3 * Copyright (C) 2007 Sebastian Freundt
5 * Author: Sebastian Freundt <hroptatyr@sxemacs.org>
7 * This file is part of SXEmacs.
9 * Redistribution and use in source and binary forms, with or without
10 * modification, are permitted provided that the following conditions
13 * 1. Redistributions of source code must retain the above copyright
14 * notice, this list of conditions and the following disclaimer.
16 * 2. Redistributions in binary form must reproduce the above copyright
17 * notice, this list of conditions and the following disclaimer in the
18 * documentation and/or other materials provided with the distribution.
20 * 3. Neither the name of the author nor the names of any contributors
21 * may be used to endorse or promote products derived from this
22 * software without specific prior written permission.
24 * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR
25 * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
26 * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
27 * DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
28 * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
29 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
30 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
31 * BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
32 * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
33 * OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
34 * IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
38 * All the code below is just a first (tacky) draught. It is optimised
39 * in a way, but still, the ardent worshippers of the DRY principle
40 * would tar and feather me for that.
44 /* Synched up with: Not in FSF, not in XE */
53 Lisp_Object Q_arity, Q_result_type, Q_mode, Q_glue;
54 Lisp_Object Q_separator, Q_initiator, Q_terminator;
55 Lisp_Object Qpntw, Qpointwise, Qpoints;
56 Lisp_Object Qkeyw, Qkeywise, Qkeys;
57 Lisp_Object Qcomb, Qcombination, Qcombinations;
58 Lisp_Object Qperm, Qpermutation, Qpermutations;
59 Lisp_Object Qcart, Qcartesian;
61 typedef Lisp_Object(*glue_f)(int nargs, Lisp_Object *args);
63 static Lisp_Object Qinplace, Qlitter, Qconcat;
64 static Lisp_Object Qvector, Qbit_vector;
67 EXFUN(Fbit_vector, MANY);
69 /* until this is available globally */
70 #define DICTP(x) (HASH_TABLEP(x) || SKIPLISTP(x))
73 Lisp_Object ini, ter, sep;
76 #define deco_ini(x) ((x)->ini)
77 #define deco_sep(x) ((x)->sep)
78 #define deco_ter(x) ((x)->ter)
82 static inline Lisp_Object
83 __Flist(int nargs, Lisp_Object *args)
84 __attribute__((always_inline));
85 static inline Lisp_Object
86 __Flist(int nargs, Lisp_Object *args)
88 /* this is just Flist() but inlined */
89 Lisp_Object val = Qnil;
90 Lisp_Object *argp = args + nargs;
93 val = Fcons(*--argp, val);
97 static long unsigned int
98 __ncombinations(register long unsigned int n, long unsigned int k)
100 /* == binomial(n, k) */
101 if (UNLIKELY(n == k || k == 0)) {
103 } else if (UNLIKELY(k == 1 || n - k == 1)) {
105 } else if (k == 2 || n - k == 2) {
106 return (n * (n-1)) >> 1;
108 /* otherwise do the hard work */
109 long unsigned int num = n*(n-1)*(n-k+1), den = k*(k-1);
111 /* swap k if necessary */
116 for (n -= 2, k -= 2; k > 1;) {
124 static long unsigned int
125 __factorial(register long unsigned int n)
127 register long unsigned int r = n;
129 /* trivial cases first */
153 for (long unsigned int i = 9; i < n; i++) {
159 static long unsigned int
160 __nvariations(register long unsigned int n, long unsigned int k)
162 /* == binomial(n, k) * factorial(k) */
163 if (UNLIKELY(k == 0)) {
165 } else if (UNLIKELY(k == n)) {
166 return __factorial(k);
167 } else if (UNLIKELY(k == 1)) {
169 } else if (UNLIKELY(n - k == 1)) {
170 return __factorial(n);
174 return n * (n-1) * (n-2);
176 /* otherwise do the hard work */
177 long unsigned int num = n--;
189 static long unsigned int
190 __ncart(register long unsigned int n, long unsigned int k)
193 long unsigned int res;
208 for (res = n * n * n * n, k -= 4; k > 0; k--) {
216 __advance_multi_index()
217 __attribute__((always_inline));
219 __advance_multi_index(long int idx[], long int j, long int fam_len)
221 /* partially unroll */
222 if (LIKELY(++idx[--j] < fam_len)) {
226 if (LIKELY(++idx[--j] < fam_len)) {
230 if (LIKELY(++idx[--j] < fam_len)) {
235 if (LIKELY(++idx[--j] < fam_len)) {
244 __advance_multi_index_2()
245 __attribute__((always_inline));
247 __advance_multi_index_2(long int idx[], long int j, size_t flen[])
249 /* improved version of __a_m_v() which allows for differently-sized families */
250 /* partially unroll */
251 if (LIKELY((--j, ++idx[j] < (long int)flen[j]))) {
255 if (LIKELY((--j, ++idx[j] < (long int)flen[j]))) {
259 if (LIKELY((--j, ++idx[j] < (long int)flen[j]))) {
264 if (LIKELY((--j, ++idx[j] < (long int)flen[j]))) {
273 __advance_multi_index_3()
274 __attribute__((always_inline));
276 __advance_multi_index_3(
277 long int idx[], long int j, size_t flen[],
278 long int nseqs, size_t arity[])
280 /* improved version of __a_m_v_2() which allows for differently-sized families
281 * and multiplicities thereof
282 * this is for cartesian indexing, i.e. the order goes
283 * [1,0]->[1,1]->[1,2]->[2,0] for arity (., 3) */
284 long int mlt = arity[--nseqs];
286 if (LIKELY(++idx[--j] < (long int)flen[nseqs])) {
291 mlt = arity[--nseqs];
293 if (LIKELY(++idx[--j] < (long int)flen[nseqs])) {
298 mlt = arity[--nseqs];
300 if (LIKELY(++idx[--j] < (long int)flen[nseqs])) {
305 mlt = arity[--nseqs];
307 while (j > 0 && nseqs >= 0) {
308 if (LIKELY(++idx[--j] < (long int)flen[nseqs])) {
313 mlt = arity[--nseqs];
320 __initialise_multi_index()
321 __attribute__((always_inline));
323 __initialise_multi_index(size_t midx[], size_t arity)
326 for (size_t j = 1; j < arity; j++) {
333 __advance_multi_index_comb()
334 __attribute__((always_inline));
336 __advance_multi_index_comb(size_t idx[], size_t len, int arity)
340 for (i = arity-1; (i >= 0) && idx[i] >= len - arity + i; i--);
342 for (; ++i < arity; ) {
345 return (idx[i-1] < len);
349 __advance_multi_index_4()
350 __attribute__((always_inline));
352 __advance_multi_index_4(
353 size_t *midx[], size_t flen[], long int j /*nseqs*/, size_t arity[])
355 /* like __a_m_v_3(), also allowing for differently-sized families
356 * and multiplicities thereof, but for for combinatorial indexing,
357 * i.e. the order goes
358 * [1,2]->[1,3]->[2,3] for arity (., 3) */
360 if (LIKELY(__advance_multi_index_comb(midx[j], flen[j], arity[j]))) {
361 /* if there's more to come, bingo */
364 /* otherwise reinitialise the mindex we're currently shagging */
365 __initialise_multi_index(midx[j], arity[j]);
368 if (LIKELY(__advance_multi_index_comb(midx[j], flen[j], arity[j]))) {
371 /* otherwise reinitialise the mindex we're currently shagging */
372 __initialise_multi_index(midx[j], arity[j]);
376 if (LIKELY(__advance_multi_index_comb(
377 midx[j], flen[j], arity[j]))) {
380 /* otherwise reinitialise the mindex we're currently shagging */
381 __initialise_multi_index(midx[j], arity[j]);
387 /* This is the guts of several mapping functions.
388 Apply FUNCTION to each element of SEQUENCE, one by one,
389 storing the results into elements of VALS, a C vector of Lisp_Objects.
390 LENI is the length of VALS, which should also be the length of SEQUENCE.
392 If VALS is a null pointer, do not accumulate the results. */
395 mapcar1(size_t leni, Lisp_Object * vals,
396 Lisp_Object function, Lisp_Object sequence)
406 memset(vals, 0, leni * sizeof(Lisp_Object));
410 if (LISTP(sequence)) {
411 /* A devious `function' could either:
412 - insert garbage into the list in front of us, causing XCDR to crash
413 - amputate the list behind us using (setcdr), causing the remaining
414 elts to lose their GCPRO status.
416 if (vals != 0) we avoid this by copying the elts into the
417 `vals' array. By a stroke of luck, `vals' is exactly large
418 enough to hold the elts left to be traversed as well as the
419 results computed so far.
421 if (vals == 0) we don't have any free space available and
422 don't want to eat up any more stack with alloca().
423 So we use EXTERNAL_LIST_LOOP_3_NO_DECLARE and GCPRO the tail. */
426 Lisp_Object *val = vals;
429 LIST_LOOP_2(elt, sequence) {
433 for (i = 0; i < leni; i++) {
435 vals[i] = Ffuncall(2, args);
438 Lisp_Object elt, tail;
439 EMACS_INT len_unused;
440 struct gcpro ngcpro1;
445 EXTERNAL_LIST_LOOP_4_NO_DECLARE(elt, sequence,
455 } else if (VECTORP(sequence)) {
456 Lisp_Object *objs = XVECTOR_DATA(sequence);
458 for (size_t i = 0; i < leni; i++) {
460 result = Ffuncall(2, args);
465 } else if (DLLISTP(sequence)) {
466 dllist_item_t elt = XDLLIST_FIRST(sequence);
468 for (size_t i = 0; elt; i++) {
469 args[1] = (Lisp_Object)elt->item;
470 result = Ffuncall(2, args);
476 } else if (STRINGP(sequence)) {
477 /* The string data of `sequence' might be relocated during GC. */
478 Bytecount slen = XSTRING_LENGTH(sequence);
481 int speccount = specpdl_depth();
484 XMALLOC_ATOMIC_OR_ALLOCA(p, slen, Bufbyte);
487 memcpy(p, XSTRING_DATA(sequence), slen);
490 args[1] = make_char(charptr_emchar(p));
492 result = Ffuncall(2, args);
497 XMALLOC_UNBIND(p, slen, speccount);
498 } else if (BIT_VECTORP(sequence)) {
499 Lisp_Bit_Vector *v = XBIT_VECTOR(sequence);
501 for (size_t i = 0; i < leni; i++) {
502 args[1] = make_int(bit_vector_bit(v, i));
503 result = Ffuncall(2, args);
509 /* unreachable, since Flength (sequence) did not get an error */
519 list_map_inplace(Lisp_Object function, Lisp_Object list)
522 struct gcpro gcpro1, gcpro2;
523 Lisp_Object elt = list;
525 GCPRO2(function, list);
530 XCAR(elt) = Ffuncall(2, args);
537 vector_map_inplace(Lisp_Object function, Lisp_Object tuple)
539 Lisp_Object *objs = XVECTOR_DATA(tuple);
541 size_t i, len = XVECTOR_LENGTH(tuple);
542 struct gcpro gcpro1, gcpro2, gcpro3;
544 GCPRO2n(function, tuple, args, countof(args));
547 for (i = 0; i < len; i++) {
549 *objs++ = Ffuncall(2, args);
556 string_map_inplace(Lisp_Object function, Lisp_Object string)
559 size_t len = XSTRING_LENGTH(string);
560 Bufbyte *p = XSTRING_DATA(string);
561 Bufbyte *end = p + len;
562 struct gcpro gcpro1, gcpro2, gcpro3;
564 GCPRO2n(function, string, args, countof(args));
568 args[1] = make_char(charptr_emchar(p));
569 args[1] = Ffuncall(2, args);
571 set_charptr_emchar(p, XCHAR(args[1]));
573 set_charptr_emchar(p, '\000');
581 bit_vector_map_inplace(Lisp_Object function, Lisp_Object bitvec)
583 Lisp_Bit_Vector *v = XBIT_VECTOR(bitvec);
585 struct gcpro gcpro1, gcpro2, gcpro3;
586 size_t i, len = bit_vector_length(XBIT_VECTOR(bitvec));
588 GCPRO2n(function, bitvec, args, countof(args));
591 for (i = 0; i < len; i++) {
592 args[1] = make_int(bit_vector_bit(v, i));
593 args[1] = Ffuncall(2, args);
594 if ((NUMBERP(args[1]) && ent_unrel_zerop(args[1])) ||
596 set_bit_vector_bit(v, i, 0);
598 set_bit_vector_bit(v, i, -1);
605 * The mapfam approach
608 /* auxiliary stuff */
610 __fam_size(Lisp_Object fam)
612 return seq_length((seq_t)(void*)fam);
616 __nfam_min_size(Lisp_Object fam[], size_t nfam)
620 /* catch the horst-case */
621 if (UNLIKELY(nfam == 0)) {
624 /* otherwise unroll a little */
625 res = __fam_size(fam[0]);
626 for (size_t j = 1; j < nfam; j++) {
627 size_t tmp = __fam_size(fam[j]);
636 __nfam_min_size_a(Lisp_Object fam[], size_t nfam, size_t arity[])
640 /* catch the horst-case */
641 if (UNLIKELY(nfam == 0)) {
644 /* otherwise unroll a little */
645 res = __fam_size(fam[0]) / arity[0];
646 for (size_t j = 1; j < nfam; j++) {
647 size_t tmp = __fam_size(fam[j]) / arity[j];
656 __nfam_cart_sum_size(size_t *sum, size_t *cart, size_t nfsz[],
657 Lisp_Object fam[], size_t nfam)
659 /* computes the size of the cartesian set and the maximum size of
660 * the union set, returns the sum of cartesian and union, and puts
661 * intermediately computed family sizes int nfsz */
663 /* catch the horst-case */
664 if (UNLIKELY(nfam == 0)) {
667 } else if (nfam == 1) {
668 /* another horst case
669 * just 1 fam should always call fam_size() */
670 return *sum = *cart = nfsz[0] = __fam_size(fam[0]);
672 /* otherwise unroll a little */
673 nfsz[0] = __fam_size(fam[0]);
674 nfsz[1] = __fam_size(fam[1]);
675 *sum = nfsz[0] + nfsz[1];
676 *cart = nfsz[0] * nfsz[1];
677 for (size_t j = 2; j < nfam; j++) {
678 nfsz[j] = __fam_size(fam[j]);
686 __my_pow_insitu(size_t *base, size_t expon)
688 /* improve me and put me somewhere else, ase-arith.h? */
689 for (size_t i = 1, b = *base; i < expon; i++) {
696 __my_pow_explicit(size_t base, size_t expon)
698 /* improve me and put me somewhere else, ase-arith.h? */
700 for (size_t i = 1; i < expon; i++) {
707 __nfam_cart_sum_size_a(size_t *sum, size_t *cart, size_t *midxsz,
709 Lisp_Object fam[], size_t nfam, size_t arity[])
711 /* computes the size of the cartesian set (put into *cart), the maximum
712 * size of the union set (returned) and the multiplicity of the
713 * multi-index (which is the cross sum of the arity array) returns the
714 * sum of cartesian and union, and puts intermediately computed family
717 /* catch the horst-case */
718 if (UNLIKELY(nfam == 0)) {
719 *sum = *cart = *midxsz = 0;
721 } else if (nfam == 1) {
722 /* another horst case
723 * just 1 fam should always call fam_size() */
724 *sum = *cart = nfsz[0] = __fam_size(fam[0]);
725 __my_pow_insitu(cart, *midxsz = arity[0]);
728 /* otherwise unroll a little */
729 nfsz[0] = __fam_size(fam[0]);
730 nfsz[1] = __fam_size(fam[1]);
731 *sum = nfsz[0] + nfsz[1];
732 *midxsz = arity[0] + arity[1];
733 *cart = __my_pow_explicit(nfsz[0], arity[0]) *
734 __my_pow_explicit(nfsz[1], arity[1]);
735 for (size_t j = 2; j < nfam; j++) {
736 nfsz[j] = __fam_size(fam[j]);
739 *cart *= __my_pow_explicit(nfsz[j], arity[j]);
745 __nfam_comb_sum_size_a(size_t *sum, size_t *comb, size_t *midxsz,
747 Lisp_Object fam[], size_t nfam, size_t arity[])
749 /* computes the size of the cartesian set (returned), the maximum size of
750 * the union set and the multiplicity of the multi-index (which is the
751 * cross sum of the arity array) returns the sum of cartesian and union,
752 * and puts intermediately computed family sizes into nfsz */
754 /* catch the horst-case */
755 if (UNLIKELY(nfam == 0)) {
756 *sum = *comb = *midxsz = 0;
758 } else if (nfam == 1) {
759 /* another horst case
760 * just 1 fam should always call fam_size() */
761 *sum = nfsz[0] = __fam_size(fam[0]);
762 *comb = __ncombinations(nfsz[0], *midxsz = arity[0]);
765 /* otherwise unroll a little */
766 nfsz[0] = __fam_size(fam[0]);
767 nfsz[1] = __fam_size(fam[1]);
768 *sum = nfsz[0] + nfsz[1];
769 *midxsz = arity[0] + arity[1];
770 *comb = __ncombinations(nfsz[0], arity[0]) *
771 __ncombinations(nfsz[1], arity[1]);
772 for (size_t j = 2; j < nfam; j++) {
773 nfsz[j] = __fam_size(fam[j]);
776 *comb *= __ncombinations(nfsz[j], arity[j]);
782 __nfam_perm_sum_size(size_t *sum, size_t *cart, size_t *perm, size_t nfsz[],
783 Lisp_Object fam[], size_t nfam)
785 /* computes the size of the cartesian set and the maximum size of
786 * the union set, returns the sum of cartesian and union, and puts
787 * intermediately computed family sizes int nfsz */
789 /* catch the horst-case */
790 if (UNLIKELY(nfam == 0)) {
791 *sum = *cart = *perm = 0;
793 } else if (nfam == 1) {
794 /* another horst case
795 * just 1 fam should always call fam_size() */
797 return *sum = *cart = nfsz[0] = __fam_size(fam[0]);
799 /* otherwise unroll a little */
800 nfsz[0] = __fam_size(fam[0]);
801 nfsz[1] = __fam_size(fam[1]);
802 *sum = nfsz[0] + nfsz[1];
803 *cart = nfsz[0] * nfsz[1];
804 for (size_t j = 2; j < nfam; j++) {
805 nfsz[j] = __fam_size(fam[j]);
809 *cart *= (*perm = __factorial(nfam));
814 __nfam_perm_sum_size_a(size_t *sum, size_t *var, size_t *perm, size_t *midxsz,
816 Lisp_Object fam[], size_t nfam, size_t arity[])
818 /* computes the size of the cartesian set (returned), the maximum size of
819 * the union set and the multiplicity of the multi-index (which is the
820 * cross sum of the arity array) returns the sum of cartesian and union,
821 * and puts intermediately computed family sizes into nfsz */
823 /* catch the horst-case */
824 if (UNLIKELY(nfam == 0)) {
825 *sum = *var = *perm = *midxsz = 0;
827 } else if (nfam == 1) {
828 /* another horst case
829 * just 1 fam should always call fam_size() */
830 *sum = nfsz[0] = __fam_size(fam[0]);
831 *perm = __factorial(*midxsz = arity[0]);
832 *var = __ncombinations(nfsz[0], arity[0]) * *perm;
835 /* otherwise unroll a little */
836 nfsz[0] = __fam_size(fam[0]);
837 nfsz[1] = __fam_size(fam[1]);
838 *sum = nfsz[0] + nfsz[1];
839 *midxsz = arity[0] + arity[1];
840 *var = __ncombinations(nfsz[0], arity[0]) *
841 __ncombinations(nfsz[1], arity[1]);
842 for (size_t j = 2; j < nfam; j++) {
843 nfsz[j] = __fam_size(fam[j]);
846 *var *= __ncombinations(nfsz[j], arity[j]);
848 /* we computed the number of combinations above, now to compute
849 * the number of variations we have to apply the S_{midxsz} on
850 * each element, hence we simply multiply with the factorial of
851 * midxsz (which is the cross sum of all arities) */
852 *var *= (*perm = __factorial(*midxsz));
857 * dedicated subroutines for 2-combs and 3-combs because they are soooo easy
860 __2comb(Lisp_Object tgts[], size_t SXE_UNUSED(tlen),
861 Lisp_Object supp[], size_t slen,
862 Lisp_Object fun, glue_f gf)
864 /* assumes that everything is gcpro'd properly */
865 Lisp_Object arr[3] = {fun, Qnil, Qnil};
867 if (LIKELY(!NILP(fun) && gf == NULL)) {
868 for (size_t i = 0, l = 0; i < slen-1; i++) {
869 for (size_t j = i+1; j < slen; j++) {
870 /* set up the array */
874 tgts[l++] = Ffuncall(countof(arr), arr);
877 } else if (LIKELY(!NILP(fun))) {
878 for (size_t i = 0, l = 0; i < slen-1; i++) {
879 for (size_t j = i+1; j < slen; j++) {
880 /* set up the array */
884 arr[1] = gf(2, &arr[1]);
886 tgts[l++] = Ffuncall(2, arr);
890 glue_f tgf = gf ? gf : Flist;
891 for (size_t i = 0, l = 0; i < slen-1; i++) {
892 for (size_t j = i+1; j < slen; j++) {
893 /* set up the array */
897 tgts[l++] = tgf(2, &arr[1]);
905 __3comb(Lisp_Object tgts[], size_t SXE_UNUSED(tlen),
906 Lisp_Object supp[], size_t slen,
907 Lisp_Object fun, glue_f gf)
909 /* assumes that everything is gcpro'd properly */
910 Lisp_Object arr[4] = {fun, Qnil, Qnil, Qnil};
912 if (LIKELY(!NILP(fun) && gf == NULL)) {
913 for (size_t i = 0, l = 0; i < slen-2; i++) {
914 for (size_t j = i+1; j < slen-1; j++) {
915 for (size_t k = j+1; k < slen; k++) {
916 /* set up the array */
921 tgts[l++] = Ffuncall(countof(arr), arr);
925 } else if (LIKELY(!NILP(fun))) {
926 for (size_t i = 0, l = 0; i < slen-2; i++) {
927 for (size_t j = i+1; j < slen-1; j++) {
928 for (size_t k = j+1; k < slen; k++) {
929 /* set up the array */
934 arr[1] = gf(3, &arr[1]);
936 tgts[l++] = Ffuncall(2, arr);
941 glue_f tgf = gf ? gf : Flist;
942 for (size_t i = 0, l = 0; i < slen-2; i++) {
943 for (size_t j = i+1; j < slen-1; j++) {
944 for (size_t k = j+1; k < slen; k++) {
945 /* set up the array */
950 tgts[l++] = tgf(3, &arr[1]);
959 __ncomb(Lisp_Object tgts[], size_t tlen,
960 Lisp_Object supp[], size_t slen,
961 Lisp_Object fun, glue_f gf,
964 /* assumes that everything is gcpro'd properly */
967 Lisp_Object fc[arity+1], *v = &fc[1];
970 memset(idx, 0, arity*sizeof(long int));
971 memset(v, 0, arity*sizeof(Lisp_Object));
974 /* special case slen == arity */
975 if (UNLIKELY(slen == arity)) {
976 if (LIKELY(!NILP(fun) && gf == NULL)) {
977 tgts[0] = Ffuncall(slen, supp);
978 } else if (LIKELY(!NILP(fun))) {
979 v[0] = gf(slen, supp);
980 tgts[0] = Ffuncall(2, fc);
982 glue_f tgf = gf ? gf : Flist;
983 tgts[0] = tgf(slen, supp);
988 /* setup, partially unrolled */
991 for (size_t i = 2; i < arity; i++) {
995 if (LIKELY(!NILP(fun) && gf == NULL)) {
999 for (size_t i = 2; i < arity; i++) {
1000 v[i] = supp[idx[i]];
1003 tgts[l++] = Ffuncall(countof(fc), fc);
1004 /* increment, fooking back'n'forth-loop-based
1006 (void)__advance_multi_index_comb(idx, slen, arity);
1008 } else if (LIKELY(!NILP(fun))) {
1010 v[0] = supp[idx[0]];
1011 v[1] = supp[idx[1]];
1012 for (size_t i = 2; i < arity; i++) {
1013 v[i] = supp[idx[i]];
1016 v[0] = gf(arity, v);
1018 tgts[l++] = Ffuncall(2, fc);
1019 /* increment, fooking back'n'forth-loop-based
1021 (void)__advance_multi_index_comb(idx, slen, arity);
1024 glue_f tgf = gf ? gf : Flist;
1026 v[0] = supp[idx[0]];
1027 v[1] = supp[idx[1]];
1028 for (size_t i = 2; i < arity; i++) {
1029 v[i] = supp[idx[i]];
1032 tgts[l++] = tgf(arity, v);
1033 /* increment, fooking back'n'forth-loop-based
1035 (void)__advance_multi_index_comb(idx, slen, arity);
1043 * dedicated subroutines for 2-perms and 3-perms because they are soooo easy
1044 * 2-perms (transpositions) is just a 2-cycle along with its transposition,
1045 * so we can directly reuse the comb algorithm
1046 * 3-perms are just as simple, since the generation of S_3 can simply be put
1047 * as (), a, a^2, b, a*b, a^2*b where a is a 3-cycle and b a 2-cycle.
1049 static inline size_t
1050 __2perm_fun(Lisp_Object tgts[], size_t SXE_UNUSED(tlen),
1051 Lisp_Object supp[], size_t SXE_UNUSED(slen),
1054 __attribute__((always_inline));
1055 static inline size_t
1056 __2perm_fun(Lisp_Object tgts[], size_t SXE_UNUSED(tlen),
1057 Lisp_Object supp[], size_t SXE_UNUSED(slen),
1061 /* apply fun on S_2 on (the first two elements of) supp */
1062 Lisp_Object arr[3] = {fun, Qnil, Qnil};
1064 /* set up the array */
1068 tgts[offset++] = Ffuncall(countof(arr), arr);
1070 /* swap them == (1,2) */
1074 tgts[offset++] = Ffuncall(countof(arr), arr);
1078 static inline size_t
1079 __2perm_glue_fun(Lisp_Object tgts[], size_t SXE_UNUSED(tlen),
1080 Lisp_Object supp[], size_t SXE_UNUSED(slen),
1081 Lisp_Object fun, glue_f gf,
1083 __attribute__((always_inline));
1084 static inline size_t
1085 __2perm_glue_fun(Lisp_Object tgts[], size_t SXE_UNUSED(tlen),
1086 Lisp_Object supp[], size_t SXE_UNUSED(slen),
1087 Lisp_Object fun, glue_f gf,
1090 /* apply fun on the glue of S_2 on (the first two elements of) supp */
1091 Lisp_Object arr[3] = {fun, Qnil, Qnil};
1093 /* set up the array */
1097 arr[1] = gf(2, &arr[1]);
1099 tgts[offset++] = Ffuncall(2, arr);
1101 /* swap them == (1,2) */
1105 arr[1] = gf(2, &arr[1]);
1107 tgts[offset++] = Ffuncall(2, arr);
1111 static inline size_t
1112 __2perm_glue(Lisp_Object tgts[], size_t SXE_UNUSED(tlen),
1113 Lisp_Object supp[], size_t SXE_UNUSED(slen),
1116 __attribute__((always_inline));
1117 static inline size_t
1118 __2perm_glue(Lisp_Object tgts[], size_t SXE_UNUSED(tlen),
1119 Lisp_Object supp[], size_t SXE_UNUSED(slen),
1123 /* glue of S_2 on (the first two elements of) supp */
1124 volatile Lisp_Object tmp = supp[0];
1126 /* directly apply glue */
1127 tgts[offset++] = gf(2, supp);
1129 /* swap them == (1,2) */
1133 tgts[offset++] = gf(2, supp);
1137 static inline size_t
1138 _2perm(Lisp_Object tgts[], size_t tlen,
1139 Lisp_Object supp[], size_t slen,
1140 Lisp_Object fun, glue_f gf,
1143 /* assumes that everything is gcpro'd correctly */
1144 if (LIKELY(!NILP(fun) && gf == NULL)) {
1145 return __2perm_fun(tgts, tlen, supp, slen, fun, offset);
1146 } else if (LIKELY(!NILP(fun))) {
1147 return __2perm_glue_fun(tgts, tlen, supp, slen,
1150 return __2perm_glue(tgts, tlen, supp, slen,
1151 gf ? gf : Flist, offset);
1156 _comb_2perm(Lisp_Object *tgts, size_t tlen,
1157 Lisp_Object *supp, size_t slen,
1158 Lisp_Object fun, glue_f gf)
1160 /* loop over everything in supp and form combinations thereof,
1162 * assumes that everything is gcpro'd correctly */
1163 Lisp_Object v[2] = {Qnil, Qnil};
1165 if (LIKELY(!NILP(fun) && gf == NULL)) {
1166 for (size_t i = 0, l = 0; i < slen-1; i++) {
1167 for (size_t j = i+1; j < slen; j++) {
1170 l = __2perm_fun(tgts, tlen, v, 2, fun, l);
1174 } else if (LIKELY(!NILP(fun))) {
1175 for (size_t i = 0, l = 0; i < slen-1; i++) {
1176 for (size_t j = i+1; j < slen; j++) {
1179 l = __2perm_glue_fun(
1180 tgts, tlen, v, 2, fun, gf, l);
1185 glue_f tgf = gf ? gf : Flist;
1186 for (size_t i = 0, l = 0; i < slen-1; i++) {
1187 for (size_t j = i+1; j < slen; j++) {
1190 l = __2perm_glue(tgts, tlen, v, 2, tgf, l);
1198 static inline size_t
1199 __3perm_fun(Lisp_Object tgts[], size_t SXE_UNUSED(tlen),
1200 Lisp_Object supp[], size_t SXE_UNUSED(slen),
1203 __attribute__((always_inline));
1204 static inline size_t
1205 __3perm_fun(Lisp_Object tgts[], size_t SXE_UNUSED(tlen),
1206 Lisp_Object supp[], size_t SXE_UNUSED(slen),
1210 /* apply fun on S_3 on (the first 3 elements of) supp */
1211 Lisp_Object arr[4] = {fun, Qnil, Qnil, Qnil};
1213 /* we use gap's order of the elements of S3
1214 * gap> Elements(SymmetricGroup(3));
1215 * [ (), (2,3), (1,2), (1,2,3), (1,3,2), (1,3) ] */
1222 tgts[offset++] = Ffuncall(countof(arr), arr);
1228 tgts[offset++] = Ffuncall(countof(arr), arr);
1235 tgts[offset++] = Ffuncall(countof(arr), arr);
1241 tgts[offset++] = Ffuncall(countof(arr), arr);
1248 tgts[offset++] = Ffuncall(countof(arr), arr);
1254 tgts[offset++] = Ffuncall(countof(arr), arr);
1259 static inline size_t
1260 __3perm_glue_fun(Lisp_Object tgts[], size_t SXE_UNUSED(tlen),
1261 Lisp_Object supp[], size_t SXE_UNUSED(slen),
1262 Lisp_Object fun, glue_f gf,
1264 __attribute__((always_inline));
1265 static inline size_t
1266 __3perm_glue_fun(Lisp_Object tgts[], size_t SXE_UNUSED(tlen),
1267 Lisp_Object supp[], size_t SXE_UNUSED(slen),
1268 Lisp_Object fun, glue_f gf,
1271 /* apply fun on the glue of S_3 on (the first 3 elements of) supp */
1272 Lisp_Object arr[4] = {fun, Qnil, Qnil, Qnil};
1274 /* we use gap's order of the elements of S3
1275 * gap> Elements(SymmetricGroup(3));
1276 * [ (), (2,3), (1,2), (1,2,3), (1,3,2), (1,3) ] */
1283 arr[1] = gf(3, &arr[1]);
1285 tgts[offset++] = Ffuncall(2, arr);
1292 arr[1] = gf(3, &arr[1]);
1294 tgts[offset++] = Ffuncall(2, arr);
1301 arr[1] = gf(3, &arr[1]);
1303 tgts[offset++] = Ffuncall(2, arr);
1310 arr[1] = gf(3, &arr[1]);
1312 tgts[offset++] = Ffuncall(2, arr);
1319 arr[1] = gf(3, &arr[1]);
1321 tgts[offset++] = Ffuncall(2, arr);
1328 arr[1] = gf(3, &arr[1]);
1330 tgts[offset++] = Ffuncall(2, arr);
1335 static inline size_t
1336 __3perm_glue(Lisp_Object tgts[], size_t SXE_UNUSED(tlen),
1337 Lisp_Object supp[], size_t SXE_UNUSED(slen),
1340 __attribute__((always_inline));
1341 static inline size_t
1342 __3perm_glue(Lisp_Object tgts[], size_t SXE_UNUSED(tlen),
1343 Lisp_Object supp[], size_t SXE_UNUSED(slen),
1347 /* glue of S_3 on (the first 3 elements of) supp */
1348 volatile Lisp_Object tmp;
1350 /* we use gap's order of the elements of S3
1351 * gap> Elements(SymmetricGroup(3));
1352 * [ (), (2,3), (1,2), (1,2,3), (1,3,2), (1,3) ] */
1354 /* (), directly apply glue */
1355 tgts[offset++] = gf(3, supp);
1362 tgts[offset++] = gf(3, supp);
1364 /* (0,1) == (0,1)(1,2)(1,2) == (0,1,2)(1,2) */
1370 tgts[offset++] = gf(3, supp);
1372 /* (0,1,2) == (0,2)(0,1) */
1377 tgts[offset++] = gf(3, supp);
1379 /* (0,2,1) == (0,1,2)(0,1,2) */
1385 tgts[offset++] = gf(3, supp);
1387 /* (0,2) == (0,1)(0,2,1) */
1392 tgts[offset++] = gf(3, supp);
1398 _comb_3perm(Lisp_Object *tgts, size_t tlen,
1399 Lisp_Object *supp, size_t slen,
1400 Lisp_Object fun, glue_f gf)
1402 /* loop over everything in supp and form combinations thereof,
1404 * assumes that everything is gcpro'd correctly */
1405 Lisp_Object v[3] = {Qnil, Qnil, Qnil};
1407 if (LIKELY(!NILP(fun) && gf == NULL)) {
1408 for (size_t i = 0, l = 0; i < slen-2; i++) {
1409 for (size_t j = i+1; j < slen-1; j++) {
1410 for (size_t k = j+1; k < slen; k++) {
1415 tgts, tlen, v, 3, fun, l);
1420 } else if (LIKELY(!NILP(fun))) {
1421 for (size_t i = 0, l = 0; i < slen-2; i++) {
1422 for (size_t j = i+1; j < slen-1; j++) {
1423 for (size_t k = j+1; k < slen; k++) {
1427 l = __3perm_glue_fun(
1428 tgts, tlen, v, 3, fun, gf, l);
1434 glue_f tgf = gf ? gf : Flist;
1435 for (size_t i = 0, l = 0; i < slen-2; i++) {
1436 for (size_t j = i+1; j < slen-1; j++) {
1437 for (size_t k = j+1; k < slen; k++) {
1442 tgts, tlen, v, 3, tgf, l);
1451 __transpose(Lisp_Object arr[], size_t i, size_t j)
1452 __attribute__((always_inline));
1454 __transpose(Lisp_Object arr[], size_t i, size_t j)
1456 /* use xchg assembly? */
1457 volatile Lisp_Object tmp = arr[i];
1463 static inline long int
1464 __divmod3(long int *_div_, long int num)
1465 __attribute__((always_inline));
1467 /* idivl uses >48 cycles, which is too slow for division by constants */
1468 static inline long int
1469 __divmod3(long int *_div_, long int num)
1471 /* compute _DIV_ div 3 and _DIV_ mod 3,
1472 * store the divisor in `_DIV_', the remainder in `_REM_' */
1476 __asm__("idivl %[modulus]; /* eax,edx = eax idivl 3 */\n\t"
1477 : "=&d" (_rem_), "+%a" (*_div_)
1478 : [modulus] "rm" (3) : "cc");
1482 static inline long int
1483 __divmod3(long int *_div_, long int num)
1485 long int rem = num % 3;
1491 static inline long int
1492 __divmodk(long int *_div_, long int modulus)
1493 __attribute__((always_inline));
1495 static inline long int
1496 __divmodk(long int *_div_, long int modulus)
1498 /* compute _DIV_ div MODULUS and _DIV_ mod MODULUS,
1499 * store the divisor in `_DIV_', the remainder in `_REM_'
1500 * this assembler version takes ... cycles on x86 and x86_64 processors,
1501 * however the generated code below seems to be faster -- and is more
1502 * portable anyway, since it's C */
1505 __asm__("idivl %[modulus]; /* eax,edx = eax idivl 3 */\n\t"
1506 : "=&d" (_rem_), "+%a" (*_div_)
1507 : [modulus] "rm" (modulus) : "cc");
1511 static inline long int
1512 __divmodk(long int *_div_, long int modulus)
1514 long int rem = *_div_ % modulus;
1521 __bruhat(Lisp_Object arr[], long int k)
1522 __attribute__((always_inline));
1524 __bruhat(Lisp_Object arr[], long int k)
1526 /* computes the k-th transposition in quasi bruhat order and
1527 * applies it to arr */
1529 if (UNLIKELY(k == 0)) {
1533 /* odd Ks always connote (0,1) */
1534 __transpose(arr, 0, 1);
1536 } else if (__divmod3(&k, (k >>= 1))) {
1537 /* 1 mod 3 and 2 mod 3 go to (1,2) */
1538 __transpose(arr, 1, 2);
1542 /* otherwise k is 0 mod 3 (and we divided by 3 already)
1543 * now we've factored out S_3 already */
1544 switch (k & 3 /* k % 4 */) {
1546 __transpose(arr, 2, 3);
1549 __transpose(arr, 0, 3);
1552 __transpose(arr, 1, 3);
1559 /* S_2, S_3, and S_4 is handled about, go on with S_5 now */
1560 for (int i = 5; k; i++) {
1562 if ((rem = __divmodk(&k, i))) {
1563 if (i & 1 || (rem -= 2) < 0) {
1564 /* odd i always induces the
1565 * (i-1, i) transposition
1566 * in C this is (i-2, i-1) */
1567 __transpose(arr, i-2, i-1);
1569 /* even i is uglier :(
1570 * if rem == 1 -> (i-1, i)
1571 * if rem == 2 -> (1, i)
1572 * if rem == 3 -> (2, i)
1574 __transpose(arr, rem, i-1);
1575 /* note: we treated the rem == 1 case above */
1583 static inline size_t
1584 __Sn_fun(Lisp_Object tgts[], size_t tlen,
1585 Lisp_Object supp[], size_t slen,
1588 __attribute__((always_inline));
1589 static inline size_t
1590 __Sn_fun(Lisp_Object tgts[], size_t tlen,
1591 Lisp_Object supp[], size_t slen,
1595 /* apply FUN on S_n on (the first SLEN elements of) SUPP
1596 * put results into TGTS
1597 * assumes that everything is gcpro'd correctly
1598 * also assumes that tlen == __factorial(slen) */
1599 Lisp_Object arr[slen+1], *v = &arr[1];
1601 /* setup, partially unrolled */
1606 for (size_t i = 3; i < slen; i++) {
1610 /* now we're in the setting ... */
1611 /* we enter the perm loop now, the first addition is the vector
1612 * times identity permutation */
1613 while (tlen-- > 0) {
1614 tgts[offset++] = Ffuncall(countof(arr), arr);
1615 /* permute the working vector */
1616 __bruhat(v, offset);
1621 static inline size_t
1622 __Sn_glue_fun(Lisp_Object tgts[], size_t tlen,
1623 Lisp_Object supp[], size_t slen,
1624 Lisp_Object fun, glue_f gf,
1626 __attribute__((always_inline));
1627 static inline size_t
1628 __Sn_glue_fun(Lisp_Object tgts[], size_t tlen,
1629 Lisp_Object supp[], size_t slen,
1630 Lisp_Object fun, glue_f gf,
1633 /* apply FUN on glue of S_n on (the first SLEN elements of) SUPP
1634 * put results into TGTS
1635 * assumes that everything is gcpro'd correctly
1636 * also assumes that tlen == __factorial(slen) */
1637 Lisp_Object arr[slen+1], *v = &arr[1];
1639 /* setup, partially unrolled */
1644 for (size_t i = 3; i < slen; i++) {
1648 /* now we're in the setting ... */
1649 /* we enter the perm loop now, the first addition is the vector
1650 * times identity permutation */
1651 while (tlen-- > 0) {
1652 /* backup that first slot */
1653 volatile Lisp_Object tmp = v[0];
1655 tgts[offset++] = Ffuncall(2, arr);
1656 /* recover from backup slot */
1658 /* permute the working vector */
1659 __bruhat(v, offset);
1664 static inline size_t
1665 __Sn_glue(Lisp_Object tgts[], size_t tlen,
1666 Lisp_Object supp[], size_t slen,
1669 __attribute__((always_inline));
1670 static inline size_t
1671 __Sn_glue(Lisp_Object tgts[], size_t tlen,
1672 Lisp_Object supp[], size_t slen,
1676 /* glue of S_n on (the first SLEN elements of) SUPP
1677 * put results into TGTS
1678 * assumes that everything is gcpro'd correctly
1679 * also assumes that tlen == __factorial(slen) */
1680 Lisp_Object arr[slen];
1682 /* setup, partially unrolled */
1686 for (size_t i = 3; i < slen; i++) {
1690 /* now we're in the setting ... */
1691 /* we enter the perm loop now, the first addition is the vector
1692 * times identity permutation */
1693 while (tlen-- > 0) {
1694 tgts[offset++] = gf(countof(arr), arr);
1695 /* permute the working vector */
1696 __bruhat(arr, offset);
1701 static inline void /* inline this? */
1702 _Sn(Lisp_Object tgts[], size_t tlen,
1703 Lisp_Object supp[], size_t slen,
1704 Lisp_Object fun, glue_f gf)
1705 __attribute__((always_inline));
1707 _Sn(Lisp_Object tgts[], size_t tlen,
1708 Lisp_Object supp[], size_t slen,
1709 Lisp_Object fun, glue_f gf)
1711 /* assumes that everything is gcpro'd correctly
1712 * this is just an intermediate switch, the hard work happens in
1713 * __Sn_fun(), __Sn_glue_fun() and __Sn_glue() depending on whether
1714 * just a function and no glue has been specified, a function and a glue
1715 * function has been specified, or just a glue function has been
1716 * specified respectively */
1718 if (LIKELY(!NILP(fun) && gf == NULL)) {
1719 (void)__Sn_fun(tgts, tlen, supp, slen, fun, 0);
1720 } else if (LIKELY(!NILP(fun))) {
1721 (void)__Sn_glue_fun(tgts, tlen, supp, slen, fun, gf, 0);
1723 glue_f tgf = gf ? gf : Flist;
1724 (void)__Sn_glue(tgts, tlen, supp, slen, tgf, 0);
1730 _comb_Sn(Lisp_Object tgts[], size_t tlen,
1731 Lisp_Object supp[], size_t slen,
1732 Lisp_Object fun, glue_f gf,
1735 /* assumes that everything is gcpro'd correctly
1736 * this has the same signature as _Sn() but additionally there's the
1738 * this is basically the code for variations, i.e. applying the S_m
1739 * (m < n) on some subset of size m of a set of size n */
1740 Lisp_Object v[arity];
1741 size_t idx[arity+1];
1742 size_t l = 0, np = __factorial(arity);
1745 memset(idx, 0, arity*sizeof(long int));
1747 /* more setup, partially unrolled */
1751 for (size_t i = 3; i < arity; i++) {
1755 if (LIKELY(!NILP(fun) && gf == NULL)) {
1757 /* get the combinations, serves as starting set,
1758 * partially unrolled */
1759 v[0] = supp[idx[0]];
1760 v[1] = supp[idx[1]];
1761 v[2] = supp[idx[2]];
1762 for (size_t i = 3; i < arity; i++) {
1763 v[i] = supp[idx[i]];
1765 /* do the rain dance */
1766 l = __Sn_fun(tgts, np, v, arity, fun, l);
1767 /* increment, fooking back'n'forth-loop-based
1769 (void)__advance_multi_index_comb(idx, slen, arity);
1771 } else if (LIKELY(!NILP(fun))) {
1773 /* get the combinations, serves as starting set,
1774 * partially unrolled */
1775 v[0] = supp[idx[0]];
1776 v[1] = supp[idx[1]];
1777 v[2] = supp[idx[2]];
1778 for (size_t i = 3; i < arity; i++) {
1779 v[i] = supp[idx[i]];
1781 /* do the rain dance */
1782 l = __Sn_glue_fun(tgts, np, v, arity, fun, gf, l);
1783 /* increment, fooking back'n'forth-loop-based
1785 (void)__advance_multi_index_comb(idx, slen, arity);
1788 glue_f tgf = gf ? gf : Flist;
1790 /* get the combinations, serves as starting set,
1791 * partially unrolled */
1792 v[0] = supp[idx[0]];
1793 v[1] = supp[idx[1]];
1794 v[2] = supp[idx[2]];
1795 for (size_t i = 3; i < arity; i++) {
1796 v[i] = supp[idx[i]];
1798 /* do the rain dance */
1799 l = __Sn_glue(tgts, np, v, arity, tgf, l);
1800 /* increment, fooking back'n'forth-loop-based
1802 (void)__advance_multi_index_comb(idx, slen, arity);
1810 _2cart(Lisp_Object tgts[], size_t tlen,
1811 Lisp_Object supp[], size_t slen,
1812 Lisp_Object fun, glue_f gf)
1814 /* assumes that everything is gcpro'd properly
1815 * This function can GC */
1816 Lisp_Object arr[3] = {fun, Qnil, Qnil};
1818 if (LIKELY(!NILP(fun) && gf == NULL)) {
1819 for (size_t i = 0, l = 0; i < slen; i++) {
1820 for (size_t j = 0; j < slen; j++) {
1821 /* set up the array */
1825 tgts[l++] = Ffuncall(countof(arr), arr);
1828 } else if (LIKELY(!NILP(fun))) {
1829 for (size_t i = 0, l = 0; i < slen; i++) {
1830 for (size_t j = 0; j < slen; j++) {
1831 /* set up the array */
1835 arr[1] = gf(2, &arr[1]);
1837 tgts[l++] = Ffuncall(2, arr);
1841 glue_f tgf = gf ? gf : Flist;
1842 for (size_t i = 0, l = 0; i < slen; i++) {
1843 for (size_t j = 0; j < slen; j++) {
1844 /* set up the array */
1848 tgts[l++] = tgf(2, &arr[1]);
1856 _3cart(Lisp_Object tgts[], size_t tlen,
1857 Lisp_Object supp[], size_t slen,
1858 Lisp_Object fun, glue_f gf)
1860 /* assumes that everything is gcpro'd properly
1861 * This function can GC */
1862 Lisp_Object arr[4] = {fun, Qnil, Qnil, Qnil};
1864 if (LIKELY(!NILP(fun) && gf == NULL)) {
1865 for (size_t i = 0, l = 0; i < slen; i++) {
1866 for (size_t j = 0; j < slen; j++) {
1867 for (size_t k = 0; k < slen; k++) {
1868 /* set up the array */
1873 tgts[l++] = Ffuncall(countof(arr), arr);
1877 } else if (LIKELY(!NILP(fun))) {
1878 for (size_t i = 0, l = 0; i < slen; i++) {
1879 for (size_t j = 0; j < slen; j++) {
1880 for (size_t k = 0; k < slen; k++) {
1881 /* set up the array */
1886 arr[1] = gf(3, &arr[1]);
1888 tgts[l++] = Ffuncall(2, arr);
1893 glue_f tgf = gf ? gf : Flist;
1894 for (size_t i = 0, l = 0; i < slen; i++) {
1895 for (size_t j = 0; j < slen; j++) {
1896 for (size_t k = 0; k < slen; k++) {
1897 /* set up the array */
1902 tgts[l++] = tgf(3, &arr[1]);
1911 _ncart(Lisp_Object tgts[], size_t tlen,
1912 Lisp_Object supp[], size_t slen,
1913 Lisp_Object fun, glue_f gf,
1916 /* assumes that everything is gcpro'd properly
1917 * This function can GC */
1918 long int idx[arity]; /* the multi-index */
1920 Lisp_Object fc[arity+1], *v = &fc[1];
1923 memset(idx, 0, arity*sizeof(long int));
1924 memset(v, 0, arity*sizeof(Lisp_Object));
1927 /* now we're in the setting ... */
1928 if (LIKELY(!NILP(fun) && gf == NULL)) {
1930 /* get the fam data, partially unrolled */
1931 v[0] = supp[idx[0]];
1932 v[1] = supp[idx[1]];
1933 v[2] = supp[idx[2]];
1934 for (size_t i = 3; i < arity; i++) {
1935 v[i] = supp[idx[i]];
1938 tgts[l++] = Ffuncall(countof(fc), fc);
1939 /* advance the multi-index, partially unrolled */
1940 __advance_multi_index(idx, arity, slen);
1942 } else if (LIKELY(!NILP(fun))) {
1944 /* get the fam data, partially unrolled */
1945 v[0] = supp[idx[0]];
1946 v[1] = supp[idx[1]];
1947 v[2] = supp[idx[2]];
1948 for (size_t i = 3; i < arity; i++) {
1949 v[i] = supp[idx[i]];
1952 v[0] = gf(arity, v);
1954 tgts[l++] = Ffuncall(2, fc);
1955 /* advance the multi-index, partially unrolled */
1956 __advance_multi_index(idx, arity, slen);
1959 glue_f tgf = gf ? gf : Flist;
1961 /* get the fam data, partially unrolled */
1962 v[0] = supp[idx[0]];
1963 v[1] = supp[idx[1]];
1964 v[2] = supp[idx[2]];
1965 for (size_t i = 3; i < arity; i++) {
1966 v[i] = supp[idx[i]];
1969 tgts[l++] = tgf(arity, v);
1970 /* advance the multi-index, partially unrolled */
1971 __advance_multi_index(idx, arity, slen);
1979 __dress_result(Lisp_Object rtype, Lisp_Object arr[], size_t len)
1981 /* from most likely to least likely */
1982 if (EQ(rtype, Qlist)) {
1983 return __Flist(len, arr);
1984 } else if (EQ(rtype, Qvector)) {
1985 return Fvector(len, arr);
1986 } else if (EQ(rtype, Qdllist)) {
1987 return Fdllist(len, arr);
1988 } else if (EQ(rtype, Qlitter) || EQ(rtype, Qvoid)) {
1990 } else if (EQ(rtype, Qinplace)) {
1992 } else if (EQ(rtype, Qstring)) {
1993 return Fstring(len, arr);
1994 } else if (EQ(rtype, Qbit_vector)) {
1995 return Fbit_vector(len, arr);
1996 } else if (EQ(rtype, Qconcat)) {
1997 return Fconcat(len, arr);
2002 static inline size_t
2003 __explode_1dict(Lisp_Object *restrict tkeys, Lisp_Object *restrict tvals,
2004 Lisp_Object dict, size_t len)
2005 __attribute__((always_inline));
2006 static inline size_t
2007 __explode_1dict(Lisp_Object *restrict tkeys, Lisp_Object *restrict tvals,
2008 Lisp_Object dict, size_t len)
2011 dict_t d = (dict_t)(void*)dict;
2012 struct dict_iter_s _di, *di = &_di;
2014 dict_iter_init(d, di);
2017 Lisp_Object key, val;
2018 dict_iter_next(di, &key, &val);
2019 if (LIKELY(key != Qnull_pointer)) {
2033 __comb_1seq(Lisp_Object seq, Lisp_Object fun, size_t arity,
2034 glue_f gluef, Lisp_Object result_type)
2036 size_t fs = __fam_size(seq);
2037 size_t nc = __ncombinations(fs, arity != -1UL ? arity : (arity = fs));
2038 /* C99 we need you */
2039 size_t maxsz = __sys_stk_free() / sizeof(Lisp_Object);
2041 /* leave room for stuff after us,
2042 * we call a function on this, so leave plenty of space */
2044 ? nc + fs /* actually we just need nc + arity - 1 */
2046 Lisp_Object __vals[leni], *vals, *rvals, result;
2048 struct gcpro gcpro1;
2050 if (UNLIKELY(arity == 0 || nc == 0)) {
2052 return __dress_result(result_type, NULL, 0);
2055 if (UNLIKELY(leni == 0)) {
2056 speccnt = specpdl_depth();
2057 vals = xnew_array(Lisp_Object, nc + fs);
2058 record_unwind_protect(free_malloced_ptr, make_opaque_ptr(vals));
2063 /* explode the sequence */
2064 memset(vals, 0, nc * sizeof(Lisp_Object));
2065 (void)seq_explode((void*restrict*)&vals[nc], fs, (seq_t)seq);
2067 GCPROn(vals, nc+fs);
2070 /* the same as pntw mode */
2072 if (UNLIKELY(NILP(fun) || nc == 0UL)) {
2077 for (size_t i = nc; i < nc + fs; i++) {
2078 Lisp_Object args[2] = {fun, vals[i]};
2079 vals[i] = Ffuncall(2, args);
2084 __2comb(vals, nc, &vals[nc], fs, fun, gluef);
2088 __3comb(vals, nc, &vals[nc], fs, fun, gluef);
2092 __ncomb(vals, nc, &vals[nc], fs, fun, gluef, arity);
2096 result = __dress_result(result_type, rvals, nc);
2098 if (UNLIKELY(leni == 0)) {
2099 unbind_to(speccnt, Qnil);
2105 __perm_1seq(Lisp_Object seq, Lisp_Object fun, size_t arity,
2106 glue_f gluef, Lisp_Object result_type)
2108 size_t fs = __fam_size(seq);
2109 size_t nv = __nvariations(fs, arity != -1UL ? arity : (arity = fs));
2110 /* C99 we need you */
2111 size_t maxsz = __sys_stk_free() / sizeof(Lisp_Object);
2113 /* leave room for stuff after us,
2114 * we call a function on this, so leave plenty of space */
2118 Lisp_Object __vals[leni], *vals, *rvals = NULL, result;
2120 struct gcpro gcpro1;
2122 if (UNLIKELY(leni == 0)) {
2123 speccnt = specpdl_depth();
2124 vals = xnew_array(Lisp_Object, nv + fs);
2125 record_unwind_protect(free_malloced_ptr, make_opaque_ptr(vals));
2130 if (UNLIKELY(arity == 0)) {
2132 return __dress_result(result_type, NULL, 0);
2135 /* explode the sequence */
2136 memset(vals, 0, (nv) * sizeof(Lisp_Object));
2137 (void)seq_explode((void*restrict*)&vals[nv], fs, (seq_t)seq);
2139 GCPROn(vals, nv + fs);
2142 /* the same as pntw mode */
2144 if (UNLIKELY(NILP(fun) || nv == 0UL)) {
2149 for (size_t i = nv; i < nv+fs; i++) {
2150 Lisp_Object args[2] = {fun, vals[i]};
2151 vals[i] = Ffuncall(2, args);
2156 _comb_2perm(vals, nv, &vals[nv], fs, fun, gluef);
2160 _comb_3perm(vals, nv, &vals[nv], fs, fun, gluef);
2164 if (LIKELY(fs != arity)) {
2165 _comb_Sn(vals, nv, &vals[nv], fs, fun, gluef, arity);
2167 /* optimised for mere permutations */
2168 _Sn(vals, nv, &vals[nv], fs /*== arity*/, fun, gluef);
2173 result = __dress_result(result_type, rvals, nv);
2175 if (UNLIKELY(leni == 0)) {
2176 unbind_to(speccnt, Qnil);
2182 __cart_1seq(Lisp_Object seq, Lisp_Object fun, size_t arity,
2183 glue_f gluef, Lisp_Object result_type)
2185 size_t fs = __fam_size(seq);
2186 size_t nc = __ncart(fs, arity);
2187 /* C99 we need you */
2188 size_t maxsz = __sys_stk_free() / sizeof(Lisp_Object);
2190 /* leave room for stuff after us,
2191 * we call a function on this, so leave plenty of space */
2195 Lisp_Object __vals[leni], *vals, result;
2197 struct gcpro gcpro1;
2199 if (UNLIKELY(arity == 0)) {
2201 return __dress_result(result_type, NULL, 0);
2204 if (UNLIKELY(leni == 0)) {
2205 speccnt = specpdl_depth();
2206 vals = xnew_array(Lisp_Object, nc);
2207 record_unwind_protect(free_malloced_ptr, make_opaque_ptr(vals));
2212 /* explode the sequence */
2213 memset(vals, 0, (nc - fs) * sizeof(Lisp_Object));
2214 seq_explode((void*restrict*)&vals[nc - fs], fs, (seq_t)seq);
2219 /* the same as pntw mode */
2221 if (UNLIKELY(NILP(fun) || nc == 0UL)) {
2225 for (size_t i = 0; i < nc; i++) {
2226 Lisp_Object args[2] = {fun, vals[i]};
2227 vals[i] = Ffuncall(2, args);
2231 _2cart(vals, nc, &vals[nc-fs], fs, fun, gluef);
2234 _3cart(vals, nc, &vals[nc-fs], fs, fun, gluef);
2237 _ncart(vals, nc, &vals[nc-fs], fs, fun, gluef, arity);
2240 result = __dress_result(result_type, vals, nc);
2242 if (UNLIKELY(leni == 0)) {
2243 unbind_to(speccnt, Qnil);
2249 __pntw_1seq(Lisp_Object seq, Lisp_Object fun, size_t arity,
2250 glue_f gluef, Lisp_Object result_type,
2251 volatile struct decoration_s *deco)
2253 size_t nseq = __fam_size(seq);
2254 /* C99 we need you */
2255 size_t maxsz = __sys_stk_free() / sizeof(Lisp_Object);
2256 size_t totlen = nseq + 2 /* for ini and ter */ +
2257 (deco_sep(deco) ? nseq : 0);
2259 /* leave room for stuff after us,
2260 * we call a function on this, so leave plenty of space */
2265 Lisp_Object __vals[leni+1], *vals, *seqelts, result;
2268 /* expherts alarm */
2269 return __dress_result(result_type, NULL, 0);
2271 if (UNLIKELY(leni == 0)) {
2272 vals = xnew_array(Lisp_Object, totlen);
2277 /* start maybe with the initiator */
2278 if (UNLIKELY(deco_ini(deco) != Qnull_pointer)) {
2279 vals[len++] = deco_ini(deco);
2281 /* explode the sequence */
2282 if (LIKELY(deco_sep(deco) == Qnull_pointer)) {
2283 seqelts = &vals[len];
2285 seqelts = vals + (deco_sep(deco) ? nseq : 0);
2286 memset(&vals[len], 0, sizeof(Lisp_Object) * nseq);
2288 (void)seq_explode((void*restrict*)seqelts, nseq, (seq_t)seq);
2290 /* fill the rest with naughts */
2291 memset(&seqelts[nseq], 0, (totlen - len - nseq) * sizeof(Lisp_Object));
2294 struct gcpro gcpro1;
2296 if (UNLIKELY(NILP(fun))) {
2297 if (LIKELY(deco_sep(deco) != Qnull_pointer)) {
2299 for (size_t i = 0; i < nseq; i++) {
2300 vals[len++] = seqelts[i];
2301 vals[len++] = deco_sep(deco);
2303 /* because we dont want the last element to
2304 * be followed by a separator */
2312 GCPROn(vals, totlen);
2314 for (size_t i = 0; i < nseq; i++) {
2315 Lisp_Object args[2] = {fun, seqelts[i]};
2316 vals[len++] = Ffuncall(2, args);
2317 if (UNLIKELY(deco_sep(deco) != Qnull_pointer)) {
2318 vals[len++] = deco_sep(deco);
2321 if (UNLIKELY(deco_sep(deco) != Qnull_pointer)) {
2322 /* strike the last separator */
2330 if (UNLIKELY(NILP(fun))) {
2331 /* condense the stuff */
2332 for (size_t i = 0, bar = nseq & -2;
2333 /* traverse to the previous even number */
2336 ? gluef(2, &seqelts[i])
2337 : list2(seqelts[i], seqelts[i+1]);
2338 if (UNLIKELY(deco_sep(deco) != Qnull_pointer)) {
2339 vals[len++] = deco_sep(deco);
2342 if (UNLIKELY(deco_sep(deco) != Qnull_pointer)) {
2343 /* strike the last separator */
2349 GCPROn(vals, totlen);
2351 for (size_t i = 0, bar = nseq & -2;
2352 /* traverse to the last even index */
2354 Lisp_Object args[3] = {fun, seqelts[i], seqelts[i+1]};
2355 vals[len++] = Ffuncall(countof(args), args);
2356 if (UNLIKELY(deco_sep(deco) != Qnull_pointer)) {
2357 vals[len++] = deco_sep(deco);
2360 if (UNLIKELY(deco_sep(deco) != Qnull_pointer)) {
2361 /* strike the last separator */
2369 if (UNLIKELY(NILP(fun))) {
2370 /* condense the stuff */
2372 /* traverse to the last 3-divisible index */
2373 i+3 <= nseq; i += 3) {
2375 ? gluef(3, &seqelts[i])
2379 if (UNLIKELY(deco_sep(deco) != Qnull_pointer)) {
2380 vals[len++] = deco_sep(deco);
2383 if (UNLIKELY(deco_sep(deco) != Qnull_pointer)) {
2384 /* strike the last separator */
2393 /* traverse to the last 3-divisible index */
2394 i+3 <= nseq; i += 3) {
2395 Lisp_Object args[4] = {
2396 fun, seqelts[i], seqelts[i+1], seqelts[i+2]};
2397 vals[len++] = Ffuncall(countof(args), args);
2398 if (UNLIKELY(deco_sep(deco) != Qnull_pointer)) {
2399 vals[len++] = deco_sep(deco);
2402 if (UNLIKELY(deco_sep(deco) != Qnull_pointer)) {
2403 /* strike the last separator */
2411 if (UNLIKELY(NILP(fun))) {
2412 /* condense the stuff */
2414 /* traverse to the last sane index */
2415 i+arity <= nseq; i += arity) {
2417 ? gluef(arity, &seqelts[i])
2418 : Flist(arity, &seqelts[i]);
2419 if (UNLIKELY(deco_sep(deco) != Qnull_pointer)) {
2420 vals[len++] = deco_sep(deco);
2423 if (UNLIKELY(deco_sep(deco) != Qnull_pointer)) {
2424 /* kick the last one */
2433 /* traverse to the last 3-divisible index */
2434 i+arity <= nseq; i += arity) {
2435 Lisp_Object args[arity+1];
2438 args[1] = seqelts[i];
2439 args[2] = seqelts[i+1];
2440 args[3] = seqelts[i+2];
2441 args[4] = seqelts[i+3];
2442 for (size_t j = 4; j < arity; j++) {
2443 args[j+1] = seqelts[i+j];
2445 vals[len++] = Ffuncall(countof(args), args);
2446 if (UNLIKELY(deco_sep(deco) != Qnull_pointer)) {
2448 vals[len++] = deco_sep(deco);
2451 if (UNLIKELY(deco_sep(deco) != Qnull_pointer)) {
2452 /* kick the last one */
2459 /* top off with the terminator */
2460 if (UNLIKELY(deco_ter(deco) != Qnull_pointer)) {
2461 vals[len++] = deco_ter(deco);
2464 result = __dress_result(result_type, vals, len);
2465 if (UNLIKELY(leni == 0)) {
2472 __pntw_1dict(Lisp_Object dict, Lisp_Object fun,
2473 glue_f gluef, Lisp_Object result_type)
2475 /* basically like maphash/mapskiplist */
2476 size_t ndict = dict_size((dict_t)(void*)dict);
2477 /* C99 we need you */
2478 size_t maxsz = __sys_stk_free() / sizeof(Lisp_Object);
2480 /* leave room for stuff after us,
2481 * we call a function on this, so leave plenty of space */
2486 Lisp_Object __keys[leni], __vals[leni], *keys, *vals, result;
2488 if (UNLIKELY(leni == 0)) {
2489 keys = xnew_array(Lisp_Object, 2 * ndict);
2490 vals = &keys[ndict];
2496 /* explode the sequence */
2497 len = __explode_1dict(keys, vals, dict, ndict);
2499 if (LIKELY(!NILP(fun) && len > 0UL)) {
2500 struct gcpro gcpro1, gcpro2;
2502 GCPRO1n(dict, vals, len);
2504 for (size_t i = 0; i < len; i++) {
2505 Lisp_Object args[3] = {fun, keys[i], vals[i]};
2506 vals[i] = Ffuncall(countof(args), args);
2511 for (size_t i = 0; i < len; i++) {
2512 Lisp_Object args[2] = {keys[i], vals[i]};
2514 ? gluef(countof(args), args)
2515 : Flist(countof(args), args);
2519 result = __dress_result(result_type, vals, len);
2520 if (UNLIKELY(leni == 0)) {
2527 __pntw_nseq(Lisp_Object seqs[], size_t nseqs, Lisp_Object fun,
2528 glue_f gluef, Lisp_Object result_type)
2530 /* defaults to arity 1,1,...,1 */
2531 size_t nmin = __nfam_min_size(seqs, nseqs);
2532 /* C99 we need you */
2533 struct seq_iter_s its[nseqs];
2534 size_t maxsz = __sys_stk_free() / sizeof(Lisp_Object);
2536 /* leave room for stuff after us,
2537 * we call a function on this, so leave plenty of space */
2541 Lisp_Object __vals[leni], *vals, result;
2542 struct gcpro gcpro1, gcpro2, gcpro3;
2544 if (UNLIKELY(leni == 0)) {
2545 vals = xnew_array(Lisp_Object, nmin);
2550 /* initialise the value space */
2551 memset(vals, 0, nmin * sizeof(Lisp_Object));
2552 /* initialise the iterators */
2553 for (size_t i = 0; i < nseqs; i++) {
2554 seq_iter_init((seq_t)seqs[i], &its[i]);
2557 GCPRO1nn(fun, vals, nmin, seqs, nseqs);
2558 if (UNLIKELY(NILP(fun))) {
2559 for (size_t i = 0; i < nmin; i++) {
2560 Lisp_Object args[nseqs];
2563 seq_iter_next(&its[0], (void**)&args[0]);
2565 seq_iter_next(&its[1], (void**)&args[1]);
2566 /* ... and the rest */
2567 for (size_t j = 2; j < nseqs; j++) {
2568 seq_iter_next(&its[j], (void**)&args[j]);
2571 ? gluef(countof(args), args)
2572 : Flist(countof(args), args);
2575 for (size_t i = 0; i < nmin; i++) {
2576 Lisp_Object args[nseqs+1];
2579 seq_iter_next(&its[0], (void**)&args[1]);
2581 seq_iter_next(&its[1], (void**)&args[2]);
2582 /* ... and the rest */
2583 for (size_t j = 2; j < nseqs; j++) {
2584 seq_iter_next(&its[j], (void**)&args[j+1]);
2587 vals[i] = Ffuncall(countof(args), args);
2592 /* deinitialise the iterators */
2593 for (size_t i = 0; i < nseqs; i++) {
2594 seq_iter_fini(&its[i]);
2597 result = __dress_result(result_type, vals, nmin);
2598 if (UNLIKELY(leni == 0)) {
2604 static inline size_t
2605 __arity_cross_sum(size_t arity[], size_t narity)
2607 size_t res = arity[0];
2608 for (size_t j = 1; j < narity; j++) {
2615 __explode_n(seq_iter_t si, void *tgt[], size_t n)
2617 /* explodes the sequence in SI N times, puts the stuff into tgt,
2618 * consequently tgt[] is N elements richer thereafter */
2620 seq_iter_next(si, &tgt[0]);
2621 for (size_t j = 1; j < n; j++) {
2622 seq_iter_next(si, &tgt[j]);
2628 __pntw_nseq2(Lisp_Object seqs[], size_t nseqs, Lisp_Object fun,
2629 glue_f gluef, Lisp_Object result_type, size_t arity[])
2631 size_t nmin = __nfam_min_size_a(seqs, nseqs, arity);
2632 /* C99 we need you */
2633 struct seq_iter_s its[nseqs];
2634 size_t aXsum = __arity_cross_sum(arity, nseqs);
2635 size_t maxsz = __sys_stk_free() / sizeof(Lisp_Object);
2637 /* leave room for stuff after us,
2638 * we call a function on this, so leave plenty of space */
2642 Lisp_Object __vals[leni], *vals, result;
2643 struct gcpro gcpro1, gcpro2, gcpro3;
2645 if (UNLIKELY(leni == 0)) {
2646 vals = xnew_array(Lisp_Object, nmin);
2651 /* initialise the value space */
2652 memset(vals, 0, nmin * sizeof(Lisp_Object));
2653 /* initialise the iterators */
2654 for (size_t i = 0; i < nseqs; i++) {
2655 seq_iter_init((seq_t)seqs[i], &its[i]);
2658 GCPRO1nn(fun, vals, nmin, seqs, nseqs);
2659 if (UNLIKELY(NILP(fun))) {
2660 for (size_t i = 0; i < nmin; i++) {
2661 Lisp_Object args[aXsum];
2664 /* partially unroll this, as we know that it's
2665 * definitely one seq to consider */
2666 __explode_n(&its[0], (void**)&args[0], off = arity[0]);
2667 /* ... actually we know it's even more than one
2668 * seq otherwise we'd be in the 1seq counterpart
2670 __explode_n(&its[1], (void**)&args[off], arity[1]);
2671 for (j = 2, off += arity[1];
2672 j < nseqs; off += arity[j++]) {
2674 &its[j], (void**)&args[off], arity[j]);
2677 ? gluef(countof(args), args)
2678 : Flist(countof(args), args);
2681 for (size_t i = 0; i < nmin; i++) {
2682 Lisp_Object args[aXsum+1];
2685 /* partially unroll this, as we know that it's
2686 * definitely one seq to consider */
2687 __explode_n(&its[0], (void**)&args[1], off = arity[0]);
2688 /* ... actually we know it's even more than one
2689 * seq otherwise we'd be in the 1seq counterpart
2691 __explode_n(&its[1], (void**)&args[++off], arity[1]);
2692 for (j = 2, off += arity[1];
2693 j < nseqs; off += arity[j++]) {
2695 &its[j], (void**)&args[off], arity[j]);
2698 vals[i] = Ffuncall(countof(args), args);
2703 /* deinitialise the iterators */
2704 for (size_t i = 0; i < nseqs; i++) {
2705 seq_iter_fini(&its[i]);
2708 result = __dress_result(result_type, vals, nmin);
2709 if (UNLIKELY(leni == 0)) {
2716 __cart_nseq(Lisp_Object seqs[], size_t nseqs, Lisp_Object fun, size_t arity,
2717 glue_f gf, Lisp_Object result_type)
2719 /* defaults to arity 1,1,...,1
2720 * there is no __comb_nseq() as combinations are defined to be
2721 * (cart (comb s1) (comb s2) ...), so in the arity 1,1,...,1 case this
2722 * equals __cart_nseq() */
2723 size_t nseqsz[nseqs];
2724 size_t nsum, ncart, l = 0;
2725 size_t nsz = __nfam_cart_sum_size(&nsum, &ncart, nseqsz, seqs, nseqs);
2726 /* C99 we need you */
2727 Lisp_Object *expls[nseqs];
2728 long int idx[nseqs]; /* the multi index */
2729 Lisp_Object fc[nseqs+1], *v = &fc[1];
2730 size_t maxsz = __sys_stk_free() / sizeof(Lisp_Object);
2732 /* leave room for stuff after us,
2733 * we call a function on this, so leave plenty of space */
2737 Lisp_Object __vals[leni], *vals, result;
2738 struct gcpro gcpro1, gcpro2, gcpro3;
2740 /* catch some horst cases */
2742 return __dress_result(result_type, NULL, 0);
2743 } /* actually now we ought to catch the case ncart == nsum
2744 * which is nseqs == 1 */
2746 if (UNLIKELY(leni == 0)) {
2747 vals = xnew_array(Lisp_Object, nsz);
2752 /* initialise the value space */
2753 memset(vals, 0, nsz * sizeof(Lisp_Object));
2754 /* initialise the explosion pointers */
2755 expls[0] = &vals[ncart];
2756 seq_explode((void**)expls[0], nseqsz[0], (seq_t)seqs[0]);
2757 expls[1] = expls[0] + nseqsz[0];
2758 seq_explode((void**)expls[1], nseqsz[1], (seq_t)seqs[1]);
2759 for (size_t i = 2; i < nseqs; i++) {
2760 expls[i] = expls[i-1] + nseqsz[i-1];
2761 seq_explode((void**)expls[i], nseqsz[i], (seq_t)seqs[i]);
2763 /* setup multiindex */
2764 memset(idx, 0, nseqs * sizeof(long int));
2767 GCPRO1nn(fun, vals, nsz, seqs, nseqs);
2768 if (LIKELY(!NILP(fun) && gf == NULL)) {
2770 /* fetch the data from the explosions, p-unrolled */
2771 v[0] = expls[0][idx[0]];
2772 v[1] = expls[1][idx[1]];
2773 for (size_t i = 2; i < nseqs; i++) {
2774 v[i] = expls[i][idx[i]];
2777 vals[l++] = Ffuncall(countof(fc), fc);
2778 /* advance the multi-index */
2779 __advance_multi_index_2(idx, countof(idx), nseqsz);
2781 } else if (LIKELY(!NILP(fun))) {
2783 /* fetch the data from the explosions, p-unrolled */
2784 v[0] = expls[0][idx[0]];
2785 v[1] = expls[1][idx[1]];
2786 for (size_t i = 2; i < nseqs; i++) {
2787 v[i] = expls[i][idx[i]];
2790 v[0] = gf(countof(idx), v);
2792 vals[l++] = Ffuncall(2, fc);
2793 /* advance the multi-index */
2794 __advance_multi_index_2(idx, countof(idx), nseqsz);
2797 glue_f tgf = gf ? gf : Flist;
2799 /* fetch the data from the explosions, p-unrolled */
2800 v[0] = expls[0][idx[0]];
2801 v[1] = expls[1][idx[1]];
2802 for (size_t i = 2; i < nseqs; i++) {
2803 v[i] = expls[i][idx[i]];
2806 vals[l++] = tgf(countof(idx), v);
2807 /* advance the multi-index */
2808 __advance_multi_index_2(idx, countof(idx), nseqsz);
2813 result = __dress_result(result_type, vals, ncart);
2814 if (UNLIKELY(leni == 0)) {
2821 __cart_nseq2(Lisp_Object seqs[], size_t nseqs, Lisp_Object fun,
2822 glue_f gf, Lisp_Object result_type, size_t arity[])
2824 size_t nseqsz[nseqs];
2825 size_t nsum, ncart, midxsz /* size of the multi index */, l = 0;
2826 size_t nsz = __nfam_cart_sum_size_a(
2827 &nsum, &ncart, &midxsz, nseqsz, seqs, nseqs, arity);
2828 /* C99 we need you */
2829 Lisp_Object *expls[nseqs];
2830 long int idx[midxsz]; /* the multi index */
2831 Lisp_Object fc[midxsz+1], *v = &fc[1];
2832 size_t maxsz = __sys_stk_free() / sizeof(Lisp_Object);
2834 /* leave room for stuff after us,
2835 * we call a function on this, so leave plenty of space */
2839 Lisp_Object __vals[leni], *vals, result;
2840 struct gcpro gcpro1, gcpro2, gcpro3;
2842 /* catch some horst cases */
2844 return __dress_result(result_type, NULL, 0);
2845 } /* actually now we ought to catch the case ncart == nsum
2846 * which is nseqs == 1 */
2848 if (UNLIKELY(leni == 0)) {
2849 vals = xnew_array(Lisp_Object, nsz);
2854 /* initialise the value space */
2855 memset(vals, 0, nsz * sizeof(Lisp_Object));
2856 /* initialise the explosion pointers */
2857 expls[0] = &vals[ncart];
2858 seq_explode((void**)expls[0], nseqsz[0], (seq_t)seqs[0]);
2859 expls[1] = expls[0] + nseqsz[0];
2860 seq_explode((void**)expls[1], nseqsz[1], (seq_t)seqs[1]);
2861 for (size_t i = 2; i < nseqs; i++) {
2862 expls[i] = expls[i-1] + nseqsz[i-1];
2863 seq_explode((void**)expls[i], nseqsz[i], (seq_t)seqs[i]);
2865 /* setup multiindex */
2866 memset(idx, 0, countof(idx) * sizeof(long int));
2869 GCPRO1nn(fun, vals, nsz, seqs, nseqs);
2870 if (LIKELY(!NILP(fun) && gf == NULL)) {
2873 /* fetch the data from the explosions, p-unrolled */
2874 v[0] = expls[0][idx[0]];
2875 for (slot = 1; slot < arity[0]; slot++) {
2876 /* offload arity[0] slots onto v */
2877 v[slot] = expls[0][idx[slot]];
2879 /* continue with the next arity[1] slots */
2880 v[slot] = expls[1][idx[slot]];
2882 for (size_t j = 1; j < arity[1]; slot++, j++) {
2883 v[slot] = expls[1][idx[slot]];
2885 /* now the rest of the crowd */
2886 for (size_t i = 2; i < nseqs; i++) {
2887 v[slot] = expls[i][idx[slot]];
2889 for (size_t j = 1; j < arity[i]; slot++, j++) {
2890 v[slot] = expls[i][idx[slot]];
2894 vals[l++] = Ffuncall(countof(fc), fc);
2895 /* advance the multi-index */
2896 __advance_multi_index_3(
2897 idx, countof(idx), nseqsz, nseqs, arity);
2899 } else if (LIKELY(!NILP(fun))) {
2902 /* fetch the data from the explosions, p-unrolled */
2903 v[0] = expls[0][idx[0]];
2904 for (slot = 1; slot < arity[0]; slot++) {
2905 /* offload arity[0] slots onto v */
2906 v[slot] = expls[0][idx[slot]];
2908 /* continue with the next arity[1] slots */
2909 v[slot] = expls[1][idx[slot]];
2911 for (size_t j = 1; j < arity[1]; slot++, j++) {
2912 v[slot] = expls[1][idx[slot]];
2914 /* now the rest of the crowd */
2915 for (size_t i = 2; i < nseqs; i++) {
2916 v[slot] = expls[i][idx[slot]];
2918 for (size_t j = 1; j < arity[i]; slot++, j++) {
2919 v[slot] = expls[i][idx[slot]];
2923 v[0] = gf(countof(idx), v);
2925 vals[l++] = Ffuncall(2, fc);
2926 /* advance the multi-index */
2927 __advance_multi_index_3(
2928 idx, countof(idx), nseqsz, nseqs, arity);
2931 glue_f tgf = gf ? gf : Flist;
2934 /* fetch the data from the explosions, p-unrolled */
2935 v[0] = expls[0][idx[0]];
2936 for (slot = 1; slot < arity[0]; slot++) {
2937 /* offload arity[0] slots onto v */
2938 v[slot] = expls[0][idx[slot]];
2940 /* continue with the next arity[1] slots */
2941 v[slot] = expls[1][idx[slot]];
2943 for (size_t j = 1; j < arity[1]; slot++, j++) {
2944 v[slot] = expls[1][idx[slot]];
2946 /* now the rest of the crowd */
2947 for (size_t i = 2; i < nseqs; i++) {
2948 v[slot] = expls[i][idx[slot]];
2950 for (size_t j = 1; j < arity[i]; slot++, j++) {
2951 v[slot] = expls[i][idx[slot]];
2955 vals[l++] = tgf(countof(idx), v);
2956 /* advance the multi-index */
2957 __advance_multi_index_3(
2958 idx, countof(idx), nseqsz, nseqs, arity);
2963 result = __dress_result(result_type, vals, ncart);
2964 if (UNLIKELY(leni == 0)) {
2971 __comb_nseq2(Lisp_Object seqs[], size_t nseqs, Lisp_Object fun,
2972 glue_f gf, Lisp_Object result_type, size_t arity[])
2974 /* this is the dodgiest one, since
2975 * comb(seq1, seq2, ..., seqn) => cart(comb(seq1), comb(seq2), ..., comb(seqn))
2977 size_t nseqsz[nseqs];
2978 size_t nsum, ncomb, midxsz /* size of the multi index */, l = 0;
2979 /* computes the size of the cartesian set, the maximum size of
2980 * the union set and the multiplicity of the multi-index (which is the
2981 * cross sum of the arity array) returns the sum of cartesian and union,
2982 * and puts intermediately computed family sizes into nseqsz[] */
2983 size_t nsz = __nfam_comb_sum_size_a(
2984 &nsum, &ncomb, &midxsz, nseqsz, seqs, nseqs, arity);
2985 /* C99 we need you */
2986 Lisp_Object *expls[nseqs];
2987 /* the multi indices, we have a big one, and a custom one */
2988 size_t __midx[midxsz], *midx[nseqs]; /* the multi indices */
2989 Lisp_Object fc[midxsz+1], *v = &fc[1];
2990 size_t maxsz = __sys_stk_free() / sizeof(Lisp_Object);
2992 /* leave room for stuff after us,
2993 * we call a function on this, so leave plenty of space */
2997 Lisp_Object __vals[leni], *vals, result;
2998 struct gcpro gcpro1, gcpro2, gcpro3;
3000 /* catch some horst cases */
3002 return __dress_result(result_type, NULL, 0);
3003 } /* actually now we ought to catch the case ncart == nsum
3004 * which is nseqs == 1 */
3006 if (UNLIKELY(leni == 0)) {
3007 vals = xnew_array(Lisp_Object, nsz);
3012 /* initialise the value space */
3013 memset(vals, 0, nsz * sizeof(Lisp_Object));
3014 /* initialise the explosion pointers and ... */
3015 expls[0] = &vals[ncomb];
3016 seq_explode((void**)expls[0], nseqsz[0], (seq_t)seqs[0]);
3017 expls[1] = expls[0] + nseqsz[0];
3018 seq_explode((void**)expls[1], nseqsz[1], (seq_t)seqs[1]);
3019 /* ... the multi-multi-index */
3020 midx[0] = &__midx[0];
3021 __initialise_multi_index(midx[0], arity[0]);
3022 midx[1] = &__midx[arity[0]];
3023 __initialise_multi_index(midx[1], arity[1]);
3024 /* and the rest of the explosion pointers, gosh, that's going
3025 * to be an Index War */
3026 for (size_t i = 2; i < nseqs; i++) {
3027 expls[i] = expls[i-1] + nseqsz[i-1];
3028 seq_explode((void**)expls[i], nseqsz[i], (seq_t)seqs[i]);
3029 midx[i] = &__midx[arity[i-1]];
3030 __initialise_multi_index(midx[i], arity[i]);
3035 GCPRO1nn(fun, vals, nsz, seqs, nseqs);
3036 if (LIKELY(!NILP(fun) && gf == NULL)) {
3039 /* fetch the data from the explosions, p-unrolled */
3040 v[0] = expls[0][__midx[0]];
3041 for (slot = 1; slot < arity[0]; slot++) {
3042 /* offload arity[0] slots onto v */
3043 v[slot] = expls[0][__midx[slot]];
3045 /* continue with the next arity[1] slots */
3046 v[slot] = expls[1][__midx[slot]];
3048 for (size_t j = 1; j < arity[1]; slot++, j++) {
3049 v[slot] = expls[1][__midx[slot]];
3051 /* now the rest of the crowd */
3052 for (size_t i = 2; i < nseqs; i++) {
3053 v[slot] = expls[i][__midx[slot]];
3055 for (size_t j = 1; j < arity[i]; slot++, j++) {
3056 v[slot] = expls[i][__midx[slot]];
3060 vals[l++] = Ffuncall(countof(fc), fc);
3061 /* advance the multi-index */
3062 __advance_multi_index_4(midx, nseqsz, nseqs, arity);
3064 } else if (LIKELY(!NILP(fun))) {
3067 /* fetch the data from the explosions, p-unrolled */
3068 v[0] = expls[0][__midx[0]];
3069 for (slot = 1; slot < arity[0]; slot++) {
3070 /* offload arity[0] slots onto v */
3071 v[slot] = expls[0][__midx[slot]];
3073 /* continue with the next arity[1] slots */
3074 v[slot] = expls[1][__midx[slot]];
3076 for (size_t j = 1; j < arity[1]; slot++, j++) {
3077 v[slot] = expls[1][__midx[slot]];
3079 /* now the rest of the crowd */
3080 for (size_t i = 2; i < nseqs; i++) {
3081 v[slot] = expls[i][__midx[slot]];
3083 for (size_t j = 1; j < arity[i]; slot++, j++) {
3084 v[slot] = expls[i][__midx[slot]];
3088 v[0] = gf(countof(__midx), v);
3090 vals[l++] = Ffuncall(2, fc);
3091 /* advance the multi-index */
3092 __advance_multi_index_4(midx, nseqsz, nseqs, arity);
3095 glue_f tgf = gf ? gf : Flist;
3100 /* fetch the data from the explosions, p-unrolled */
3101 v[0] = expls[0][__midx[0]];
3102 for (slot = 1; slot < arity[0]; slot++) {
3103 /* offload arity[0] slots onto v */
3104 v[slot] = expls[0][__midx[slot]];
3106 /* continue with the next arity[1] slots */
3107 v[slot] = expls[1][__midx[slot]];
3109 for (size_t j = 1; j < arity[1]; slot++, j++) {
3110 v[slot] = expls[1][__midx[slot]];
3112 /* now the rest of the crowd */
3113 for (size_t i = 2; i < nseqs; i++) {
3114 v[slot] = expls[i][__midx[slot]];
3116 for (size_t j = 1; j < arity[i]; slot++, j++) {
3117 v[slot] = expls[i][__midx[slot]];
3121 vals[l++] = tgf(countof(__midx), v);
3122 /* advance the multi-index */
3123 __advance_multi_index_4(midx, nseqsz, nseqs, arity);
3128 result = __dress_result(result_type, vals, ncomb);
3129 if (UNLIKELY(leni == 0)) {
3136 __perm_nseq(Lisp_Object seqs[], size_t nseqs, Lisp_Object fun, size_t arity,
3137 glue_f gf, Lisp_Object result_type)
3139 /* defaults to arity 1,1,...,1 */
3140 size_t nseqsz[nseqs];
3141 size_t ns, ncp, np, l = 0;
3142 size_t nsz = __nfam_perm_sum_size(&ns, &ncp, &np, nseqsz, seqs, nseqs);
3143 /* C99 we need you */
3144 Lisp_Object *expls[nseqs];
3145 long int idx[nseqs]; /* the multi index */
3146 Lisp_Object fc[nseqs+1], *v = &fc[1];
3147 size_t maxsz = __sys_stk_free() / sizeof(Lisp_Object);
3149 /* leave room for stuff after us,
3150 * we call a function on this, so leave plenty of space */
3154 Lisp_Object __vals[leni], *vals, result;
3155 struct gcpro gcpro1, gcpro2, gcpro3;
3157 /* catch some horst cases */
3159 return __dress_result(result_type, NULL, 0);
3160 } /* actually now we ought to catch the case nperm == nsum
3161 * which is nseqs == 1 */
3163 if (UNLIKELY(leni == 0)) {
3164 vals = xnew_array(Lisp_Object, nsz);
3169 /* initialise the value space */
3170 memset(vals, 0, nsz * sizeof(Lisp_Object));
3171 /* initialise the explosion pointers */
3172 expls[0] = &vals[ncp];
3173 seq_explode((void**)expls[0], nseqsz[0], (seq_t)seqs[0]);
3174 expls[1] = expls[0] + nseqsz[0];
3175 seq_explode((void**)expls[1], nseqsz[1], (seq_t)seqs[1]);
3176 for (size_t i = 2; i < nseqs; i++) {
3177 expls[i] = expls[i-1] + nseqsz[i-1];
3178 seq_explode((void**)expls[i], nseqsz[i], (seq_t)seqs[i]);
3180 /* setup multiindex */
3181 memset(idx, 0, nseqs * sizeof(long int));
3184 GCPRO1nn(fun, vals, nsz, seqs, nseqs);
3187 if (LIKELY(!NILP(fun) && gf == NULL)) {
3189 /* fetch the data from the explosions */
3190 v[0] = expls[0][idx[0]];
3191 v[1] = expls[1][idx[1]];
3192 l = __2perm_fun(vals, 2, v, 2, fun, l);
3193 /* advance the multi-index */
3194 __advance_multi_index_2(idx, 2, nseqsz);
3197 } else if (LIKELY(!NILP(fun))) {
3199 /* fetch the data from the explosions */
3200 v[0] = expls[0][idx[0]];
3201 v[1] = expls[1][idx[1]];
3202 l = __2perm_glue_fun(vals, 2, v, 2, fun, gf, l);
3203 /* advance the multi-index */
3204 __advance_multi_index_2(idx, 2, nseqsz);
3208 glue_f tgf = gf ? gf : Flist;
3210 /* fetch the data from the explosions */
3211 v[0] = expls[0][idx[0]];
3212 v[1] = expls[1][idx[1]];
3213 l = __2perm_glue(vals, 2, v, 2, tgf, l);
3214 /* advance the multi-index */
3215 __advance_multi_index_2(idx, 2, nseqsz);
3221 if (LIKELY(!NILP(fun) && gf == NULL)) {
3223 /* fetch the data from the explosions */
3224 v[0] = expls[0][idx[0]];
3225 v[1] = expls[1][idx[1]];
3226 v[2] = expls[2][idx[2]];
3227 l = __3perm_fun(vals, 0, v, 3, fun, l);
3228 /* advance the multi-index */
3229 __advance_multi_index_2(idx, 3, nseqsz);
3231 } else if (LIKELY(!NILP(fun))) {
3233 /* fetch the data from the explosions */
3234 v[0] = expls[0][idx[0]];
3235 v[1] = expls[1][idx[1]];
3236 v[2] = expls[2][idx[2]];
3237 l = __3perm_glue_fun(vals, 0, v, 3, fun, gf, l);
3238 /* advance the multi-index */
3239 __advance_multi_index_2(idx, 3, nseqsz);
3242 glue_f tgf = gf ? gf : Flist;
3244 /* fetch the data from the explosions */
3245 v[0] = expls[0][idx[0]];
3246 v[1] = expls[1][idx[1]];
3247 v[2] = expls[2][idx[2]];
3248 l = __3perm_glue(vals, 0, v, 3, tgf, l);
3249 /* advance the multi-index */
3250 __advance_multi_index_2(idx, 3, nseqsz);
3256 if (LIKELY(!NILP(fun) && gf == NULL)) {
3258 /* fetch the data from the explosions */
3259 v[0] = expls[0][idx[0]];
3260 v[1] = expls[1][idx[1]];
3261 for (size_t i = 2; i < nseqs; i++) {
3262 v[i] = expls[i][idx[i]];
3264 /* have Sn operating */
3265 l = __Sn_fun(vals, np, v, nseqs, fun, l);
3266 /* advance the multi-index */
3267 __advance_multi_index_2(idx, nseqs, nseqsz);
3269 } else if (LIKELY(!NILP(fun))) {
3271 /* fetch the data from the explosions */
3272 v[0] = expls[0][idx[0]];
3273 v[1] = expls[1][idx[1]];
3274 for (size_t i = 2; i < nseqs; i++) {
3275 v[i] = expls[i][idx[i]];
3277 /* have Sn operating */
3279 vals, np, v, nseqs, fun, gf, l);
3280 /* advance the multi-index */
3281 __advance_multi_index_2(idx, nseqs, nseqsz);
3284 glue_f tgf = gf ? gf : Flist;
3286 /* fetch the data from the explosions */
3287 v[0] = expls[0][idx[0]];
3288 v[1] = expls[1][idx[1]];
3289 for (size_t i = 2; i < nseqs; i++) {
3290 v[i] = expls[i][idx[i]];
3292 /* have Sn operating */
3293 l = __Sn_glue(vals, np, v, nseqs, tgf, l);
3294 /* advance the multi-index */
3295 __advance_multi_index_2(idx, nseqs, nseqsz);
3302 result = __dress_result(result_type, vals, ncp);
3303 if (UNLIKELY(leni == 0)) {
3310 __perm_nseq2(Lisp_Object seqs[], size_t nseqs, Lisp_Object fun,
3311 glue_f gf, Lisp_Object result_type, size_t arity[])
3313 /* this is the utmost dodgiest one, since
3314 * perm(seq1, seq2, ..., seqn) => perm(comb(seq1, seq2, ..., seqn))
3316 size_t nseqsz[nseqs];
3317 size_t nsum, nvar, nperm, midxsz /* size of the multi index */, l = 0;
3318 /* computes the size of the cartesian set, the maximum size of
3319 * the union set and the multiplicity of the multi-index (which is the
3320 * cross sum of the arity array) returns the sum of cartesian and union,
3321 * and puts intermediately computed family sizes into nseqsz[] */
3322 size_t nsz = __nfam_perm_sum_size_a(
3323 &nsum, &nvar, &nperm, &midxsz, nseqsz, seqs, nseqs, arity);
3324 /* C99 we need you */
3325 Lisp_Object *expls[nseqs];
3326 /* the multi indices, we have a big one, and a custom one */
3327 size_t __midx[midxsz], *midx[nseqs]; /* the multi indices */
3328 Lisp_Object v[midxsz + 2 /*to survive the aggressive loop unrolling*/];
3329 size_t maxsz = __sys_stk_free() / sizeof(Lisp_Object);
3331 /* leave room for stuff after us,
3332 * we call a function on this, so leave plenty of space */
3336 Lisp_Object __vals[leni], *vals, result;
3337 struct gcpro gcpro1, gcpro2, gcpro3;
3339 /* catch some horst cases */
3341 return __dress_result(result_type, NULL, 0);
3342 } /* actually now we ought to catch the case ncart == nsum
3343 * which is nseqs == 1 */
3345 if (UNLIKELY(leni == 0)) {
3346 vals = xnew_array(Lisp_Object, nsz);
3351 /* initialise the value space */
3352 memset(vals, 0, nsz * sizeof(Lisp_Object));
3353 /* initialise the explosion pointers and ... */
3354 expls[0] = &vals[nvar];
3355 seq_explode((void**)expls[0], nseqsz[0], (seq_t)seqs[0]);
3356 expls[1] = expls[0] + nseqsz[0];
3357 seq_explode((void**)expls[1], nseqsz[1], (seq_t)seqs[1]);
3358 /* ... the multi-multi-index */
3359 midx[0] = &__midx[0];
3360 __initialise_multi_index(midx[0], arity[0]);
3361 midx[1] = &__midx[arity[0]];
3362 __initialise_multi_index(midx[1], arity[1]);
3363 /* ... the multi-multi-index */
3364 midx[0] = &__midx[0];
3365 __initialise_multi_index(midx[0], arity[0]);
3366 /* and the rest of the explosion pointers, gosh, that's going
3367 * to be an Index War */
3368 for (size_t i = 2; i < nseqs; i++) {
3369 expls[i] = expls[i-1] + nseqsz[i-1];
3370 seq_explode((void**)expls[i], nseqsz[i], (seq_t)seqs[i]);
3371 midx[i] = &__midx[arity[i-1]];
3372 __initialise_multi_index(midx[i], arity[i]);
3375 GCPRO1nn(fun, vals, nsz, seqs, nseqs);
3376 /* actually we would have to distinguish between cross_sum(arity) >= 4
3377 * and == 3 and == 2, because the __Sn functions unroll at least 3
3378 * iterations, howbeit it seems to work so we stick with this for now */
3379 if (LIKELY(!NILP(fun) && gf == NULL)) {
3382 /* fetch the data from the explosions, p-unrolled */
3383 v[0] = expls[0][__midx[0]];
3384 for (slot = 1; slot < arity[0]; slot++) {
3385 /* offload arity[0] slots onto v */
3386 v[slot] = expls[0][__midx[slot]];
3388 /* continue with the next arity[1] slots */
3389 v[slot] = expls[1][__midx[slot]];
3391 for (size_t j = 1; j < arity[1]; slot++, j++) {
3392 v[slot] = expls[1][__midx[slot]];
3394 /* now the rest of the crowd */
3395 for (size_t i = 2; i < nseqs; i++) {
3396 v[slot] = expls[i][__midx[slot]];
3398 for (size_t j = 1; j < arity[i]; slot++, j++) {
3399 v[slot] = expls[i][__midx[slot]];
3402 /* do the rain dance */
3403 l = __Sn_fun(vals, nperm, v, midxsz, fun, l);
3404 /* advance the multi-index */
3405 __advance_multi_index_4(midx, nseqsz, nseqs, arity);
3407 } else if (LIKELY(!NILP(fun))) {
3410 /* fetch the data from the explosions, p-unrolled */
3411 v[0] = expls[0][__midx[0]];
3412 for (slot = 1; slot < arity[0]; slot++) {
3413 /* offload arity[0] slots onto v */
3414 v[slot] = expls[0][__midx[slot]];
3416 /* continue with the next arity[1] slots */
3417 v[slot] = expls[1][__midx[slot]];
3419 for (size_t j = 1; j < arity[1]; slot++, j++) {
3420 v[slot] = expls[1][__midx[slot]];
3422 /* now the rest of the crowd */
3423 for (size_t i = 2; i < nseqs; i++) {
3424 v[slot] = expls[i][__midx[slot]];
3426 for (size_t j = 1; j < arity[i]; slot++, j++) {
3427 v[slot] = expls[i][__midx[slot]];
3430 /* do the rain dance */
3431 l = __Sn_glue_fun(vals, nperm, v, midxsz, fun, gf, l);
3432 /* advance the multi-index */
3433 __advance_multi_index_4(midx, nseqsz, nseqs, arity);
3436 glue_f tgf = gf ? gf : Flist;
3441 /* fetch the data from the explosions, p-unrolled */
3442 v[0] = expls[0][__midx[0]];
3443 for (slot = 1; slot < arity[0]; slot++) {
3444 /* offload arity[0] slots onto v */
3445 v[slot] = expls[0][__midx[slot]];
3447 /* continue with the next arity[1] slots */
3448 v[slot] = expls[1][__midx[slot]];
3450 for (size_t j = 1; j < arity[1]; slot++, j++) {
3451 v[slot] = expls[1][__midx[slot]];
3453 /* now the rest of the crowd */
3454 for (size_t i = 2; i < nseqs; i++) {
3455 v[slot] = expls[i][__midx[slot]];
3457 for (size_t j = 1; j < arity[i]; slot++, j++) {
3458 v[slot] = expls[i][__midx[slot]];
3461 /* do the rain dance */
3462 l = __Sn_glue(vals, nperm, v, midxsz, tgf, l);
3463 /* advance the multi-index */
3464 __advance_multi_index_4(midx, nseqsz, nseqs, arity);
3469 result = __dress_result(result_type, vals, nvar);
3470 if (UNLIKELY(leni == 0)) {
3477 static inline glue_f
3478 _obtain_glue(Lisp_Object glue)
3479 __attribute__((always_inline));
3480 static inline glue_f
3481 _obtain_glue(Lisp_Object glue)
3483 if (EQ(glue, Qlist)) {
3485 } else if (EQ(glue, Qdllist)) {
3487 } else if (EQ(glue, Qvector)) {
3489 } else if (EQ(glue, Qstring)) {
3491 } else if (EQ(glue, Qconcat)) {
3499 _maybe_downgrade(Lisp_Object *arity)
3501 bool downgrade = !NILP(*arity) && CONSP(*arity);
3504 for (Lisp_Object tmp = *arity; CONSP(tmp); i++, tmp = XCDR(tmp)) {
3505 if (UNLIKELY(!NATNUMP(XCAR(tmp)) || XCAR(tmp) == Qzero)) {
3506 signal_simple_error(
3507 ":arity does not specify a valid multi-index",
3509 } else if (XCAR(tmp) != Qone) {
3513 if (LIKELY(i != 1 && !downgrade)) {
3515 } else if (UNLIKELY(i == 1)) {
3516 *arity = XCAR(*arity);
3518 } else if (UNLIKELY(downgrade)) {
3527 DEFUN("mapfam", Fmapfam, 1, MANY, 0, /*
3528 Apply FUNCTION to elements in FAMILIES and collect the results
3532 FUNCTION &rest FAMILIES &key :result-type :mode :arity :glue
3533 :initiator :separator :terminator
3535 The first argument FUNCTION is the function to use for the map.
3536 If FUNCTION is `nil' the function #\'identity or one of its glue
3537 counterparts (see :glue) is implicitly used. This can be used
3538 to convert one family to another, see examples below.
3540 The rest of the arguments are FAMILIES, where a family is a
3541 sequence \(see `sequencep'\) or a dict-like map (hash-table,
3542 skiplist, etc.). The family types need not coincide.
3544 Keys may be specified as in :key value [:key value [...]], all
3545 keys are optional and may appear anywhere. In greater detail:
3547 :result-type specifies the container type of the result object, can be:
3548 - #'list to yield a list (default)
3549 - #'dllist to yield a dllist
3550 - #'vector to yield a vector
3551 - #'string to yield a string iff FUNCTION returns characters or
3552 integers within the character range
3553 - #'concat to yield a string iff FUNCTION returns character arrays or
3554 arrays of integers within the character range
3555 - #'bit-vector to yield a bit-vector, FUNCTION's return values will
3556 be treated 1 iff non-nil, and 0 otherwise.
3557 - 'litter or 'void to not collect the results at all
3558 - 'inplace to modify the first family in FAMILIES by side-effect if
3559 it is a sequence, and modify the value destructively if it is a
3560 dict. This works only in pointwise mode, see :mode.
3562 Generally, the result-type is a functor (most often a constructor)
3563 to be applied on the produced output sequence. It behaves as if the
3564 elements of the output sequence had been passed to the constructor
3565 function argument-wise. So it can be thought of as a shortcut to
3566 \(apply #'<constructor> result-sequence\).
3568 In the past result types were specified by the name of the map
3569 function which turned out to be extremely sluggish in case the
3570 result type is parametrised (i.e. passed as parameter).
3572 :mode specifies the way the arguments are passed to FUNCTION, can be:
3573 - 'pointwise or 'pntw (default): given FAMILIES consists of
3574 fam1, fam2, etc. this mode passes the first point of fam1 along
3575 with the first point of fam2 along with etc. to FUNCTION. Hereby
3576 a point is just one element in case the family is a sequence, and
3577 a key-value pair (as two separate arguments) if family is a dict
3578 (and arity does not specify this otherwise).
3579 - 'keywise or 'keyw: like 'pointwise in case of sequences, for dicts
3580 this passes only the key cell to FUNCTION.
3581 - 'cartesian or 'cart: construct the cartesian product of the points
3582 in FAMILIES and pass the resulting tuples to FUNCTION.
3583 - 'combination or 'comb: construct the set of all combinations of
3584 the points, formally this is the set of (fixed-size) subsets of the
3585 set of points, disregarding different orders.
3586 Note: the implementation will always preserve orders though, that is
3587 the combinatorial subsets of an ordered family will be ordered wrt
3588 to the same overlying order.
3589 - 'permutation or 'perm or 'variation or 'var: construct the set of
3590 all permutations of the points (also known as variations), formally
3591 this is the set of (fixed-size) tuples arising from rearranging
3592 (different ordering) the subsets of the set of points.
3594 Note: The combinatorial modes (cart, comb and perm) produce giant
3595 amounts of data (using glues) or a neverending series of function
3596 calls. In case you are using one of the above modes and pass user
3597 input to #'mapfam or allow your users to specify their own mapping
3598 functions make sure you restrain the (size of the) input arguments.
3600 To give a rough idea of the outcome sizes:
3601 family size arity #combinations #permutations #cartesians
3608 9 7 36 181440 4782969
3609 9 8 9 362880 43046721
3610 9 9 1 362880 387420489
3612 For the number of combinations:
3613 (binomial-coefficient SIZE ARITY)
3614 For the number of permutations:
3615 (* (binomial-coeeficient SIZE ARITY) (factorial ARITY))
3616 For the number of points in the cartesian product:
3619 Additional note: SXEmacs' implementation of explicit symmetric group
3620 traversal (wrt a Bruhat-like order) is currently the fastest on the
3621 planet, however it obviously cannot overcome the sheer size of large
3622 symmetric groups. Be aware that explicit unrolling S_11 eats up at
3623 least 300 MB of RAM, unrolling S_12 requires at least 3.6 GB of RAM,
3624 for S_13 it's approx 48 GB and so on.
3626 Additional note: Cartesian products are highly exponential in space
3627 and time complexity. However, unlike permutations (symm. groups)
3628 the cartesian points can be constructed rather easily using nested
3629 loops. So if you are just after a couple of cartesian points do not
3630 bother using mapfam to create them all and filter afterwards but
3631 directly use nested loops to create the points you need.
3633 :arity specifies how to choose and pass points from the families to
3634 FUNCTION. The value of :arity can be a normal index (positive
3635 integer) if there is only one family, and a multi-index if points
3636 are to be picked from multiple families.
3639 - 1 if there is only one family which is not a dictionary and mode
3640 'pointwise or 'combination
3641 - 1 if there is only one family (including dictionaries) and mode is
3643 - 2 if there is only one family and mode is 'cartesian
3644 - the length of the family if there is only one family and mode is
3646 - (1 1) if family is a dictionary and mode is 'pointwise or
3648 - (1 1 ... 1) if there are n families, irrespective of mode.
3650 So it is '(1 1) if two families are given, '(1 1 1) for 3 families
3653 Indices, multi-indices and modes:
3654 The general multi-index form of the :arity keyword specifies how many
3655 points are taking from each family to form a glue cell which is passed
3656 directly to FUNCTION (exploded of course) if that is non-nil, and
3657 passed to the glue if that is nil.
3658 The first index in the arity multi-index list corresponds to the
3659 number of points to choose from the first family, the second one to
3660 the second family respectively and so on.
3661 An ordinary index always refers to the first family irrespective how
3662 many families have been specified.
3664 The exact meaning of this multi-index depends on the mode (see also
3666 - In pointwise or keywise mode, always pick this number of points
3667 or elements (consecutively), example:
3668 Let '(1 2 3 a b c) be the family and 1 its arity, the sequence of
3669 picks goes: 1, 2, 3, a, b, c.
3670 Let '(1 2 3 a b c) be the family and 2 its arity, the sequence of
3671 picks goes: [1 2], [3 a], [b c]
3672 If a cell is not formable because there are too few elements left in
3673 the family the mapping will not take place at all, so be '(1 2 3)
3674 the family and 2 its arity, the sequence of picks goes: [1 2].
3676 Multiple families in pointwise or keywise mode behave similarly
3677 Be '(1 2 3) '(a b c) two families and '(1 1) the arity (which is the
3678 default arity anyway), the pick then goes: [1 a] [2 b] [3 c], which
3679 is exactly how CL's #'map behaves in this situation.
3680 Be '(1 2 3) '(a b c one-more) two families and '(1 1) the arity,
3681 then the pick sequence again is: [1 a] [2 b] [3 c].
3682 In general the family with the least elements determines the number
3683 of picks in this mode.
3685 For arbitrary multi-indices the same rules hold, example:
3686 Let '(1 2 3) '(a b c one-more) be two families and '(1 2) its arity,
3687 then the pick sequence will be: [1 a b] [2 c one-more]
3689 - In cartesian mode, the arity, if an ordinary index, specifies the
3690 number of cartesian copies of the first given family, example:
3691 Let [a b c] be a sequence and arity be 2, then the mapping will
3693 [a a] [a b] [a c] [b a] [b b] [b c] [c a] [c b] [c c]
3695 If given a multi-index the cross sum denotes the total dimension of
3696 the yield while each index specifies the number of copies of the
3697 respective family, so fundamentally each cartesian mapping can be
3698 rewritten by a multi-index consisting solely of ones and
3699 correspondingly many copies of the input families, example:
3700 Let [a b c] and [1 2 3] be two families and '(1 1) the arity, then
3701 the cartesian mode will give:
3702 [a 1] [a 2] [a 3] [b 1] [b 2] [b 3] [c 1] [c 2] [c 3]
3703 Clearly the input sequence [a b c] of arity 2 can be rewritten as
3704 two input sequences [a b c] [a b c] and arity '(1 1) and will yield
3705 the sequence shown above.
3707 Let [a b] and [1 2] be two families and '(1 2) the arity, the result
3709 [a 1 1] [a 1 2] [a 2 1] [a 2 2] [b 1 1] [b 1 2] [b 2 1] [b 2 2]
3711 - In combination mode, the arity, if an ordinary index, specifies the
3712 combination size, example:
3713 Let \'(1 2 3 a) be the input sequence and 2 its arity, then the
3714 sequence of picks goes:
3715 [1 2] [1 3] [1 a] [2 3] [2 a] [3 a].
3717 A multi-index over several families specifies the subset sizes of
3718 each of the families. The total combination set is then formed by
3719 taking the cartesian product of these, example:
3720 Let [1 2 3] and [a b c] be two sets and '(2 2) the considered arity,
3721 then the first family yields [1 2] [1 3] [2 3] and the second one
3722 [a b] [a c] [b c], thence the final outcome will be:
3723 [1 2 a b] [1 2 a c] [1 2 b c] [1 3 a b] [1 3 a c] [1 3 b c] ...
3725 Again, the combination mode is strictly order-preserving, both
3726 the order of the families (as a sequence of families) and the order
3727 of each family will be preserved upon mapping.
3729 - In permuation mode, an ordinary index as arity will specify the
3730 cardinality, read size, of the combinatorial subset which will
3732 Note: the default arity for the permutation mode if just one
3733 sequence is given is the length of this sequence!
3736 Let \'(a b c) be a family and no arity be given, then the sequence
3738 [a b c] [a c b] [b a c] [b c a] [c a b] [c b a]
3739 Let "abcd" be a family and the arity be 2, then the pick sequence
3741 "ab" "ba" "ac" "ca" "ad" "da" "bc" "cb" "bd" "db" "cd" "dc"
3743 Note: while order 2 and order 3 permutations look carefully
3744 constructed and easily predictable this is not true for higher order
3745 permutations! They are specially designed to be mappable as fast as
3746 possible and seem to have no predictable pattern whatsoever, the
3747 order is based on a 1-orbit representation of the underlying
3748 symmetric group which needs merely one transposition to get from one
3749 orbit element to the next one; for details cf. source code.
3751 If given a multi-index
3752 Let "abc" and "123" be two families and arity (2 2), the pick
3754 (perms-of "ab12"), (perms-of "ab13"), (perms-of "ab23"),
3755 (perms-of "ac12"), (perms-of "ac13"), (perms-of "ac23")
3756 where #'perms-of denotes all permutations of that one give sequence,
3757 and can be implemented as (mapfam nil :mode \'perm <seq>)
3759 :glue when multiple values are to be passed to FUNCTION (or if FUNCTION
3760 is `nil' in particular) this specifies which (container) structure to
3761 use to glue them together.
3762 IOW, if FUNCTION is just a single-valued function but the family, the
3763 arity and/or the mode induce more than just one value, glue can turn
3764 so-called exploded form into a single value. Possible constructors:
3765 - #'list (default) to glue the arguments as lists
3766 - #'vector to glue the arguments as vectors
3767 - #'dllist to glue the arguments as dllists
3768 - #'string to glue the arguments as strings, iff they are characters
3769 - #'concat to glue the arguments as strings from character sequences
3771 In pointwise and keywise mode the result sequence can be decorated:
3773 :initiator insert this object at the beginning of the output sequence
3774 only works in 'pointwise and 'keywise mode
3776 :terminator insert this object at the end of the output sequence
3777 only works in 'pointwise and 'keywise mode
3779 :separator insert this object between each pair of elements of the
3780 output sequence. Use this to mimic a #'mapconcat-like behaviour,
3781 but this works for any sequence not just strings.
3782 only works in 'pointwise and 'keywise mode
3787 Normal mapcar-like behaviour:
3788 \(mapfam #'1+ '(1 2 3 4)\)
3790 \(mapfam #'1+ :result-type 'vector '(1 2 3 4)\)
3792 \(mapfam #'1- :result-type 'dllist [1 2 3 4]\)
3795 Normal mapcar*-like behaviour:
3796 \(mapfam #'+ (1 2 3 4) (10 20 30 40)\)
3798 \(mapfam #'+ [1 2 3 4] (dllist 10 20 30 40) :result-type 'vector\)
3801 Construct an alist from a plist:
3802 \(mapfam #'cons '(a 1 b 2 c 3) :arity 2\)
3803 => ((a . 1) (b . 2) (c . 3))
3804 \(mapfam #'list '(a 1 b 2 c 3) :arity 3 :result-type 'vector\)
3805 => [(a 1 b) (2 c 3)]
3806 \(mapfam nil '(a 1 b 2 c 3) :arity 2 :glue 'list\)
3807 => ((a 1) (b 2) (c 3))
3808 \(mapfam nil '(a 1 b 2 c 3) :arity 2 :glue 'vector :result-type 'dllist\)
3809 => (dllist [a 1] [b 2] [c 3])
3811 Apply cons to 2-sets (subsets of order 2) of a list:
3812 \(mapfam #'cons :mode 'comb :arity 2 '(a b c d)\)
3813 => ((a . b) (a . c) (a . d) (b . c) (b . d) (c . d))
3814 \(mapfam #'cons :mode 'comb :arity 2 '(a b a c)\)
3815 => ((a . b) (a . a) (a . c) (b . a) (b . c) (a . c))
3817 The same for 3-sets (using the automatic glue):
3818 \(mapfam nil :mode 'comb :arity 3 '(a b c d)\)
3819 => ((a b c) (a b d) (b c d))
3820 \(mapfam nil :mode 'comb :arity 3 '(a b c d) :glue 'vector\)
3821 => ([a b c] [a b d] [b c d])
3822 Note: This is exactly what `ncombs' is doing.
3824 Given a tuple of elements determine all combinations of three
3825 elements thereof (the 3-sets of the the tuple):
3826 \(mapfam nil :mode 'comb :arity 3 [a b c d]\)
3827 => ((a b c) (a b d) (a c d) (b c d))
3828 \(mapfam nil :mode 'comb :arity 3 [a b c d e] :glue #'vector\)
3829 => ([a b c] [a b d] [a b e] [a c d] [a c e] [a d e]
3830 [b c d] [b c e] [b d e] [c d e])
3832 Glueing the combinations of two different lists:
3833 \(mapfam nil :mode 'comb '(a b c) '(1 2)\)
3834 => ((a 1) (b 1) (c 1) (a 2) (b 2) (c 2))
3835 \(mapfam nil :mode 'comb '(a b c) '(1 2) :arity '(2 1)\)
3836 => ((a b 1) (a c 1) (b c 1) (a b 2) (a c 2) (b c 2))
3837 \(mapfam nil :mode 'comb '(a b c) '(1 2 3) :arity '(2 2)\)
3838 => ((a b 1 2) (a c 1 2) (b c 1 2)
3839 (a b 1 3) (a c 1 3) (b c 1 3)
3840 (a b 2 3) (a c 2 3) (b c 2 3))
3842 Applying the plus function immediately:
3843 \(mapfam #'+ :mode 'comb '(10 20 30) '(1 2)\)
3844 => (11 21 31 12 22 32)
3845 \(mapfam #'+ :mode 'comb '(10 20 30) '(1 2) :arity '(2 1)\)
3846 => (31 41 51 22 42 52)
3848 Mimicking #'mapconcat:
3849 \(mapconcat #'identity '("the" "inverse" "of" "#'split-string") " "\)
3850 => "the inverse of #'split-string"
3851 \(mapfam nil :separator " " '("the" "inverse" "of" "#'split-string")\)
3852 => ("the" " " "inverse" " " "of" " " "#'split-string")
3853 \(mapfam nil :separator " " :result-type #'concat
3854 '("the inverse of #'split-string")\)
3855 => "the inverse of #'split-string"
3857 Using cartesian mode and #'concat to emulate :separator
3858 \(mapfam #'concat :result-type #'concat :mode 'cartesian
3859 '\("the" "inverse" "of" "#'split-string"\) '(" ")\)
3860 => "the inverse of #'split-string "
3861 \(mapfam #'concat :result-type #'concat :mode 'cartesian
3862 [" "] '\("the" "inverse" "of" "#'split-string"\)\)
3863 => " the inverse of #'split-string"
3865 Note a separator is not exactly like doing cartesian mapping over
3866 two sequences since it affects only pairs of elements and so the
3867 last/first tuple is missing.
3868 However, pointwise mode is still use full if each pair of elements
3869 requires a `different separator'.
3871 \(mapfam #'concat :result-type #'concat :mode 'pointwise
3872 '\("the" "inverse" "of" "#'split-string"\) '(" " "_" "-" "."\)\)
3873 => "the inverse_of-#'split-string."
3876 (int nargs, Lisp_Object *args))
3878 /* this is just one, huuuuge case distinctor */
3879 Lisp_Object fun = Qnil;
3880 Lisp_Object mode = Qnil, arity = Qnil;
3881 Lisp_Object res_type = Qlist;
3882 volatile struct decoration_s deco = {
3883 Qnull_pointer, Qnull_pointer, Qnull_pointer
3885 int nfams = 0, arity_len;
3886 bool found_fun_p = false;
3887 glue_f gluef = NULL;
3889 /* snarf the function */
3890 if (!KEYWORDP(args[0])) {
3894 /* snarf the keys and families */
3895 for (int i = found_fun_p; i < nargs; i++) {
3896 if (EQ(args[i], Q_result_type)) {
3897 res_type = args[++i];
3898 } else if (EQ(args[i], Q_arity)) {
3900 } else if (EQ(args[i], Q_mode)) {
3902 } else if (EQ(args[i], Q_glue)) {
3903 gluef = _obtain_glue(args[++i]);
3904 } else if (EQ(args[i], Q_separator)) {
3905 deco.sep = args[++i];
3906 } else if (EQ(args[i], Q_initiator)) {
3907 deco.ini = args[++i];
3908 } else if (EQ(args[i], Q_terminator)) {
3909 deco.ter = args[++i];
3910 } else if (!found_fun_p) {
3911 /* we found the function cell */
3915 /* must be a family */
3916 args[nfams++] = args[i];
3920 /* check the integrity of the options */
3921 /* first kick the most idiotic situations */
3923 (NILP(fun) && EQ(mode, Qvoid)) ||
3925 /* looks like an exphert is here */
3926 return __dress_result(res_type, NULL, 0);
3928 /* now, fill in default values */
3932 /* degrade a thoroughly fledges '(1 1 ... 1) arity to nil */
3933 arity_len = _maybe_downgrade(&arity);
3935 #define POINTWISEP(mode) \
3936 (EQ(mode, Qpntw) || EQ(mode, Qpointwise) || EQ(mode, Qpoints))
3937 #define KEYWISEP(mode) \
3938 (EQ(mode, Qkeyw) || EQ(mode, Qkeywise) || EQ(mode, Qkeys))
3939 #define COMBINATIONP(mode) \
3940 (EQ(mode, Qcomb) || EQ(mode, Qcombination) || EQ(mode, Qcombinations))
3941 #define PERMUTATIONP(mode) \
3942 (EQ(mode, Qperm) || EQ(mode, Qpermutation) || EQ(mode, Qpermutations))
3943 #define CARTESIANP(mode) \
3944 (EQ(mode, Qcart) || EQ(mode, Qcartesian))
3946 if (POINTWISEP(mode) && nfams == 1 && NILP(arity) && !DICTP(args[0])) {
3947 /* the arity is not specified and it's just one sequence */
3948 return __pntw_1seq(args[0], fun, 1UL, gluef, res_type, &deco);
3950 } else if (POINTWISEP(mode) && NILP(arity) && !DICTP(args[0])) {
3951 /* the arity is not specified and it's more than one sequence */
3952 return __pntw_nseq(args, nfams, fun, gluef, res_type);
3954 } else if (KEYWISEP(mode) && nfams == 1 && NILP(arity)) {
3955 /* the arity is not specified and it's just one sequence,
3956 * also we dont have to care about dicts since
3957 * keywise is specified */
3958 return __pntw_1seq(args[0], fun, 1UL, gluef, res_type, &deco);
3960 } else if (KEYWISEP(mode) && NILP(arity)) {
3961 /* the arity is not specified and it's more than one sequence,
3962 * also we dont have to care about dicts since
3963 * keywise is specified */
3964 return __pntw_nseq(args, nfams, fun, gluef, res_type);
3966 } else if (POINTWISEP(mode) && (nfams == 1 && NILP(arity))) {
3967 /* the arity is not specified, it's one sequence, and it
3968 * must be a dict, since the non-dict case was check already */
3969 return __pntw_1dict(args[0], fun, gluef, res_type);
3971 } else if (NATNUMP(arity) && (POINTWISEP(mode) || KEYWISEP(mode))) {
3972 /* the arity is a natnum, so we consider just the
3973 * first sequence, in case of dicts this equals keywise
3975 return __pntw_1seq(args[0], fun, XUINT(arity),
3976 gluef, res_type, &deco);
3977 } else if (POINTWISEP(mode) || KEYWISEP(mode)) {
3978 /* the most general case */
3979 size_t a[arity_len];
3980 volatile Lisp_Object tmp;
3983 for (i = 0, tmp = arity;
3984 CONSP(tmp) && i < nfams && i < arity_len;
3985 i++, tmp = XCDR(tmp)) {
3986 a[i] = XUINT(XCAR(tmp));
3988 return __pntw_nseq2(args, i, fun, gluef, res_type, a);
3991 if (COMBINATIONP(mode) && NATNUMP(arity)) {
3992 /* the arity is a natnum, so it's just one sequence,
3993 * if not who cares :) */
3994 return __comb_1seq(args[0], fun, XUINT(arity),
3996 } else if (COMBINATIONP(mode) && (nfams == 1 && NILP(arity))) {
3997 /* the arity is a natnum, so it's just one sequence,
3998 * if not who cares :) */
3999 return __comb_1seq(args[0], fun, -1UL, gluef, res_type);
4001 } else if (COMBINATIONP(mode) && NILP(arity)) {
4002 /* the arity is not specified and it's more than one sequence */
4003 return __cart_nseq(args, nfams, fun, 1UL, gluef, res_type);
4005 } else if (COMBINATIONP(mode)) {
4006 /* the most general case */
4007 size_t a[arity_len];
4008 volatile Lisp_Object tmp;
4011 for (i = 0, tmp = arity;
4012 CONSP(tmp) && i < nfams && i < arity_len;
4013 i++, tmp = XCDR(tmp)) {
4014 a[i] = XUINT(XCAR(tmp));
4016 return __comb_nseq2(args, i, fun, gluef, res_type, a);
4019 if (CARTESIANP(mode) && NATNUMP(arity)) {
4020 /* the arity is a natnum, so it's just one sequence,
4021 * if not who cares :) */
4022 return __cart_1seq(args[0], fun, XUINT(arity),
4024 } else if (CARTESIANP(mode) &&
4025 (nfams == 1 && NILP(arity))) {
4026 /* it's one sequence and arity isnt specified, go with 2 then */
4027 return __cart_1seq(args[0], fun, 2UL, gluef, res_type);
4029 } else if (CARTESIANP(mode) && NILP(arity)) {
4030 /* the arity is not specified and it's more than one sequence */
4031 return __cart_nseq(args, nfams, fun, 1UL, gluef, res_type);
4033 } else if (CARTESIANP(mode)) {
4034 /* the most general case */
4035 size_t a[arity_len];
4036 volatile Lisp_Object tmp;
4039 for (i = 0, tmp = arity;
4040 CONSP(tmp) && i < nfams && i < arity_len;
4041 i++, tmp = XCDR(tmp)) {
4042 a[i] = XUINT(XCAR(tmp));
4044 return __cart_nseq2(args, i, fun, gluef, res_type, a);
4047 if (PERMUTATIONP(mode) && NATNUMP(arity)) {
4048 /* the arity is a natnum, so it's just one sequence,
4049 * if not who cares :) */
4050 return __perm_1seq(args[0], fun, XUINT(arity),
4052 } else if (PERMUTATIONP(mode) && (nfams == 1 && NILP(arity))) {
4053 /* the arity is a natnum, so it's just one sequence,
4054 * if not who cares :) */
4055 return __perm_1seq(args[0], fun, -1UL, gluef, res_type);
4057 } else if (PERMUTATIONP(mode) && NILP(arity)) {
4058 /* the arity is not specified and it's more than one sequence */
4059 return __perm_nseq(args, nfams, fun, 1UL, gluef, res_type);
4061 } else if (PERMUTATIONP(mode)) {
4062 /* the most general case */
4063 size_t a[arity_len];
4064 volatile Lisp_Object tmp;
4067 for (i = 0, tmp = arity;
4068 CONSP(tmp) && i < nfams && i < arity_len;
4069 i++, tmp = XCDR(tmp)) {
4070 a[i] = XUINT(XCAR(tmp));
4072 return __perm_nseq2(args, i, fun, gluef, res_type, a);
4077 DEFUN("mapconcat", Fmapconcat, 3, 3, 0, /*
4078 Apply FUNCTION to each element of SEQUENCE, and concat the results to a string.
4079 Between each pair of results, insert SEPARATOR.
4081 Each result, and SEPARATOR, should be strings. Thus, using " " as SEPARATOR
4082 results in spaces between the values returned by FUNCTION. SEQUENCE itself
4083 may be a list, a vector, a dllist, a bit vector, or a string.
4085 (function, sequence, separator))
4087 EMACS_INT len = XINT(Flength(sequence));
4091 EMACS_INT nargs = len + len - 1;
4092 int speccount = specpdl_depth();
4095 return build_string("");
4097 XMALLOC_OR_ALLOCA(args, nargs, Lisp_Object);
4099 mapcar1(len, args, function, sequence);
4101 for (i = len - 1; i >= 0; i--)
4102 args[i + i] = args[i];
4104 for (i = 1; i < nargs; i += 2)
4105 args[i] = separator;
4107 result = Fconcat(nargs, args);
4108 XMALLOC_UNBIND(args, nargs, speccount);
4112 DEFUN("mapcar", Fmapcar, 2, 2, 0, /*
4113 Apply FUNCTION to each element of SEQUENCE; return a list of the results.
4114 The result is a list of the same length as SEQUENCE.
4115 SEQUENCE may be a list, a vector, a dllist, a bit vector, or a string.
4117 (function, sequence))
4119 size_t len = XINT(Flength(sequence));
4120 Lisp_Object *args = NULL;
4122 int speccount = specpdl_depth();
4124 XMALLOC_OR_ALLOCA(args, len, Lisp_Object);
4126 mapcar1(len, args, function, sequence);
4128 result = Flist(len, args);
4129 XMALLOC_UNBIND(args, len, speccount);
4133 DEFUN("mapdllist", Fmapdllist, 2, 2, 0, /*
4134 Apply FUNCTION to each element of SEQUENCE; return a dllist of the results.
4135 The result is a list of the same length as SEQUENCE.
4136 SEQUENCE may be a list, a vector, a dllist, a bit vector, or a string.
4138 (function, sequence))
4140 size_t len = XINT(Flength(sequence));
4141 Lisp_Object *args = NULL;
4143 int speccount = specpdl_depth();
4145 XMALLOC_OR_ALLOCA(args, len, Lisp_Object);
4147 mapcar1(len, args, function, sequence);
4149 result = Fdllist(len, args);
4150 XMALLOC_UNBIND(args, len, speccount);
4154 DEFUN("mapvector", Fmapvector, 2, 2, 0, /*
4155 Apply FUNCTION to each element of SEQUENCE; return a vector of the results.
4156 The result is a vector of the same length as SEQUENCE.
4157 SEQUENCE may be a list, a vector, a dllist, a bit vector, or a string.
4159 (function, sequence))
4161 size_t len = XINT(Flength(sequence));
4162 Lisp_Object result = make_vector(len, Qnil);
4163 struct gcpro gcpro1;
4166 mapcar1(len, XVECTOR_DATA(result), function, sequence);
4172 DEFUN("mapc-internal", Fmapc_internal, 2, 2, 0, /*
4173 Apply FUNCTION to each element of SEQUENCE.
4174 SEQUENCE may be a list, a vector, a bit vector, or a string.
4175 This function is like `mapcar' but does not accumulate the results,
4176 which is more efficient if you do not use the results.
4178 The difference between this and `mapc' is that `mapc' supports all
4179 the spiffy Common Lisp arguments. You should normally use `mapc'.
4181 (function, sequence))
4183 mapcar1(XINT(Flength(sequence)), 0, function, sequence);
4188 DEFUN("mapc-inplace", Fmapc_inplace, 2, 2, 0, /*
4189 Apply FUNCTION to each element of SEQUENCE and replace the
4190 element with the result.
4191 Return the (destructively) modified sequence.
4193 At the moment, SEQUENCE can be a list, a dllist, a vector,
4194 a bit-vector, or a string.
4196 Containers with type restrictions -- strings or bit-vectors here --
4197 cannot handle all results of FUNCTION. In case of bit-vectors,
4198 if the function yields `nil' or 0 the current bit is set to 0,
4199 if the function yields anything else, the bit is set to 1.
4200 Similarly in the string case any non-char result of FUNCTION sets
4201 the currently processed character to ^@ (octal value: 000).
4203 (function, sequence))
4206 else if (LISTP(sequence))
4207 list_map_inplace(function, sequence);
4208 else if (DLLISTP(sequence))
4209 dllist_map_inplace(function, sequence);
4210 else if (STRINGP(sequence))
4211 string_map_inplace(function, sequence);
4212 else if (VECTORP(sequence))
4213 vector_map_inplace(function, sequence);
4214 else if (BIT_VECTORP(sequence))
4215 bit_vector_map_inplace(function, sequence);
4221 /* to be emodule compliant */
4229 DEFKEYWORD(Q_arity);
4230 DEFKEYWORD(Q_result_type);
4231 DEFKEYWORD(Q_initiator);
4232 DEFKEYWORD(Q_separator);
4233 DEFKEYWORD(Q_terminator);
4234 /* symbols for result and glue */
4235 DEFSYMBOL(Qinplace);
4240 DEFSYMBOL(Qbit_vector);
4245 DEFSYMBOL(Qpointwise);
4248 DEFSYMBOL(Qkeywise);
4251 DEFSYMBOL(Qcombination);
4252 DEFSYMBOL(Qcombinations);
4254 DEFSYMBOL(Qpermutation);
4255 DEFSYMBOL(Qpermutations);
4257 DEFSYMBOL(Qcartesian);
4260 /* special map*s, compatibility */
4262 DEFSUBR(Fmapdllist);
4263 DEFSUBR(Fmapvector);
4264 DEFSUBR(Fmapc_internal);
4265 DEFSUBR(Fmapconcat);
4266 DEFSUBR(Fmapc_inplace);
4270 /* map.c ends here */