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 */
52 Lisp_Object Q_arity, Q_result_type, Q_mode, Q_glue;
53 Lisp_Object Q_separator, Q_initiator, Q_terminator;
54 Lisp_Object Qpntw, Qpointwise, Qpoints;
55 Lisp_Object Qkeyw, Qkeywise, Qkeys;
56 Lisp_Object Qcomb, Qcombination, Qcombinations;
57 Lisp_Object Qperm, Qpermutation, Qpermutations;
58 Lisp_Object Qcart, Qcartesian;
60 typedef Lisp_Object(*glue_f)(int nargs, Lisp_Object *args);
62 static Lisp_Object Qinplace, Qvoid, Qlitter, Qconcat;
63 static Lisp_Object Qvector, Qbit_vector;
66 EXFUN(Fbit_vector, MANY);
68 /* until this is available globally */
69 #define DICTP(x) (HASH_TABLEP(x) || SKIPLISTP(x))
72 Lisp_Object ini, ter, sep;
75 #define deco_ini(x) ((x)->ini)
76 #define deco_sep(x) ((x)->sep)
77 #define deco_ter(x) ((x)->ter)
81 static inline Lisp_Object
82 __Flist(int nargs, Lisp_Object *args)
83 __attribute__((always_inline));
84 static inline Lisp_Object
85 __Flist(int nargs, Lisp_Object *args)
87 /* this is just Flist() but inlined */
88 Lisp_Object val = Qnil;
89 Lisp_Object *argp = args + nargs;
92 val = Fcons(*--argp, val);
96 static long unsigned int
97 __ncombinations(register long unsigned int n, long unsigned int k)
99 /* == binomial(n, k) */
100 if (UNLIKELY(n == k || k == 0)) {
102 } else if (UNLIKELY(k == 1 || n - k == 1)) {
104 } else if (k == 2 || n - k == 2) {
105 return (n * (n-1)) >> 1;
107 /* otherwise do the hard work */
108 long unsigned int num = n*(n-1)*(n-k+1), den = k*(k-1);
110 /* swap k if necessary */
115 for (n -= 2, k -= 2; k > 1;) {
123 static long unsigned int
124 __factorial(register long unsigned int n)
126 register long unsigned int r = n;
128 /* trivial cases first */
152 for (long unsigned int i = 9; i < n; i++) {
158 static long unsigned int
159 __nvariations(register long unsigned int n, long unsigned int k)
161 /* == binomial(n, k) * factorial(k) */
162 if (UNLIKELY(k == 0)) {
164 } else if (UNLIKELY(k == n)) {
165 return __factorial(k);
166 } else if (UNLIKELY(k == 1)) {
168 } else if (UNLIKELY(n - k == 1)) {
169 return __factorial(n);
173 return n * (n-1) * (n-2);
175 /* otherwise do the hard work */
176 long unsigned int num = n--;
188 static long unsigned int
189 __ncart(register long unsigned int n, long unsigned int k)
192 long unsigned int res;
207 for (res = n * n * n * n, k -= 4; k > 0; k--) {
215 __advance_multi_index()
216 __attribute__((always_inline));
218 __advance_multi_index(long int idx[], long int j, long int fam_len)
220 /* partially unroll */
221 if (LIKELY(++idx[--j] < fam_len)) {
225 if (LIKELY(++idx[--j] < fam_len)) {
229 if (LIKELY(++idx[--j] < fam_len)) {
234 if (LIKELY(++idx[--j] < fam_len)) {
243 __advance_multi_index_2()
244 __attribute__((always_inline));
246 __advance_multi_index_2(long int idx[], long int j, size_t flen[])
248 /* improved version of __a_m_v() which allows for differently-sized families */
249 /* partially unroll */
250 if (LIKELY((--j, ++idx[j] < (long int)flen[j]))) {
254 if (LIKELY((--j, ++idx[j] < (long int)flen[j]))) {
258 if (LIKELY((--j, ++idx[j] < (long int)flen[j]))) {
263 if (LIKELY((--j, ++idx[j] < (long int)flen[j]))) {
272 __advance_multi_index_3()
273 __attribute__((always_inline));
275 __advance_multi_index_3(
276 long int idx[], long int j, size_t flen[],
277 long int nseqs, size_t arity[])
279 /* improved version of __a_m_v_2() which allows for differently-sized families
280 * and multiplicities thereof
281 * this is for cartesian indexing, i.e. the order goes
282 * [1,0]->[1,1]->[1,2]->[2,0] for arity (., 3) */
283 long int mlt = arity[--nseqs];
285 if (LIKELY(++idx[--j] < (long int)flen[nseqs])) {
290 mlt = arity[--nseqs];
292 if (LIKELY(++idx[--j] < (long int)flen[nseqs])) {
297 mlt = arity[--nseqs];
299 if (LIKELY(++idx[--j] < (long int)flen[nseqs])) {
304 mlt = arity[--nseqs];
306 while (j > 0 && nseqs >= 0) {
307 if (LIKELY(++idx[--j] < (long int)flen[nseqs])) {
312 mlt = arity[--nseqs];
319 __initialise_multi_index()
320 __attribute__((always_inline));
322 __initialise_multi_index(size_t midx[], size_t arity)
325 for (size_t j = 1; j < arity; j++) {
332 __advance_multi_index_comb()
333 __attribute__((always_inline));
335 __advance_multi_index_comb(size_t idx[], size_t len, int arity)
339 for (i = arity-1; (i >= 0) && idx[i] >= len - arity + i; i--);
341 for (; ++i < arity; ) {
344 return (idx[i-1] < len);
348 __advance_multi_index_4()
349 __attribute__((always_inline));
351 __advance_multi_index_4(
352 size_t *midx[], size_t flen[], long int j /*nseqs*/, size_t arity[])
354 /* like __a_m_v_3(), also allowing for differently-sized families
355 * and multiplicities thereof, but for for combinatorial indexing,
356 * i.e. the order goes
357 * [1,2]->[1,3]->[2,3] for arity (., 3) */
359 if (LIKELY(__advance_multi_index_comb(midx[j], flen[j], arity[j]))) {
360 /* if there's more to come, bingo */
363 /* otherwise reinitialise the mindex we're currently shagging */
364 __initialise_multi_index(midx[j], arity[j]);
367 if (LIKELY(__advance_multi_index_comb(midx[j], flen[j], arity[j]))) {
370 /* otherwise reinitialise the mindex we're currently shagging */
371 __initialise_multi_index(midx[j], arity[j]);
375 if (LIKELY(__advance_multi_index_comb(
376 midx[j], flen[j], arity[j]))) {
379 /* otherwise reinitialise the mindex we're currently shagging */
380 __initialise_multi_index(midx[j], arity[j]);
386 /* This is the guts of several mapping functions.
387 Apply FUNCTION to each element of SEQUENCE, one by one,
388 storing the results into elements of VALS, a C vector of Lisp_Objects.
389 LENI is the length of VALS, which should also be the length of SEQUENCE.
391 If VALS is a null pointer, do not accumulate the results. */
394 mapcar1(size_t leni, Lisp_Object * vals,
395 Lisp_Object function, Lisp_Object sequence)
405 memset(vals, 0, leni * sizeof(Lisp_Object));
409 if (LISTP(sequence)) {
410 /* A devious `function' could either:
411 - insert garbage into the list in front of us, causing XCDR to crash
412 - amputate the list behind us using (setcdr), causing the remaining
413 elts to lose their GCPRO status.
415 if (vals != 0) we avoid this by copying the elts into the
416 `vals' array. By a stroke of luck, `vals' is exactly large
417 enough to hold the elts left to be traversed as well as the
418 results computed so far.
420 if (vals == 0) we don't have any free space available and
421 don't want to eat up any more stack with alloca().
422 So we use EXTERNAL_LIST_LOOP_3_NO_DECLARE and GCPRO the tail. */
425 Lisp_Object *val = vals;
428 LIST_LOOP_2(elt, sequence) {
432 for (i = 0; i < leni; i++) {
434 vals[i] = Ffuncall(2, args);
437 Lisp_Object elt, tail;
438 EMACS_INT len_unused;
439 struct gcpro ngcpro1;
444 EXTERNAL_LIST_LOOP_4_NO_DECLARE(elt, sequence,
454 } else if (VECTORP(sequence)) {
455 Lisp_Object *objs = XVECTOR_DATA(sequence);
457 for (size_t i = 0; i < leni; i++) {
459 result = Ffuncall(2, args);
464 } else if (DLLISTP(sequence)) {
465 dllist_item_t elt = XDLLIST_FIRST(sequence);
467 for (size_t i = 0; elt; i++) {
468 args[1] = (Lisp_Object)elt->item;
469 result = Ffuncall(2, args);
475 } else if (STRINGP(sequence)) {
476 /* The string data of `sequence' might be relocated during GC. */
477 Bytecount slen = XSTRING_LENGTH(sequence);
480 int speccount = specpdl_depth();
483 XMALLOC_ATOMIC_OR_ALLOCA(p, slen, Bufbyte);
486 memcpy(p, XSTRING_DATA(sequence), slen);
489 args[1] = make_char(charptr_emchar(p));
491 result = Ffuncall(2, args);
496 XMALLOC_UNBIND(p, slen, speccount);
497 } else if (BIT_VECTORP(sequence)) {
498 Lisp_Bit_Vector *v = XBIT_VECTOR(sequence);
500 for (size_t i = 0; i < leni; i++) {
501 args[1] = make_int(bit_vector_bit(v, i));
502 result = Ffuncall(2, args);
508 /* unreachable, since Flength (sequence) did not get an error */
518 list_map_inplace(Lisp_Object function, Lisp_Object list)
521 struct gcpro gcpro1, gcpro2;
522 Lisp_Object elt = list;
524 GCPRO2(function, list);
529 XCAR(elt) = Ffuncall(2, args);
536 vector_map_inplace(Lisp_Object function, Lisp_Object tuple)
538 Lisp_Object *objs = XVECTOR_DATA(tuple);
540 size_t i, len = XVECTOR_LENGTH(tuple);
541 struct gcpro gcpro1, gcpro2, gcpro3;
543 GCPRO2n(function, tuple, args, countof(args));
546 for (i = 0; i < len; i++) {
548 *objs++ = Ffuncall(2, args);
555 string_map_inplace(Lisp_Object function, Lisp_Object string)
558 size_t len = XSTRING_LENGTH(string);
559 Bufbyte *p = XSTRING_DATA(string);
560 Bufbyte *end = p + len;
561 struct gcpro gcpro1, gcpro2, gcpro3;
563 GCPRO2n(function, string, args, countof(args));
567 args[1] = make_char(charptr_emchar(p));
568 args[1] = Ffuncall(2, args);
570 set_charptr_emchar(p, XCHAR(args[1]));
572 set_charptr_emchar(p, '\000');
580 bit_vector_map_inplace(Lisp_Object function, Lisp_Object bitvec)
582 Lisp_Bit_Vector *v = XBIT_VECTOR(bitvec);
584 struct gcpro gcpro1, gcpro2, gcpro3;
585 size_t i, len = bit_vector_length(XBIT_VECTOR(bitvec));
587 GCPRO2n(function, bitvec, args, countof(args));
590 for (i = 0; i < len; i++) {
591 args[1] = make_int(bit_vector_bit(v, i));
592 args[1] = Ffuncall(2, args);
593 if ((NUMBERP(args[1]) && ent_unrel_zerop(args[1])) ||
595 set_bit_vector_bit(v, i, 0);
597 set_bit_vector_bit(v, i, -1);
604 * The mapfam approach
607 /* auxiliary stuff */
609 __fam_size(Lisp_Object fam)
611 return seq_length((seq_t)(void*)fam);
615 __nfam_min_size(Lisp_Object fam[], size_t nfam)
619 /* catch the horst-case */
620 if (UNLIKELY(nfam == 0)) {
623 /* otherwise unroll a little */
624 res = __fam_size(fam[0]);
625 for (size_t j = 1; j < nfam; j++) {
626 size_t tmp = __fam_size(fam[j]);
635 __nfam_min_size_a(Lisp_Object fam[], size_t nfam, size_t arity[])
639 /* catch the horst-case */
640 if (UNLIKELY(nfam == 0)) {
643 /* otherwise unroll a little */
644 res = __fam_size(fam[0]) / arity[0];
645 for (size_t j = 1; j < nfam; j++) {
646 size_t tmp = __fam_size(fam[j]) / arity[j];
655 __nfam_cart_sum_size(size_t *sum, size_t *cart, size_t nfsz[],
656 Lisp_Object fam[], size_t nfam)
658 /* computes the size of the cartesian set and the maximum size of
659 * the union set, returns the sum of cartesian and union, and puts
660 * intermediately computed family sizes int nfsz */
662 /* catch the horst-case */
663 if (UNLIKELY(nfam == 0)) {
666 } else if (nfam == 1) {
667 /* another horst case
668 * just 1 fam should always call fam_size() */
669 return *sum = *cart = nfsz[0] = __fam_size(fam[0]);
671 /* otherwise unroll a little */
672 nfsz[0] = __fam_size(fam[0]);
673 nfsz[1] = __fam_size(fam[1]);
674 *sum = nfsz[0] + nfsz[1];
675 *cart = nfsz[0] * nfsz[1];
676 for (size_t j = 2; j < nfam; j++) {
677 nfsz[j] = __fam_size(fam[j]);
685 __my_pow_insitu(size_t *base, size_t expon)
687 /* improve me and put me somewhere else, ase-arith.h? */
688 for (size_t i = 1, b = *base; i < expon; i++) {
695 __my_pow_explicit(size_t base, size_t expon)
697 /* improve me and put me somewhere else, ase-arith.h? */
699 for (size_t i = 1; i < expon; i++) {
706 __nfam_cart_sum_size_a(size_t *sum, size_t *cart, size_t *midxsz,
708 Lisp_Object fam[], size_t nfam, size_t arity[])
710 /* computes the size of the cartesian set (put into *cart), the maximum
711 * size of the union set (returned) and the multiplicity of the
712 * multi-index (which is the cross sum of the arity array) returns the
713 * sum of cartesian and union, and puts intermediately computed family
716 /* catch the horst-case */
717 if (UNLIKELY(nfam == 0)) {
718 *sum = *cart = *midxsz = 0;
720 } else if (nfam == 1) {
721 /* another horst case
722 * just 1 fam should always call fam_size() */
723 *sum = *cart = nfsz[0] = __fam_size(fam[0]);
724 __my_pow_insitu(cart, *midxsz = arity[0]);
727 /* otherwise unroll a little */
728 nfsz[0] = __fam_size(fam[0]);
729 nfsz[1] = __fam_size(fam[1]);
730 *sum = nfsz[0] + nfsz[1];
731 *midxsz = arity[0] + arity[1];
732 *cart = __my_pow_explicit(nfsz[0], arity[0]) *
733 __my_pow_explicit(nfsz[1], arity[1]);
734 for (size_t j = 2; j < nfam; j++) {
735 nfsz[j] = __fam_size(fam[j]);
738 *cart *= __my_pow_explicit(nfsz[j], arity[j]);
744 __nfam_comb_sum_size_a(size_t *sum, size_t *comb, size_t *midxsz,
746 Lisp_Object fam[], size_t nfam, size_t arity[])
748 /* computes the size of the cartesian set (returned), the maximum size of
749 * the union set and the multiplicity of the multi-index (which is the
750 * cross sum of the arity array) returns the sum of cartesian and union,
751 * and puts intermediately computed family sizes into nfsz */
753 /* catch the horst-case */
754 if (UNLIKELY(nfam == 0)) {
755 *sum = *comb = *midxsz = 0;
757 } else if (nfam == 1) {
758 /* another horst case
759 * just 1 fam should always call fam_size() */
760 *sum = nfsz[0] = __fam_size(fam[0]);
761 *comb = __ncombinations(nfsz[0], *midxsz = arity[0]);
764 /* otherwise unroll a little */
765 nfsz[0] = __fam_size(fam[0]);
766 nfsz[1] = __fam_size(fam[1]);
767 *sum = nfsz[0] + nfsz[1];
768 *midxsz = arity[0] + arity[1];
769 *comb = __ncombinations(nfsz[0], arity[0]) *
770 __ncombinations(nfsz[1], arity[1]);
771 for (size_t j = 2; j < nfam; j++) {
772 nfsz[j] = __fam_size(fam[j]);
775 *comb *= __ncombinations(nfsz[j], arity[j]);
781 __nfam_perm_sum_size(size_t *sum, size_t *cart, size_t *perm, size_t nfsz[],
782 Lisp_Object fam[], size_t nfam)
784 /* computes the size of the cartesian set and the maximum size of
785 * the union set, returns the sum of cartesian and union, and puts
786 * intermediately computed family sizes int nfsz */
788 /* catch the horst-case */
789 if (UNLIKELY(nfam == 0)) {
790 *sum = *cart = *perm = 0;
792 } else if (nfam == 1) {
793 /* another horst case
794 * just 1 fam should always call fam_size() */
796 return *sum = *cart = nfsz[0] = __fam_size(fam[0]);
798 /* otherwise unroll a little */
799 nfsz[0] = __fam_size(fam[0]);
800 nfsz[1] = __fam_size(fam[1]);
801 *sum = nfsz[0] + nfsz[1];
802 *cart = nfsz[0] * nfsz[1];
803 for (size_t j = 2; j < nfam; j++) {
804 nfsz[j] = __fam_size(fam[j]);
808 *cart *= (*perm = __factorial(nfam));
813 __nfam_perm_sum_size_a(size_t *sum, size_t *var, size_t *perm, size_t *midxsz,
815 Lisp_Object fam[], size_t nfam, size_t arity[])
817 /* computes the size of the cartesian set (returned), the maximum size of
818 * the union set and the multiplicity of the multi-index (which is the
819 * cross sum of the arity array) returns the sum of cartesian and union,
820 * and puts intermediately computed family sizes into nfsz */
822 /* catch the horst-case */
823 if (UNLIKELY(nfam == 0)) {
824 *sum = *var = *perm = *midxsz = 0;
826 } else if (nfam == 1) {
827 /* another horst case
828 * just 1 fam should always call fam_size() */
829 *sum = nfsz[0] = __fam_size(fam[0]);
830 *perm = __factorial(*midxsz = arity[0]);
831 *var = __ncombinations(nfsz[0], arity[0]) * *perm;
834 /* otherwise unroll a little */
835 nfsz[0] = __fam_size(fam[0]);
836 nfsz[1] = __fam_size(fam[1]);
837 *sum = nfsz[0] + nfsz[1];
838 *midxsz = arity[0] + arity[1];
839 *var = __ncombinations(nfsz[0], arity[0]) *
840 __ncombinations(nfsz[1], arity[1]);
841 for (size_t j = 2; j < nfam; j++) {
842 nfsz[j] = __fam_size(fam[j]);
845 *var *= __ncombinations(nfsz[j], arity[j]);
847 /* we computed the number of combinations above, now to compute
848 * the number of variations we have to apply the S_{midxsz} on
849 * each element, hence we simply multiply with the factorial of
850 * midxsz (which is the cross sum of all arities) */
851 *var *= (*perm = __factorial(*midxsz));
856 * dedicated subroutines for 2-combs and 3-combs because they are soooo easy
859 __2comb(Lisp_Object tgts[], size_t SXE_UNUSED(tlen),
860 Lisp_Object supp[], size_t slen,
861 Lisp_Object fun, glue_f gf)
863 /* assumes that everything is gcpro'd properly */
864 Lisp_Object arr[3] = {fun, Qnil, Qnil};
866 if (LIKELY(!NILP(fun) && gf == NULL)) {
867 for (size_t i = 0, l = 0; i < slen-1; i++) {
868 for (size_t j = i+1; j < slen; j++) {
869 /* set up the array */
873 tgts[l++] = Ffuncall(countof(arr), arr);
876 } else if (LIKELY(!NILP(fun))) {
877 for (size_t i = 0, l = 0; i < slen-1; i++) {
878 for (size_t j = i+1; j < slen; j++) {
879 /* set up the array */
883 arr[1] = gf(2, &arr[1]);
885 tgts[l++] = Ffuncall(2, arr);
889 glue_f tgf = gf ? gf : Flist;
890 for (size_t i = 0, l = 0; i < slen-1; i++) {
891 for (size_t j = i+1; j < slen; j++) {
892 /* set up the array */
896 tgts[l++] = tgf(2, &arr[1]);
904 __3comb(Lisp_Object tgts[], size_t SXE_UNUSED(tlen),
905 Lisp_Object supp[], size_t slen,
906 Lisp_Object fun, glue_f gf)
908 /* assumes that everything is gcpro'd properly */
909 Lisp_Object arr[4] = {fun, Qnil, Qnil, Qnil};
911 if (LIKELY(!NILP(fun) && gf == NULL)) {
912 for (size_t i = 0, l = 0; i < slen-2; i++) {
913 for (size_t j = i+1; j < slen-1; j++) {
914 for (size_t k = j+1; k < slen; k++) {
915 /* set up the array */
920 tgts[l++] = Ffuncall(countof(arr), arr);
924 } else if (LIKELY(!NILP(fun))) {
925 for (size_t i = 0, l = 0; i < slen-2; i++) {
926 for (size_t j = i+1; j < slen-1; j++) {
927 for (size_t k = j+1; k < slen; k++) {
928 /* set up the array */
933 arr[1] = gf(3, &arr[1]);
935 tgts[l++] = Ffuncall(2, arr);
940 glue_f tgf = gf ? gf : Flist;
941 for (size_t i = 0, l = 0; i < slen-2; i++) {
942 for (size_t j = i+1; j < slen-1; j++) {
943 for (size_t k = j+1; k < slen; k++) {
944 /* set up the array */
949 tgts[l++] = tgf(3, &arr[1]);
958 __ncomb(Lisp_Object tgts[], size_t tlen,
959 Lisp_Object supp[], size_t slen,
960 Lisp_Object fun, glue_f gf,
963 /* assumes that everything is gcpro'd properly */
966 Lisp_Object fc[arity+1], *v = &fc[1];
969 memset(idx, 0, arity*sizeof(long int));
970 memset(v, 0, arity*sizeof(Lisp_Object));
973 /* special case slen == arity */
974 if (UNLIKELY(slen == arity)) {
975 if (LIKELY(!NILP(fun) && gf == NULL)) {
976 tgts[0] = Ffuncall(slen, supp);
977 } else if (LIKELY(!NILP(fun))) {
978 v[0] = gf(slen, supp);
979 tgts[0] = Ffuncall(2, fc);
981 glue_f tgf = gf ? gf : Flist;
982 tgts[0] = tgf(slen, supp);
987 /* setup, partially unrolled */
990 for (size_t i = 2; i < arity; i++) {
994 if (LIKELY(!NILP(fun) && gf == NULL)) {
998 for (size_t i = 2; i < arity; i++) {
1002 tgts[l++] = Ffuncall(countof(fc), fc);
1003 /* increment, fooking back'n'forth-loop-based
1005 (void)__advance_multi_index_comb(idx, slen, arity);
1007 } else if (LIKELY(!NILP(fun))) {
1009 v[0] = supp[idx[0]];
1010 v[1] = supp[idx[1]];
1011 for (size_t i = 2; i < arity; i++) {
1012 v[i] = supp[idx[i]];
1015 v[0] = gf(arity, v);
1017 tgts[l++] = Ffuncall(2, fc);
1018 /* increment, fooking back'n'forth-loop-based
1020 (void)__advance_multi_index_comb(idx, slen, arity);
1023 glue_f tgf = gf ? gf : Flist;
1025 v[0] = supp[idx[0]];
1026 v[1] = supp[idx[1]];
1027 for (size_t i = 2; i < arity; i++) {
1028 v[i] = supp[idx[i]];
1031 tgts[l++] = tgf(arity, v);
1032 /* increment, fooking back'n'forth-loop-based
1034 (void)__advance_multi_index_comb(idx, slen, arity);
1042 * dedicated subroutines for 2-perms and 3-perms because they are soooo easy
1043 * 2-perms (transpositions) is just a 2-cycle along with its transposition,
1044 * so we can directly reuse the comb algorithm
1045 * 3-perms are just as simple, since the generation of S_3 can simply be put
1046 * as (), a, a^2, b, a*b, a^2*b where a is a 3-cycle and b a 2-cycle.
1048 static inline size_t
1049 __2perm_fun(Lisp_Object tgts[], size_t SXE_UNUSED(tlen),
1050 Lisp_Object supp[], size_t SXE_UNUSED(slen),
1053 __attribute__((always_inline));
1054 static inline size_t
1055 __2perm_fun(Lisp_Object tgts[], size_t SXE_UNUSED(tlen),
1056 Lisp_Object supp[], size_t SXE_UNUSED(slen),
1060 /* apply fun on S_2 on (the first two elements of) supp */
1061 Lisp_Object arr[3] = {fun, Qnil, Qnil};
1063 /* set up the array */
1067 tgts[offset++] = Ffuncall(countof(arr), arr);
1069 /* swap them == (1,2) */
1073 tgts[offset++] = Ffuncall(countof(arr), arr);
1077 static inline size_t
1078 __2perm_glue_fun(Lisp_Object tgts[], size_t SXE_UNUSED(tlen),
1079 Lisp_Object supp[], size_t SXE_UNUSED(slen),
1080 Lisp_Object fun, glue_f gf,
1082 __attribute__((always_inline));
1083 static inline size_t
1084 __2perm_glue_fun(Lisp_Object tgts[], size_t SXE_UNUSED(tlen),
1085 Lisp_Object supp[], size_t SXE_UNUSED(slen),
1086 Lisp_Object fun, glue_f gf,
1089 /* apply fun on the glue of S_2 on (the first two elements of) supp */
1090 Lisp_Object arr[3] = {fun, Qnil, Qnil};
1092 /* set up the array */
1096 arr[1] = gf(2, &arr[1]);
1098 tgts[offset++] = Ffuncall(2, arr);
1100 /* swap them == (1,2) */
1104 arr[1] = gf(2, &arr[1]);
1106 tgts[offset++] = Ffuncall(2, arr);
1110 static inline size_t
1111 __2perm_glue(Lisp_Object tgts[], size_t SXE_UNUSED(tlen),
1112 Lisp_Object supp[], size_t SXE_UNUSED(slen),
1115 __attribute__((always_inline));
1116 static inline size_t
1117 __2perm_glue(Lisp_Object tgts[], size_t SXE_UNUSED(tlen),
1118 Lisp_Object supp[], size_t SXE_UNUSED(slen),
1122 /* glue of S_2 on (the first two elements of) supp */
1123 volatile Lisp_Object tmp = supp[0];
1125 /* directly apply glue */
1126 tgts[offset++] = gf(2, supp);
1128 /* swap them == (1,2) */
1132 tgts[offset++] = gf(2, supp);
1136 static inline size_t
1137 _2perm(Lisp_Object tgts[], size_t tlen,
1138 Lisp_Object supp[], size_t slen,
1139 Lisp_Object fun, glue_f gf,
1142 /* assumes that everything is gcpro'd correctly */
1143 if (LIKELY(!NILP(fun) && gf == NULL)) {
1144 return __2perm_fun(tgts, tlen, supp, slen, fun, offset);
1145 } else if (LIKELY(!NILP(fun))) {
1146 return __2perm_glue_fun(tgts, tlen, supp, slen,
1149 return __2perm_glue(tgts, tlen, supp, slen,
1150 gf ? gf : Flist, offset);
1155 _comb_2perm(Lisp_Object *tgts, size_t tlen,
1156 Lisp_Object *supp, size_t slen,
1157 Lisp_Object fun, glue_f gf)
1159 /* loop over everything in supp and form combinations thereof,
1161 * assumes that everything is gcpro'd correctly */
1162 Lisp_Object v[2] = {Qnil, Qnil};
1164 if (LIKELY(!NILP(fun) && gf == NULL)) {
1165 for (size_t i = 0, l = 0; i < slen-1; i++) {
1166 for (size_t j = i+1; j < slen; j++) {
1169 l = __2perm_fun(tgts, tlen, v, 2, fun, l);
1173 } else if (LIKELY(!NILP(fun))) {
1174 for (size_t i = 0, l = 0; i < slen-1; i++) {
1175 for (size_t j = i+1; j < slen; j++) {
1178 l = __2perm_glue_fun(
1179 tgts, tlen, v, 2, fun, gf, l);
1184 glue_f tgf = gf ? gf : Flist;
1185 for (size_t i = 0, l = 0; i < slen-1; i++) {
1186 for (size_t j = i+1; j < slen; j++) {
1189 l = __2perm_glue(tgts, tlen, v, 2, tgf, l);
1197 static inline size_t
1198 __3perm_fun(Lisp_Object tgts[], size_t SXE_UNUSED(tlen),
1199 Lisp_Object supp[], size_t SXE_UNUSED(slen),
1202 __attribute__((always_inline));
1203 static inline size_t
1204 __3perm_fun(Lisp_Object tgts[], size_t SXE_UNUSED(tlen),
1205 Lisp_Object supp[], size_t SXE_UNUSED(slen),
1209 /* apply fun on S_3 on (the first 3 elements of) supp */
1210 Lisp_Object arr[4] = {fun, Qnil, Qnil, Qnil};
1212 /* we use gap's order of the elements of S3
1213 * gap> Elements(SymmetricGroup(3));
1214 * [ (), (2,3), (1,2), (1,2,3), (1,3,2), (1,3) ] */
1221 tgts[offset++] = Ffuncall(countof(arr), arr);
1227 tgts[offset++] = Ffuncall(countof(arr), arr);
1234 tgts[offset++] = Ffuncall(countof(arr), arr);
1240 tgts[offset++] = Ffuncall(countof(arr), arr);
1247 tgts[offset++] = Ffuncall(countof(arr), arr);
1253 tgts[offset++] = Ffuncall(countof(arr), arr);
1258 static inline size_t
1259 __3perm_glue_fun(Lisp_Object tgts[], size_t SXE_UNUSED(tlen),
1260 Lisp_Object supp[], size_t SXE_UNUSED(slen),
1261 Lisp_Object fun, glue_f gf,
1263 __attribute__((always_inline));
1264 static inline size_t
1265 __3perm_glue_fun(Lisp_Object tgts[], size_t SXE_UNUSED(tlen),
1266 Lisp_Object supp[], size_t SXE_UNUSED(slen),
1267 Lisp_Object fun, glue_f gf,
1270 /* apply fun on the glue of S_3 on (the first 3 elements of) supp */
1271 Lisp_Object arr[4] = {fun, Qnil, Qnil, Qnil};
1273 /* we use gap's order of the elements of S3
1274 * gap> Elements(SymmetricGroup(3));
1275 * [ (), (2,3), (1,2), (1,2,3), (1,3,2), (1,3) ] */
1282 arr[1] = gf(3, &arr[1]);
1284 tgts[offset++] = Ffuncall(2, arr);
1291 arr[1] = gf(3, &arr[1]);
1293 tgts[offset++] = Ffuncall(2, arr);
1300 arr[1] = gf(3, &arr[1]);
1302 tgts[offset++] = Ffuncall(2, arr);
1309 arr[1] = gf(3, &arr[1]);
1311 tgts[offset++] = Ffuncall(2, arr);
1318 arr[1] = gf(3, &arr[1]);
1320 tgts[offset++] = Ffuncall(2, arr);
1327 arr[1] = gf(3, &arr[1]);
1329 tgts[offset++] = Ffuncall(2, arr);
1334 static inline size_t
1335 __3perm_glue(Lisp_Object tgts[], size_t SXE_UNUSED(tlen),
1336 Lisp_Object supp[], size_t SXE_UNUSED(slen),
1339 __attribute__((always_inline));
1340 static inline size_t
1341 __3perm_glue(Lisp_Object tgts[], size_t SXE_UNUSED(tlen),
1342 Lisp_Object supp[], size_t SXE_UNUSED(slen),
1346 /* glue of S_3 on (the first 3 elements of) supp */
1347 volatile Lisp_Object tmp;
1349 /* we use gap's order of the elements of S3
1350 * gap> Elements(SymmetricGroup(3));
1351 * [ (), (2,3), (1,2), (1,2,3), (1,3,2), (1,3) ] */
1353 /* (), directly apply glue */
1354 tgts[offset++] = gf(3, supp);
1361 tgts[offset++] = gf(3, supp);
1363 /* (0,1) == (0,1)(1,2)(1,2) == (0,1,2)(1,2) */
1369 tgts[offset++] = gf(3, supp);
1371 /* (0,1,2) == (0,2)(0,1) */
1376 tgts[offset++] = gf(3, supp);
1378 /* (0,2,1) == (0,1,2)(0,1,2) */
1384 tgts[offset++] = gf(3, supp);
1386 /* (0,2) == (0,1)(0,2,1) */
1391 tgts[offset++] = gf(3, supp);
1397 _comb_3perm(Lisp_Object *tgts, size_t tlen,
1398 Lisp_Object *supp, size_t slen,
1399 Lisp_Object fun, glue_f gf)
1401 /* loop over everything in supp and form combinations thereof,
1403 * assumes that everything is gcpro'd correctly */
1404 Lisp_Object v[3] = {Qnil, Qnil, Qnil};
1406 if (LIKELY(!NILP(fun) && gf == NULL)) {
1407 for (size_t i = 0, l = 0; i < slen-2; i++) {
1408 for (size_t j = i+1; j < slen-1; j++) {
1409 for (size_t k = j+1; k < slen; k++) {
1414 tgts, tlen, v, 3, fun, l);
1419 } else if (LIKELY(!NILP(fun))) {
1420 for (size_t i = 0, l = 0; i < slen-2; i++) {
1421 for (size_t j = i+1; j < slen-1; j++) {
1422 for (size_t k = j+1; k < slen; k++) {
1426 l = __3perm_glue_fun(
1427 tgts, tlen, v, 3, fun, gf, l);
1433 glue_f tgf = gf ? gf : Flist;
1434 for (size_t i = 0, l = 0; i < slen-2; i++) {
1435 for (size_t j = i+1; j < slen-1; j++) {
1436 for (size_t k = j+1; k < slen; k++) {
1441 tgts, tlen, v, 3, tgf, l);
1450 __transpose(Lisp_Object arr[], size_t i, size_t j)
1451 __attribute__((always_inline));
1453 __transpose(Lisp_Object arr[], size_t i, size_t j)
1455 /* use xchg assembly? */
1456 volatile Lisp_Object tmp = arr[i];
1462 static inline long int
1463 __divmod3(long int *_div_, long int num)
1464 __attribute__((always_inline));
1466 /* idivl uses >48 cycles, which is too slow for division by constants */
1467 static inline long int
1468 __divmod3(long int *_div_, long int num)
1470 /* compute _DIV_ div 3 and _DIV_ mod 3,
1471 * store the divisor in `_DIV_', the remainder in `_REM_' */
1475 __asm__("idivl %[modulus]; /* eax,edx = eax idivl 3 */\n\t"
1476 : "=&d" (_rem_), "+%a" (*_div_)
1477 : [modulus] "rm" (3) : "cc");
1481 static inline long int
1482 __divmod3(long int *_div_, long int num)
1484 long int rem = num % 3;
1490 static inline long int
1491 __divmodk(long int *_div_, long int modulus)
1492 __attribute__((always_inline));
1494 static inline long int
1495 __divmodk(long int *_div_, long int modulus)
1497 /* compute _DIV_ div MODULUS and _DIV_ mod MODULUS,
1498 * store the divisor in `_DIV_', the remainder in `_REM_'
1499 * this assembler version takes ... cycles on x86 and x86_64 processors,
1500 * however the generated code below seems to be faster -- and is more
1501 * portable anyway, since it's C */
1504 __asm__("idivl %[modulus]; /* eax,edx = eax idivl 3 */\n\t"
1505 : "=&d" (_rem_), "+%a" (*_div_)
1506 : [modulus] "rm" (modulus) : "cc");
1510 static inline long int
1511 __divmodk(long int *_div_, long int modulus)
1513 long int rem = *_div_ % modulus;
1520 __bruhat(Lisp_Object arr[], long int k)
1521 __attribute__((always_inline));
1523 __bruhat(Lisp_Object arr[], long int k)
1525 /* computes the k-th transposition in quasi bruhat order and
1526 * applies it to arr */
1528 if (UNLIKELY(k == 0)) {
1532 /* odd Ks always connote (0,1) */
1533 __transpose(arr, 0, 1);
1535 } else if (__divmod3(&k, (k >>= 1))) {
1536 /* 1 mod 3 and 2 mod 3 go to (1,2) */
1537 __transpose(arr, 1, 2);
1541 /* otherwise k is 0 mod 3 (and we divided by 3 already)
1542 * now we've factored out S_3 already */
1543 switch (k & 3 /* k % 4 */) {
1545 __transpose(arr, 2, 3);
1548 __transpose(arr, 0, 3);
1551 __transpose(arr, 1, 3);
1558 /* S_2, S_3, and S_4 is handled about, go on with S_5 now */
1559 for (int i = 5; k; i++) {
1561 if ((rem = __divmodk(&k, i))) {
1562 if (i & 1 || (rem -= 2) < 0) {
1563 /* odd i always induces the
1564 * (i-1, i) transposition
1565 * in C this is (i-2, i-1) */
1566 __transpose(arr, i-2, i-1);
1568 /* even i is uglier :(
1569 * if rem == 1 -> (i-1, i)
1570 * if rem == 2 -> (1, i)
1571 * if rem == 3 -> (2, i)
1573 __transpose(arr, rem, i-1);
1574 /* note: we treated the rem == 1 case above */
1582 static inline size_t
1583 __Sn_fun(Lisp_Object tgts[], size_t tlen,
1584 Lisp_Object supp[], size_t slen,
1587 __attribute__((always_inline));
1588 static inline size_t
1589 __Sn_fun(Lisp_Object tgts[], size_t tlen,
1590 Lisp_Object supp[], size_t slen,
1594 /* apply FUN on S_n on (the first SLEN elements of) SUPP
1595 * put results into TGTS
1596 * assumes that everything is gcpro'd correctly
1597 * also assumes that tlen == __factorial(slen) */
1598 Lisp_Object arr[slen+1], *v = &arr[1];
1600 /* setup, partially unrolled */
1605 for (size_t i = 3; i < slen; i++) {
1609 /* now we're in the setting ... */
1610 /* we enter the perm loop now, the first addition is the vector
1611 * times identity permutation */
1612 while (tlen-- > 0) {
1613 tgts[offset++] = Ffuncall(countof(arr), arr);
1614 /* permute the working vector */
1615 __bruhat(v, offset);
1620 static inline size_t
1621 __Sn_glue_fun(Lisp_Object tgts[], size_t tlen,
1622 Lisp_Object supp[], size_t slen,
1623 Lisp_Object fun, glue_f gf,
1625 __attribute__((always_inline));
1626 static inline size_t
1627 __Sn_glue_fun(Lisp_Object tgts[], size_t tlen,
1628 Lisp_Object supp[], size_t slen,
1629 Lisp_Object fun, glue_f gf,
1632 /* apply FUN on glue of S_n on (the first SLEN elements of) SUPP
1633 * put results into TGTS
1634 * assumes that everything is gcpro'd correctly
1635 * also assumes that tlen == __factorial(slen) */
1636 Lisp_Object arr[slen+1], *v = &arr[1];
1638 /* setup, partially unrolled */
1643 for (size_t i = 3; i < slen; i++) {
1647 /* now we're in the setting ... */
1648 /* we enter the perm loop now, the first addition is the vector
1649 * times identity permutation */
1650 while (tlen-- > 0) {
1651 /* backup that first slot */
1652 volatile Lisp_Object tmp = v[0];
1654 tgts[offset++] = Ffuncall(2, arr);
1655 /* recover from backup slot */
1657 /* permute the working vector */
1658 __bruhat(v, offset);
1663 static inline size_t
1664 __Sn_glue(Lisp_Object tgts[], size_t tlen,
1665 Lisp_Object supp[], size_t slen,
1668 __attribute__((always_inline));
1669 static inline size_t
1670 __Sn_glue(Lisp_Object tgts[], size_t tlen,
1671 Lisp_Object supp[], size_t slen,
1675 /* glue of S_n on (the first SLEN elements of) SUPP
1676 * put results into TGTS
1677 * assumes that everything is gcpro'd correctly
1678 * also assumes that tlen == __factorial(slen) */
1679 Lisp_Object arr[slen];
1681 /* setup, partially unrolled */
1685 for (size_t i = 3; i < slen; i++) {
1689 /* now we're in the setting ... */
1690 /* we enter the perm loop now, the first addition is the vector
1691 * times identity permutation */
1692 while (tlen-- > 0) {
1693 tgts[offset++] = gf(countof(arr), arr);
1694 /* permute the working vector */
1695 __bruhat(arr, offset);
1700 static inline void /* inline this? */
1701 _Sn(Lisp_Object tgts[], size_t tlen,
1702 Lisp_Object supp[], size_t slen,
1703 Lisp_Object fun, glue_f gf)
1704 __attribute__((always_inline));
1706 _Sn(Lisp_Object tgts[], size_t tlen,
1707 Lisp_Object supp[], size_t slen,
1708 Lisp_Object fun, glue_f gf)
1710 /* assumes that everything is gcpro'd correctly
1711 * this is just an intermediate switch, the hard work happens in
1712 * __Sn_fun(), __Sn_glue_fun() and __Sn_glue() depending on whether
1713 * just a function and no glue has been specified, a function and a glue
1714 * function has been specified, or just a glue function has been
1715 * specified respectively */
1717 if (LIKELY(!NILP(fun) && gf == NULL)) {
1718 (void)__Sn_fun(tgts, tlen, supp, slen, fun, 0);
1719 } else if (LIKELY(!NILP(fun))) {
1720 (void)__Sn_glue_fun(tgts, tlen, supp, slen, fun, gf, 0);
1722 glue_f tgf = gf ? gf : Flist;
1723 (void)__Sn_glue(tgts, tlen, supp, slen, tgf, 0);
1729 _comb_Sn(Lisp_Object tgts[], size_t tlen,
1730 Lisp_Object supp[], size_t slen,
1731 Lisp_Object fun, glue_f gf,
1734 /* assumes that everything is gcpro'd correctly
1735 * this has the same signature as _Sn() but additionally there's the
1737 * this is basically the code for variations, i.e. applying the S_m
1738 * (m < n) on some subset of size m of a set of size n */
1739 Lisp_Object v[arity];
1740 size_t idx[arity+1];
1741 size_t l = 0, np = __factorial(arity);
1744 memset(idx, 0, arity*sizeof(long int));
1746 /* more setup, partially unrolled */
1750 for (size_t i = 3; i < arity; i++) {
1754 if (LIKELY(!NILP(fun) && gf == NULL)) {
1756 /* get the combinations, serves as starting set,
1757 * partially unrolled */
1758 v[0] = supp[idx[0]];
1759 v[1] = supp[idx[1]];
1760 v[2] = supp[idx[2]];
1761 for (size_t i = 3; i < arity; i++) {
1762 v[i] = supp[idx[i]];
1764 /* do the rain dance */
1765 l = __Sn_fun(tgts, np, v, arity, fun, l);
1766 /* increment, fooking back'n'forth-loop-based
1768 (void)__advance_multi_index_comb(idx, slen, arity);
1770 } else if (LIKELY(!NILP(fun))) {
1772 /* get the combinations, serves as starting set,
1773 * partially unrolled */
1774 v[0] = supp[idx[0]];
1775 v[1] = supp[idx[1]];
1776 v[2] = supp[idx[2]];
1777 for (size_t i = 3; i < arity; i++) {
1778 v[i] = supp[idx[i]];
1780 /* do the rain dance */
1781 l = __Sn_glue_fun(tgts, np, v, arity, fun, gf, l);
1782 /* increment, fooking back'n'forth-loop-based
1784 (void)__advance_multi_index_comb(idx, slen, arity);
1787 glue_f tgf = gf ? gf : Flist;
1789 /* get the combinations, serves as starting set,
1790 * partially unrolled */
1791 v[0] = supp[idx[0]];
1792 v[1] = supp[idx[1]];
1793 v[2] = supp[idx[2]];
1794 for (size_t i = 3; i < arity; i++) {
1795 v[i] = supp[idx[i]];
1797 /* do the rain dance */
1798 l = __Sn_glue(tgts, np, v, arity, tgf, l);
1799 /* increment, fooking back'n'forth-loop-based
1801 (void)__advance_multi_index_comb(idx, slen, arity);
1809 _2cart(Lisp_Object tgts[], size_t tlen,
1810 Lisp_Object supp[], size_t slen,
1811 Lisp_Object fun, glue_f gf)
1813 /* assumes that everything is gcpro'd properly
1814 * This function can GC */
1815 Lisp_Object arr[3] = {fun, Qnil, Qnil};
1817 if (LIKELY(!NILP(fun) && gf == NULL)) {
1818 for (size_t i = 0, l = 0; i < slen; i++) {
1819 for (size_t j = 0; j < slen; j++) {
1820 /* set up the array */
1824 tgts[l++] = Ffuncall(countof(arr), arr);
1827 } else if (LIKELY(!NILP(fun))) {
1828 for (size_t i = 0, l = 0; i < slen; i++) {
1829 for (size_t j = 0; j < slen; j++) {
1830 /* set up the array */
1834 arr[1] = gf(2, &arr[1]);
1836 tgts[l++] = Ffuncall(2, arr);
1840 glue_f tgf = gf ? gf : Flist;
1841 for (size_t i = 0, l = 0; i < slen; i++) {
1842 for (size_t j = 0; j < slen; j++) {
1843 /* set up the array */
1847 tgts[l++] = tgf(2, &arr[1]);
1855 _3cart(Lisp_Object tgts[], size_t tlen,
1856 Lisp_Object supp[], size_t slen,
1857 Lisp_Object fun, glue_f gf)
1859 /* assumes that everything is gcpro'd properly
1860 * This function can GC */
1861 Lisp_Object arr[4] = {fun, Qnil, Qnil, Qnil};
1863 if (LIKELY(!NILP(fun) && gf == NULL)) {
1864 for (size_t i = 0, l = 0; i < slen; i++) {
1865 for (size_t j = 0; j < slen; j++) {
1866 for (size_t k = 0; k < slen; k++) {
1867 /* set up the array */
1872 tgts[l++] = Ffuncall(countof(arr), arr);
1876 } else if (LIKELY(!NILP(fun))) {
1877 for (size_t i = 0, l = 0; i < slen; i++) {
1878 for (size_t j = 0; j < slen; j++) {
1879 for (size_t k = 0; k < slen; k++) {
1880 /* set up the array */
1885 arr[1] = gf(3, &arr[1]);
1887 tgts[l++] = Ffuncall(2, arr);
1892 glue_f tgf = gf ? gf : Flist;
1893 for (size_t i = 0, l = 0; i < slen; i++) {
1894 for (size_t j = 0; j < slen; j++) {
1895 for (size_t k = 0; k < slen; k++) {
1896 /* set up the array */
1901 tgts[l++] = tgf(3, &arr[1]);
1910 _ncart(Lisp_Object tgts[], size_t tlen,
1911 Lisp_Object supp[], size_t slen,
1912 Lisp_Object fun, glue_f gf,
1915 /* assumes that everything is gcpro'd properly
1916 * This function can GC */
1917 long int idx[arity]; /* the multi-index */
1919 Lisp_Object fc[arity+1], *v = &fc[1];
1922 memset(idx, 0, arity*sizeof(long int));
1923 memset(v, 0, arity*sizeof(Lisp_Object));
1926 /* now we're in the setting ... */
1927 if (LIKELY(!NILP(fun) && gf == NULL)) {
1929 /* get the fam data, partially unrolled */
1930 v[0] = supp[idx[0]];
1931 v[1] = supp[idx[1]];
1932 v[2] = supp[idx[2]];
1933 for (size_t i = 3; i < arity; i++) {
1934 v[i] = supp[idx[i]];
1937 tgts[l++] = Ffuncall(countof(fc), fc);
1938 /* advance the multi-index, partially unrolled */
1939 __advance_multi_index(idx, arity, slen);
1941 } else if (LIKELY(!NILP(fun))) {
1943 /* get the fam data, partially unrolled */
1944 v[0] = supp[idx[0]];
1945 v[1] = supp[idx[1]];
1946 v[2] = supp[idx[2]];
1947 for (size_t i = 3; i < arity; i++) {
1948 v[i] = supp[idx[i]];
1951 v[0] = gf(arity, v);
1953 tgts[l++] = Ffuncall(2, fc);
1954 /* advance the multi-index, partially unrolled */
1955 __advance_multi_index(idx, arity, slen);
1958 glue_f tgf = gf ? gf : Flist;
1960 /* get the fam data, partially unrolled */
1961 v[0] = supp[idx[0]];
1962 v[1] = supp[idx[1]];
1963 v[2] = supp[idx[2]];
1964 for (size_t i = 3; i < arity; i++) {
1965 v[i] = supp[idx[i]];
1968 tgts[l++] = tgf(arity, v);
1969 /* advance the multi-index, partially unrolled */
1970 __advance_multi_index(idx, arity, slen);
1978 __dress_result(Lisp_Object rtype, Lisp_Object arr[], size_t len)
1980 /* from most likely to least likely */
1981 if (EQ(rtype, Qlist)) {
1982 return __Flist(len, arr);
1983 } else if (EQ(rtype, Qvector)) {
1984 return Fvector(len, arr);
1985 } else if (EQ(rtype, Qdllist)) {
1986 return Fdllist(len, arr);
1987 } else if (EQ(rtype, Qlitter) || EQ(rtype, Qvoid)) {
1989 } else if (EQ(rtype, Qinplace)) {
1991 } else if (EQ(rtype, Qstring)) {
1992 return Fstring(len, arr);
1993 } else if (EQ(rtype, Qbit_vector)) {
1994 return Fbit_vector(len, arr);
1995 } else if (EQ(rtype, Qconcat)) {
1996 return Fconcat(len, arr);
2001 static inline size_t
2002 __explode_1dict(Lisp_Object *restrict tkeys, Lisp_Object *restrict tvals,
2003 Lisp_Object dict, size_t len)
2004 __attribute__((always_inline));
2005 static inline size_t
2006 __explode_1dict(Lisp_Object *restrict tkeys, Lisp_Object *restrict tvals,
2007 Lisp_Object dict, size_t len)
2010 dict_t d = (dict_t)(void*)dict;
2011 struct dict_iter_s _di, *di = &_di;
2013 dict_iter_init(d, di);
2016 Lisp_Object key, val;
2017 dict_iter_next(di, &key, &val);
2018 if (LIKELY(key != Qnull_pointer)) {
2032 __comb_1seq(Lisp_Object seq, Lisp_Object fun, size_t arity,
2033 glue_f gluef, Lisp_Object result_type)
2035 size_t fs = __fam_size(seq);
2036 size_t nc = __ncombinations(fs, arity != -1UL ? arity : (arity = fs));
2037 /* C99 we need you */
2038 size_t maxsz = __sys_stk_free() / sizeof(Lisp_Object);
2040 /* leave room for stuff after us,
2041 * we call a function on this, so leave plenty of space */
2043 ? nc + fs /* actually we just need nc + arity - 1 */
2045 Lisp_Object __vals[leni], *vals, *rvals, result;
2047 struct gcpro gcpro1;
2049 if (UNLIKELY(arity == 0 || nc == 0)) {
2051 return __dress_result(result_type, NULL, 0);
2054 if (UNLIKELY(leni == 0)) {
2055 speccnt = specpdl_depth();
2056 vals = xnew_array(Lisp_Object, nc + fs);
2057 record_unwind_protect(free_malloced_ptr, make_opaque_ptr(vals));
2062 /* explode the sequence */
2063 memset(vals, 0, nc * sizeof(Lisp_Object));
2064 (void)seq_explode((void*restrict*)&vals[nc], fs, (seq_t)seq);
2066 GCPROn(vals, nc+fs);
2069 /* the same as pntw mode */
2071 if (UNLIKELY(NILP(fun) || nc == 0UL)) {
2076 for (size_t i = nc; i < nc + fs; i++) {
2077 Lisp_Object args[2] = {fun, vals[i]};
2078 vals[i] = Ffuncall(2, args);
2083 __2comb(vals, nc, &vals[nc], fs, fun, gluef);
2087 __3comb(vals, nc, &vals[nc], fs, fun, gluef);
2091 __ncomb(vals, nc, &vals[nc], fs, fun, gluef, arity);
2095 result = __dress_result(result_type, rvals, nc);
2097 if (UNLIKELY(leni == 0)) {
2098 unbind_to(speccnt, Qnil);
2104 __perm_1seq(Lisp_Object seq, Lisp_Object fun, size_t arity,
2105 glue_f gluef, Lisp_Object result_type)
2107 size_t fs = __fam_size(seq);
2108 size_t nv = __nvariations(fs, arity != -1UL ? arity : (arity = fs));
2109 /* C99 we need you */
2110 size_t maxsz = __sys_stk_free() / sizeof(Lisp_Object);
2112 /* leave room for stuff after us,
2113 * we call a function on this, so leave plenty of space */
2117 Lisp_Object __vals[leni], *vals, *rvals = NULL, result;
2119 struct gcpro gcpro1;
2121 if (UNLIKELY(leni == 0)) {
2122 speccnt = specpdl_depth();
2123 vals = xnew_array(Lisp_Object, nv + fs);
2124 record_unwind_protect(free_malloced_ptr, make_opaque_ptr(vals));
2129 if (UNLIKELY(arity == 0)) {
2131 return __dress_result(result_type, NULL, 0);
2134 /* explode the sequence */
2135 memset(vals, 0, (nv) * sizeof(Lisp_Object));
2136 (void)seq_explode((void*restrict*)&vals[nv], fs, (seq_t)seq);
2138 GCPROn(vals, nv + fs);
2141 /* the same as pntw mode */
2143 if (UNLIKELY(NILP(fun) || nv == 0UL)) {
2148 for (size_t i = nv; i < nv+fs; i++) {
2149 Lisp_Object args[2] = {fun, vals[i]};
2150 vals[i] = Ffuncall(2, args);
2155 _comb_2perm(vals, nv, &vals[nv], fs, fun, gluef);
2159 _comb_3perm(vals, nv, &vals[nv], fs, fun, gluef);
2163 if (LIKELY(fs != arity)) {
2164 _comb_Sn(vals, nv, &vals[nv], fs, fun, gluef, arity);
2166 /* optimised for mere permutations */
2167 _Sn(vals, nv, &vals[nv], fs /*== arity*/, fun, gluef);
2172 result = __dress_result(result_type, rvals, nv);
2174 if (UNLIKELY(leni == 0)) {
2175 unbind_to(speccnt, Qnil);
2181 __cart_1seq(Lisp_Object seq, Lisp_Object fun, size_t arity,
2182 glue_f gluef, Lisp_Object result_type)
2184 size_t fs = __fam_size(seq);
2185 size_t nc = __ncart(fs, arity);
2186 /* C99 we need you */
2187 size_t maxsz = __sys_stk_free() / sizeof(Lisp_Object);
2189 /* leave room for stuff after us,
2190 * we call a function on this, so leave plenty of space */
2194 Lisp_Object __vals[leni], *vals, result;
2196 struct gcpro gcpro1;
2198 if (UNLIKELY(arity == 0)) {
2200 return __dress_result(result_type, NULL, 0);
2203 if (UNLIKELY(leni == 0)) {
2204 speccnt = specpdl_depth();
2205 vals = xnew_array(Lisp_Object, nc);
2206 record_unwind_protect(free_malloced_ptr, make_opaque_ptr(vals));
2211 /* explode the sequence */
2212 memset(vals, 0, (nc - fs) * sizeof(Lisp_Object));
2213 seq_explode((void*restrict*)&vals[nc - fs], fs, (seq_t)seq);
2218 /* the same as pntw mode */
2220 if (UNLIKELY(NILP(fun) || nc == 0UL)) {
2224 for (size_t i = 0; i < nc; i++) {
2225 Lisp_Object args[2] = {fun, vals[i]};
2226 vals[i] = Ffuncall(2, args);
2230 _2cart(vals, nc, &vals[nc-fs], fs, fun, gluef);
2233 _3cart(vals, nc, &vals[nc-fs], fs, fun, gluef);
2236 _ncart(vals, nc, &vals[nc-fs], fs, fun, gluef, arity);
2239 result = __dress_result(result_type, vals, nc);
2241 if (UNLIKELY(leni == 0)) {
2242 unbind_to(speccnt, Qnil);
2248 __pntw_1seq(Lisp_Object seq, Lisp_Object fun, size_t arity,
2249 glue_f gluef, Lisp_Object result_type,
2250 volatile struct decoration_s *deco)
2252 size_t nseq = __fam_size(seq);
2253 /* C99 we need you */
2254 size_t maxsz = __sys_stk_free() / sizeof(Lisp_Object);
2255 size_t totlen = nseq + 2 /* for ini and ter */ +
2256 (deco_sep(deco) ? nseq : 0);
2258 /* leave room for stuff after us,
2259 * we call a function on this, so leave plenty of space */
2264 Lisp_Object __vals[leni+1], *vals, *seqelts, result;
2267 /* expherts alarm */
2268 return __dress_result(result_type, NULL, 0);
2270 if (UNLIKELY(leni == 0)) {
2271 vals = xnew_array(Lisp_Object, totlen);
2276 /* start maybe with the initiator */
2277 if (UNLIKELY(deco_ini(deco) != Qnull_pointer)) {
2278 vals[len++] = deco_ini(deco);
2280 /* explode the sequence */
2281 if (LIKELY(deco_sep(deco) == Qnull_pointer)) {
2282 seqelts = &vals[len];
2284 seqelts = vals + (deco_sep(deco) ? nseq : 0);
2285 memset(&vals[len], 0, sizeof(Lisp_Object) * nseq);
2287 (void)seq_explode((void*restrict*)seqelts, nseq, (seq_t)seq);
2289 /* fill the rest with naughts */
2290 memset(&seqelts[nseq], 0, (totlen - len - nseq) * sizeof(Lisp_Object));
2293 struct gcpro gcpro1;
2295 if (UNLIKELY(NILP(fun))) {
2296 if (LIKELY(deco_sep(deco) != Qnull_pointer)) {
2298 for (size_t i = 0; i < nseq; i++) {
2299 vals[len++] = seqelts[i];
2300 vals[len++] = deco_sep(deco);
2302 /* because we dont want the last element to
2303 * be followed by a separator */
2311 GCPROn(vals, totlen);
2313 for (size_t i = 0; i < nseq; i++) {
2314 Lisp_Object args[2] = {fun, seqelts[i]};
2315 vals[len++] = Ffuncall(2, args);
2316 if (UNLIKELY(deco_sep(deco) != Qnull_pointer)) {
2317 vals[len++] = deco_sep(deco);
2320 if (UNLIKELY(deco_sep(deco) != Qnull_pointer)) {
2321 /* strike the last separator */
2329 if (UNLIKELY(NILP(fun))) {
2330 /* condense the stuff */
2331 for (size_t i = 0, bar = nseq & -2;
2332 /* traverse to the previous even number */
2335 ? gluef(2, &seqelts[i])
2336 : list2(seqelts[i], seqelts[i+1]);
2337 if (UNLIKELY(deco_sep(deco) != Qnull_pointer)) {
2338 vals[len++] = deco_sep(deco);
2341 if (UNLIKELY(deco_sep(deco) != Qnull_pointer)) {
2342 /* strike the last separator */
2348 GCPROn(vals, totlen);
2350 for (size_t i = 0, bar = nseq & -2;
2351 /* traverse to the last even index */
2353 Lisp_Object args[3] = {fun, seqelts[i], seqelts[i+1]};
2354 vals[len++] = Ffuncall(countof(args), args);
2355 if (UNLIKELY(deco_sep(deco) != Qnull_pointer)) {
2356 vals[len++] = deco_sep(deco);
2359 if (UNLIKELY(deco_sep(deco) != Qnull_pointer)) {
2360 /* strike the last separator */
2368 if (UNLIKELY(NILP(fun))) {
2369 /* condense the stuff */
2371 /* traverse to the last 3-divisible index */
2372 i+3 <= nseq; i += 3) {
2374 ? gluef(3, &seqelts[i])
2378 if (UNLIKELY(deco_sep(deco) != Qnull_pointer)) {
2379 vals[len++] = deco_sep(deco);
2382 if (UNLIKELY(deco_sep(deco) != Qnull_pointer)) {
2383 /* strike the last separator */
2392 /* traverse to the last 3-divisible index */
2393 i+3 <= nseq; i += 3) {
2394 Lisp_Object args[4] = {
2395 fun, seqelts[i], seqelts[i+1], seqelts[i+2]};
2396 vals[len++] = Ffuncall(countof(args), args);
2397 if (UNLIKELY(deco_sep(deco) != Qnull_pointer)) {
2398 vals[len++] = deco_sep(deco);
2401 if (UNLIKELY(deco_sep(deco) != Qnull_pointer)) {
2402 /* strike the last separator */
2410 if (UNLIKELY(NILP(fun))) {
2411 /* condense the stuff */
2413 /* traverse to the last sane index */
2414 i+arity <= nseq; i += arity) {
2416 ? gluef(arity, &seqelts[i])
2417 : Flist(arity, &seqelts[i]);
2418 if (UNLIKELY(deco_sep(deco) != Qnull_pointer)) {
2419 vals[len++] = deco_sep(deco);
2422 if (UNLIKELY(deco_sep(deco) != Qnull_pointer)) {
2423 /* kick the last one */
2432 /* traverse to the last 3-divisible index */
2433 i+arity <= nseq; i += arity) {
2434 Lisp_Object args[arity+1];
2437 args[1] = seqelts[i];
2438 args[2] = seqelts[i+1];
2439 args[3] = seqelts[i+2];
2440 args[4] = seqelts[i+3];
2441 for (size_t j = 4; j < arity; j++) {
2442 args[j+1] = seqelts[i+j];
2444 vals[len++] = Ffuncall(countof(args), args);
2445 if (UNLIKELY(deco_sep(deco) != Qnull_pointer)) {
2447 vals[len++] = deco_sep(deco);
2450 if (UNLIKELY(deco_sep(deco) != Qnull_pointer)) {
2451 /* kick the last one */
2458 /* top off with the terminator */
2459 if (UNLIKELY(deco_ter(deco) != Qnull_pointer)) {
2460 vals[len++] = deco_ter(deco);
2463 result = __dress_result(result_type, vals, len);
2464 if (UNLIKELY(leni == 0)) {
2471 __pntw_1dict(Lisp_Object dict, Lisp_Object fun,
2472 glue_f gluef, Lisp_Object result_type)
2474 /* basically like maphash/mapskiplist */
2475 size_t ndict = dict_size((dict_t)(void*)dict);
2476 /* C99 we need you */
2477 size_t maxsz = __sys_stk_free() / sizeof(Lisp_Object);
2479 /* leave room for stuff after us,
2480 * we call a function on this, so leave plenty of space */
2485 Lisp_Object __keys[leni], __vals[leni], *keys, *vals, result;
2487 if (UNLIKELY(leni == 0)) {
2488 keys = xnew_array(Lisp_Object, 2 * ndict);
2489 vals = &keys[ndict];
2495 /* explode the sequence */
2496 len = __explode_1dict(keys, vals, dict, ndict);
2498 if (LIKELY(!NILP(fun) && len > 0UL)) {
2499 struct gcpro gcpro1, gcpro2;
2501 GCPRO1n(dict, vals, len);
2503 for (size_t i = 0; i < len; i++) {
2504 Lisp_Object args[3] = {fun, keys[i], vals[i]};
2505 vals[i] = Ffuncall(countof(args), args);
2510 for (size_t i = 0; i < len; i++) {
2511 Lisp_Object args[2] = {keys[i], vals[i]};
2513 ? gluef(countof(args), args)
2514 : Flist(countof(args), args);
2518 result = __dress_result(result_type, vals, len);
2519 if (UNLIKELY(leni == 0)) {
2526 __pntw_nseq(Lisp_Object seqs[], size_t nseqs, Lisp_Object fun,
2527 glue_f gluef, Lisp_Object result_type)
2529 /* defaults to arity 1,1,...,1 */
2530 size_t nmin = __nfam_min_size(seqs, nseqs);
2531 /* C99 we need you */
2532 struct seq_iter_s its[nseqs];
2533 size_t maxsz = __sys_stk_free() / sizeof(Lisp_Object);
2535 /* leave room for stuff after us,
2536 * we call a function on this, so leave plenty of space */
2540 Lisp_Object __vals[leni], *vals, result;
2541 struct gcpro gcpro1, gcpro2, gcpro3;
2543 if (UNLIKELY(leni == 0)) {
2544 vals = xnew_array(Lisp_Object, nmin);
2549 /* initialise the value space */
2550 memset(vals, 0, nmin * sizeof(Lisp_Object));
2551 /* initialise the iterators */
2552 for (size_t i = 0; i < nseqs; i++) {
2553 seq_iter_init((seq_t)seqs[i], &its[i]);
2556 GCPRO1nn(fun, vals, nmin, seqs, nseqs);
2557 if (UNLIKELY(NILP(fun))) {
2558 for (size_t i = 0; i < nmin; i++) {
2559 Lisp_Object args[nseqs];
2562 seq_iter_next(&its[0], (void**)&args[0]);
2564 seq_iter_next(&its[1], (void**)&args[1]);
2565 /* ... and the rest */
2566 for (size_t j = 2; j < nseqs; j++) {
2567 seq_iter_next(&its[j], (void**)&args[j]);
2570 ? gluef(countof(args), args)
2571 : Flist(countof(args), args);
2574 for (size_t i = 0; i < nmin; i++) {
2575 Lisp_Object args[nseqs+1];
2578 seq_iter_next(&its[0], (void**)&args[1]);
2580 seq_iter_next(&its[1], (void**)&args[2]);
2581 /* ... and the rest */
2582 for (size_t j = 2; j < nseqs; j++) {
2583 seq_iter_next(&its[j], (void**)&args[j+1]);
2586 vals[i] = Ffuncall(countof(args), args);
2591 /* deinitialise the iterators */
2592 for (size_t i = 0; i < nseqs; i++) {
2593 seq_iter_fini(&its[i]);
2596 result = __dress_result(result_type, vals, nmin);
2597 if (UNLIKELY(leni == 0)) {
2603 static inline size_t
2604 __arity_cross_sum(size_t arity[], size_t narity)
2606 size_t res = arity[0];
2607 for (size_t j = 1; j < narity; j++) {
2614 __explode_n(seq_iter_t si, void *tgt[], size_t n)
2616 /* explodes the sequence in SI N times, puts the stuff into tgt,
2617 * consequently tgt[] is N elements richer thereafter */
2619 seq_iter_next(si, &tgt[0]);
2620 for (size_t j = 1; j < n; j++) {
2621 seq_iter_next(si, &tgt[j]);
2627 __pntw_nseq2(Lisp_Object seqs[], size_t nseqs, Lisp_Object fun,
2628 glue_f gluef, Lisp_Object result_type, size_t arity[])
2630 size_t nmin = __nfam_min_size_a(seqs, nseqs, arity);
2631 /* C99 we need you */
2632 struct seq_iter_s its[nseqs];
2633 size_t aXsum = __arity_cross_sum(arity, nseqs);
2634 size_t maxsz = __sys_stk_free() / sizeof(Lisp_Object);
2636 /* leave room for stuff after us,
2637 * we call a function on this, so leave plenty of space */
2641 Lisp_Object __vals[leni], *vals, result;
2642 struct gcpro gcpro1, gcpro2, gcpro3;
2644 if (UNLIKELY(leni == 0)) {
2645 vals = xnew_array(Lisp_Object, nmin);
2650 /* initialise the value space */
2651 memset(vals, 0, nmin * sizeof(Lisp_Object));
2652 /* initialise the iterators */
2653 for (size_t i = 0; i < nseqs; i++) {
2654 seq_iter_init((seq_t)seqs[i], &its[i]);
2657 GCPRO1nn(fun, vals, nmin, seqs, nseqs);
2658 if (UNLIKELY(NILP(fun))) {
2659 for (size_t i = 0; i < nmin; i++) {
2660 Lisp_Object args[aXsum];
2663 /* partially unroll this, as we know that it's
2664 * definitely one seq to consider */
2665 __explode_n(&its[0], (void**)&args[0], off = arity[0]);
2666 /* ... actually we know it's even more than one
2667 * seq otherwise we'd be in the 1seq counterpart
2669 __explode_n(&its[1], (void**)&args[off], arity[1]);
2670 for (j = 2, off += arity[1];
2671 j < nseqs; off += arity[j++]) {
2673 &its[j], (void**)&args[off], arity[j]);
2676 ? gluef(countof(args), args)
2677 : Flist(countof(args), args);
2680 for (size_t i = 0; i < nmin; i++) {
2681 Lisp_Object args[aXsum+1];
2684 /* partially unroll this, as we know that it's
2685 * definitely one seq to consider */
2686 __explode_n(&its[0], (void**)&args[1], off = arity[0]);
2687 /* ... actually we know it's even more than one
2688 * seq otherwise we'd be in the 1seq counterpart
2690 __explode_n(&its[1], (void**)&args[++off], arity[1]);
2691 for (j = 2, off += arity[1];
2692 j < nseqs; off += arity[j++]) {
2694 &its[j], (void**)&args[off], arity[j]);
2697 vals[i] = Ffuncall(countof(args), args);
2702 /* deinitialise the iterators */
2703 for (size_t i = 0; i < nseqs; i++) {
2704 seq_iter_fini(&its[i]);
2707 result = __dress_result(result_type, vals, nmin);
2708 if (UNLIKELY(leni == 0)) {
2715 __cart_nseq(Lisp_Object seqs[], size_t nseqs, Lisp_Object fun, size_t arity,
2716 glue_f gf, Lisp_Object result_type)
2718 /* defaults to arity 1,1,...,1
2719 * there is no __comb_nseq() as combinations are defined to be
2720 * (cart (comb s1) (comb s2) ...), so in the arity 1,1,...,1 case this
2721 * equals __cart_nseq() */
2722 size_t nseqsz[nseqs];
2723 size_t nsum, ncart, l = 0;
2724 size_t nsz = __nfam_cart_sum_size(&nsum, &ncart, nseqsz, seqs, nseqs);
2725 /* C99 we need you */
2726 Lisp_Object *expls[nseqs];
2727 long int idx[nseqs]; /* the multi index */
2728 Lisp_Object fc[nseqs+1], *v = &fc[1];
2729 size_t maxsz = __sys_stk_free() / sizeof(Lisp_Object);
2731 /* leave room for stuff after us,
2732 * we call a function on this, so leave plenty of space */
2736 Lisp_Object __vals[leni], *vals, result;
2737 struct gcpro gcpro1, gcpro2, gcpro3;
2739 /* catch some horst cases */
2741 return __dress_result(result_type, NULL, 0);
2742 } /* actually now we ought to catch the case ncart == nsum
2743 * which is nseqs == 1 */
2745 if (UNLIKELY(leni == 0)) {
2746 vals = xnew_array(Lisp_Object, nsz);
2751 /* initialise the value space */
2752 memset(vals, 0, nsz * sizeof(Lisp_Object));
2753 /* initialise the explosion pointers */
2754 expls[0] = &vals[ncart];
2755 seq_explode((void**)expls[0], nseqsz[0], (seq_t)seqs[0]);
2756 expls[1] = expls[0] + nseqsz[0];
2757 seq_explode((void**)expls[1], nseqsz[1], (seq_t)seqs[1]);
2758 for (size_t i = 2; i < nseqs; i++) {
2759 expls[i] = expls[i-1] + nseqsz[i-1];
2760 seq_explode((void**)expls[i], nseqsz[i], (seq_t)seqs[i]);
2762 /* setup multiindex */
2763 memset(idx, 0, nseqs * sizeof(long int));
2766 GCPRO1nn(fun, vals, nsz, seqs, nseqs);
2767 if (LIKELY(!NILP(fun) && gf == NULL)) {
2769 /* fetch the data from the explosions, p-unrolled */
2770 v[0] = expls[0][idx[0]];
2771 v[1] = expls[1][idx[1]];
2772 for (size_t i = 2; i < nseqs; i++) {
2773 v[i] = expls[i][idx[i]];
2776 vals[l++] = Ffuncall(countof(fc), fc);
2777 /* advance the multi-index */
2778 __advance_multi_index_2(idx, countof(idx), nseqsz);
2780 } else if (LIKELY(!NILP(fun))) {
2782 /* fetch the data from the explosions, p-unrolled */
2783 v[0] = expls[0][idx[0]];
2784 v[1] = expls[1][idx[1]];
2785 for (size_t i = 2; i < nseqs; i++) {
2786 v[i] = expls[i][idx[i]];
2789 v[0] = gf(countof(idx), v);
2791 vals[l++] = Ffuncall(2, fc);
2792 /* advance the multi-index */
2793 __advance_multi_index_2(idx, countof(idx), nseqsz);
2796 glue_f tgf = gf ? gf : Flist;
2798 /* fetch the data from the explosions, p-unrolled */
2799 v[0] = expls[0][idx[0]];
2800 v[1] = expls[1][idx[1]];
2801 for (size_t i = 2; i < nseqs; i++) {
2802 v[i] = expls[i][idx[i]];
2805 vals[l++] = tgf(countof(idx), v);
2806 /* advance the multi-index */
2807 __advance_multi_index_2(idx, countof(idx), nseqsz);
2812 result = __dress_result(result_type, vals, ncart);
2813 if (UNLIKELY(leni == 0)) {
2820 __cart_nseq2(Lisp_Object seqs[], size_t nseqs, Lisp_Object fun,
2821 glue_f gf, Lisp_Object result_type, size_t arity[])
2823 size_t nseqsz[nseqs];
2824 size_t nsum, ncart, midxsz /* size of the multi index */, l = 0;
2825 size_t nsz = __nfam_cart_sum_size_a(
2826 &nsum, &ncart, &midxsz, nseqsz, seqs, nseqs, arity);
2827 /* C99 we need you */
2828 Lisp_Object *expls[nseqs];
2829 long int idx[midxsz]; /* the multi index */
2830 Lisp_Object fc[midxsz+1], *v = &fc[1];
2831 size_t maxsz = __sys_stk_free() / sizeof(Lisp_Object);
2833 /* leave room for stuff after us,
2834 * we call a function on this, so leave plenty of space */
2838 Lisp_Object __vals[leni], *vals, result;
2839 struct gcpro gcpro1, gcpro2, gcpro3;
2841 /* catch some horst cases */
2843 return __dress_result(result_type, NULL, 0);
2844 } /* actually now we ought to catch the case ncart == nsum
2845 * which is nseqs == 1 */
2847 if (UNLIKELY(leni == 0)) {
2848 vals = xnew_array(Lisp_Object, nsz);
2853 /* initialise the value space */
2854 memset(vals, 0, nsz * sizeof(Lisp_Object));
2855 /* initialise the explosion pointers */
2856 expls[0] = &vals[ncart];
2857 seq_explode((void**)expls[0], nseqsz[0], (seq_t)seqs[0]);
2858 expls[1] = expls[0] + nseqsz[0];
2859 seq_explode((void**)expls[1], nseqsz[1], (seq_t)seqs[1]);
2860 for (size_t i = 2; i < nseqs; i++) {
2861 expls[i] = expls[i-1] + nseqsz[i-1];
2862 seq_explode((void**)expls[i], nseqsz[i], (seq_t)seqs[i]);
2864 /* setup multiindex */
2865 memset(idx, 0, countof(idx) * sizeof(long int));
2868 GCPRO1nn(fun, vals, nsz, seqs, nseqs);
2869 if (LIKELY(!NILP(fun) && gf == NULL)) {
2872 /* fetch the data from the explosions, p-unrolled */
2873 v[0] = expls[0][idx[0]];
2874 for (slot = 1; slot < arity[0]; slot++) {
2875 /* offload arity[0] slots onto v */
2876 v[slot] = expls[0][idx[slot]];
2878 /* continue with the next arity[1] slots */
2879 v[slot] = expls[1][idx[slot]];
2881 for (size_t j = 1; j < arity[1]; slot++, j++) {
2882 v[slot] = expls[1][idx[slot]];
2884 /* now the rest of the crowd */
2885 for (size_t i = 2; i < nseqs; i++) {
2886 v[slot] = expls[i][idx[slot]];
2888 for (size_t j = 1; j < arity[i]; slot++, j++) {
2889 v[slot] = expls[i][idx[slot]];
2893 vals[l++] = Ffuncall(countof(fc), fc);
2894 /* advance the multi-index */
2895 __advance_multi_index_3(
2896 idx, countof(idx), nseqsz, nseqs, arity);
2898 } else if (LIKELY(!NILP(fun))) {
2901 /* fetch the data from the explosions, p-unrolled */
2902 v[0] = expls[0][idx[0]];
2903 for (slot = 1; slot < arity[0]; slot++) {
2904 /* offload arity[0] slots onto v */
2905 v[slot] = expls[0][idx[slot]];
2907 /* continue with the next arity[1] slots */
2908 v[slot] = expls[1][idx[slot]];
2910 for (size_t j = 1; j < arity[1]; slot++, j++) {
2911 v[slot] = expls[1][idx[slot]];
2913 /* now the rest of the crowd */
2914 for (size_t i = 2; i < nseqs; i++) {
2915 v[slot] = expls[i][idx[slot]];
2917 for (size_t j = 1; j < arity[i]; slot++, j++) {
2918 v[slot] = expls[i][idx[slot]];
2922 v[0] = gf(countof(idx), v);
2924 vals[l++] = Ffuncall(2, fc);
2925 /* advance the multi-index */
2926 __advance_multi_index_3(
2927 idx, countof(idx), nseqsz, nseqs, arity);
2930 glue_f tgf = gf ? gf : Flist;
2933 /* fetch the data from the explosions, p-unrolled */
2934 v[0] = expls[0][idx[0]];
2935 for (slot = 1; slot < arity[0]; slot++) {
2936 /* offload arity[0] slots onto v */
2937 v[slot] = expls[0][idx[slot]];
2939 /* continue with the next arity[1] slots */
2940 v[slot] = expls[1][idx[slot]];
2942 for (size_t j = 1; j < arity[1]; slot++, j++) {
2943 v[slot] = expls[1][idx[slot]];
2945 /* now the rest of the crowd */
2946 for (size_t i = 2; i < nseqs; i++) {
2947 v[slot] = expls[i][idx[slot]];
2949 for (size_t j = 1; j < arity[i]; slot++, j++) {
2950 v[slot] = expls[i][idx[slot]];
2954 vals[l++] = tgf(countof(idx), v);
2955 /* advance the multi-index */
2956 __advance_multi_index_3(
2957 idx, countof(idx), nseqsz, nseqs, arity);
2962 result = __dress_result(result_type, vals, ncart);
2963 if (UNLIKELY(leni == 0)) {
2970 __comb_nseq2(Lisp_Object seqs[], size_t nseqs, Lisp_Object fun,
2971 glue_f gf, Lisp_Object result_type, size_t arity[])
2973 /* this is the dodgiest one, since
2974 * comb(seq1, seq2, ..., seqn) => cart(comb(seq1), comb(seq2), ..., comb(seqn))
2976 size_t nseqsz[nseqs];
2977 size_t nsum, ncomb, midxsz /* size of the multi index */, l = 0;
2978 /* computes the size of the cartesian set, the maximum size of
2979 * the union set and the multiplicity of the multi-index (which is the
2980 * cross sum of the arity array) returns the sum of cartesian and union,
2981 * and puts intermediately computed family sizes into nseqsz[] */
2982 size_t nsz = __nfam_comb_sum_size_a(
2983 &nsum, &ncomb, &midxsz, nseqsz, seqs, nseqs, arity);
2984 /* C99 we need you */
2985 Lisp_Object *expls[nseqs];
2986 /* the multi indices, we have a big one, and a custom one */
2987 size_t __midx[midxsz], *midx[nseqs]; /* the multi indices */
2988 Lisp_Object fc[midxsz+1], *v = &fc[1];
2989 size_t maxsz = __sys_stk_free() / sizeof(Lisp_Object);
2991 /* leave room for stuff after us,
2992 * we call a function on this, so leave plenty of space */
2996 Lisp_Object __vals[leni], *vals, result;
2997 struct gcpro gcpro1, gcpro2, gcpro3;
2999 /* catch some horst cases */
3001 return __dress_result(result_type, NULL, 0);
3002 } /* actually now we ought to catch the case ncart == nsum
3003 * which is nseqs == 1 */
3005 if (UNLIKELY(leni == 0)) {
3006 vals = xnew_array(Lisp_Object, nsz);
3011 /* initialise the value space */
3012 memset(vals, 0, nsz * sizeof(Lisp_Object));
3013 /* initialise the explosion pointers and ... */
3014 expls[0] = &vals[ncomb];
3015 seq_explode((void**)expls[0], nseqsz[0], (seq_t)seqs[0]);
3016 expls[1] = expls[0] + nseqsz[0];
3017 seq_explode((void**)expls[1], nseqsz[1], (seq_t)seqs[1]);
3018 /* ... the multi-multi-index */
3019 midx[0] = &__midx[0];
3020 __initialise_multi_index(midx[0], arity[0]);
3021 midx[1] = &__midx[arity[0]];
3022 __initialise_multi_index(midx[1], arity[1]);
3023 /* and the rest of the explosion pointers, gosh, that's going
3024 * to be an Index War */
3025 for (size_t i = 2; i < nseqs; i++) {
3026 expls[i] = expls[i-1] + nseqsz[i-1];
3027 seq_explode((void**)expls[i], nseqsz[i], (seq_t)seqs[i]);
3028 midx[i] = &__midx[arity[i-1]];
3029 __initialise_multi_index(midx[i], arity[i]);
3034 GCPRO1nn(fun, vals, nsz, seqs, nseqs);
3035 if (LIKELY(!NILP(fun) && gf == NULL)) {
3038 /* fetch the data from the explosions, p-unrolled */
3039 v[0] = expls[0][__midx[0]];
3040 for (slot = 1; slot < arity[0]; slot++) {
3041 /* offload arity[0] slots onto v */
3042 v[slot] = expls[0][__midx[slot]];
3044 /* continue with the next arity[1] slots */
3045 v[slot] = expls[1][__midx[slot]];
3047 for (size_t j = 1; j < arity[1]; slot++, j++) {
3048 v[slot] = expls[1][__midx[slot]];
3050 /* now the rest of the crowd */
3051 for (size_t i = 2; i < nseqs; i++) {
3052 v[slot] = expls[i][__midx[slot]];
3054 for (size_t j = 1; j < arity[i]; slot++, j++) {
3055 v[slot] = expls[i][__midx[slot]];
3059 vals[l++] = Ffuncall(countof(fc), fc);
3060 /* advance the multi-index */
3061 __advance_multi_index_4(midx, nseqsz, nseqs, arity);
3063 } else if (LIKELY(!NILP(fun))) {
3066 /* fetch the data from the explosions, p-unrolled */
3067 v[0] = expls[0][__midx[0]];
3068 for (slot = 1; slot < arity[0]; slot++) {
3069 /* offload arity[0] slots onto v */
3070 v[slot] = expls[0][__midx[slot]];
3072 /* continue with the next arity[1] slots */
3073 v[slot] = expls[1][__midx[slot]];
3075 for (size_t j = 1; j < arity[1]; slot++, j++) {
3076 v[slot] = expls[1][__midx[slot]];
3078 /* now the rest of the crowd */
3079 for (size_t i = 2; i < nseqs; i++) {
3080 v[slot] = expls[i][__midx[slot]];
3082 for (size_t j = 1; j < arity[i]; slot++, j++) {
3083 v[slot] = expls[i][__midx[slot]];
3087 v[0] = gf(countof(__midx), v);
3089 vals[l++] = Ffuncall(2, fc);
3090 /* advance the multi-index */
3091 __advance_multi_index_4(midx, nseqsz, nseqs, arity);
3094 glue_f tgf = gf ? gf : Flist;
3099 /* fetch the data from the explosions, p-unrolled */
3100 v[0] = expls[0][__midx[0]];
3101 for (slot = 1; slot < arity[0]; slot++) {
3102 /* offload arity[0] slots onto v */
3103 v[slot] = expls[0][__midx[slot]];
3105 /* continue with the next arity[1] slots */
3106 v[slot] = expls[1][__midx[slot]];
3108 for (size_t j = 1; j < arity[1]; slot++, j++) {
3109 v[slot] = expls[1][__midx[slot]];
3111 /* now the rest of the crowd */
3112 for (size_t i = 2; i < nseqs; i++) {
3113 v[slot] = expls[i][__midx[slot]];
3115 for (size_t j = 1; j < arity[i]; slot++, j++) {
3116 v[slot] = expls[i][__midx[slot]];
3120 vals[l++] = tgf(countof(__midx), v);
3121 /* advance the multi-index */
3122 __advance_multi_index_4(midx, nseqsz, nseqs, arity);
3127 result = __dress_result(result_type, vals, ncomb);
3128 if (UNLIKELY(leni == 0)) {
3135 __perm_nseq(Lisp_Object seqs[], size_t nseqs, Lisp_Object fun, size_t arity,
3136 glue_f gf, Lisp_Object result_type)
3138 /* defaults to arity 1,1,...,1 */
3139 size_t nseqsz[nseqs];
3140 size_t ns, ncp, np, l = 0;
3141 size_t nsz = __nfam_perm_sum_size(&ns, &ncp, &np, nseqsz, seqs, nseqs);
3142 /* C99 we need you */
3143 Lisp_Object *expls[nseqs];
3144 long int idx[nseqs]; /* the multi index */
3145 Lisp_Object fc[nseqs+1], *v = &fc[1];
3146 size_t maxsz = __sys_stk_free() / sizeof(Lisp_Object);
3148 /* leave room for stuff after us,
3149 * we call a function on this, so leave plenty of space */
3153 Lisp_Object __vals[leni], *vals, result;
3154 struct gcpro gcpro1, gcpro2, gcpro3;
3156 /* catch some horst cases */
3158 return __dress_result(result_type, NULL, 0);
3159 } /* actually now we ought to catch the case nperm == nsum
3160 * which is nseqs == 1 */
3162 if (UNLIKELY(leni == 0)) {
3163 vals = xnew_array(Lisp_Object, nsz);
3168 /* initialise the value space */
3169 memset(vals, 0, nsz * sizeof(Lisp_Object));
3170 /* initialise the explosion pointers */
3171 expls[0] = &vals[ncp];
3172 seq_explode((void**)expls[0], nseqsz[0], (seq_t)seqs[0]);
3173 expls[1] = expls[0] + nseqsz[0];
3174 seq_explode((void**)expls[1], nseqsz[1], (seq_t)seqs[1]);
3175 for (size_t i = 2; i < nseqs; i++) {
3176 expls[i] = expls[i-1] + nseqsz[i-1];
3177 seq_explode((void**)expls[i], nseqsz[i], (seq_t)seqs[i]);
3179 /* setup multiindex */
3180 memset(idx, 0, nseqs * sizeof(long int));
3183 GCPRO1nn(fun, vals, nsz, seqs, nseqs);
3186 if (LIKELY(!NILP(fun) && gf == NULL)) {
3188 /* fetch the data from the explosions */
3189 v[0] = expls[0][idx[0]];
3190 v[1] = expls[1][idx[1]];
3191 l = __2perm_fun(vals, 2, v, 2, fun, l);
3192 /* advance the multi-index */
3193 __advance_multi_index_2(idx, 2, nseqsz);
3196 } else if (LIKELY(!NILP(fun))) {
3198 /* fetch the data from the explosions */
3199 v[0] = expls[0][idx[0]];
3200 v[1] = expls[1][idx[1]];
3201 l = __2perm_glue_fun(vals, 2, v, 2, fun, gf, l);
3202 /* advance the multi-index */
3203 __advance_multi_index_2(idx, 2, nseqsz);
3207 glue_f tgf = gf ? gf : Flist;
3209 /* fetch the data from the explosions */
3210 v[0] = expls[0][idx[0]];
3211 v[1] = expls[1][idx[1]];
3212 l = __2perm_glue(vals, 2, v, 2, tgf, l);
3213 /* advance the multi-index */
3214 __advance_multi_index_2(idx, 2, nseqsz);
3219 if (LIKELY(!NILP(fun) && gf == NULL)) {
3221 /* fetch the data from the explosions */
3222 v[0] = expls[0][idx[0]];
3223 v[1] = expls[1][idx[1]];
3224 v[2] = expls[2][idx[2]];
3225 l = __3perm_fun(vals, 0, v, 3, fun, l);
3226 /* advance the multi-index */
3227 __advance_multi_index_2(idx, 3, nseqsz);
3229 } else if (LIKELY(!NILP(fun))) {
3231 /* fetch the data from the explosions */
3232 v[0] = expls[0][idx[0]];
3233 v[1] = expls[1][idx[1]];
3234 v[2] = expls[2][idx[2]];
3235 l = __3perm_glue_fun(vals, 0, v, 3, fun, gf, l);
3236 /* advance the multi-index */
3237 __advance_multi_index_2(idx, 3, nseqsz);
3240 glue_f tgf = gf ? gf : Flist;
3242 /* fetch the data from the explosions */
3243 v[0] = expls[0][idx[0]];
3244 v[1] = expls[1][idx[1]];
3245 v[2] = expls[2][idx[2]];
3246 l = __3perm_glue(vals, 0, v, 3, tgf, l);
3247 /* advance the multi-index */
3248 __advance_multi_index_2(idx, 3, nseqsz);
3254 if (LIKELY(!NILP(fun) && gf == NULL)) {
3256 /* fetch the data from the explosions */
3257 v[0] = expls[0][idx[0]];
3258 v[1] = expls[1][idx[1]];
3259 for (size_t i = 2; i < nseqs; i++) {
3260 v[i] = expls[i][idx[i]];
3262 /* have Sn operating */
3263 l = __Sn_fun(vals, np, v, nseqs, fun, l);
3264 /* advance the multi-index */
3265 __advance_multi_index_2(idx, nseqs, nseqsz);
3267 } else if (LIKELY(!NILP(fun))) {
3269 /* fetch the data from the explosions */
3270 v[0] = expls[0][idx[0]];
3271 v[1] = expls[1][idx[1]];
3272 for (size_t i = 2; i < nseqs; i++) {
3273 v[i] = expls[i][idx[i]];
3275 /* have Sn operating */
3277 vals, np, v, nseqs, fun, gf, l);
3278 /* advance the multi-index */
3279 __advance_multi_index_2(idx, nseqs, nseqsz);
3282 glue_f tgf = gf ? gf : Flist;
3284 /* fetch the data from the explosions */
3285 v[0] = expls[0][idx[0]];
3286 v[1] = expls[1][idx[1]];
3287 for (size_t i = 2; i < nseqs; i++) {
3288 v[i] = expls[i][idx[i]];
3290 /* have Sn operating */
3291 l = __Sn_glue(vals, np, v, nseqs, tgf, l);
3292 /* advance the multi-index */
3293 __advance_multi_index_2(idx, nseqs, nseqsz);
3299 result = __dress_result(result_type, vals, ncp);
3300 if (UNLIKELY(leni == 0)) {
3307 __perm_nseq2(Lisp_Object seqs[], size_t nseqs, Lisp_Object fun,
3308 glue_f gf, Lisp_Object result_type, size_t arity[])
3310 /* this is the utmost dodgiest one, since
3311 * perm(seq1, seq2, ..., seqn) => perm(comb(seq1, seq2, ..., seqn))
3313 size_t nseqsz[nseqs];
3314 size_t nsum, nvar, nperm, midxsz /* size of the multi index */, l = 0;
3315 /* computes the size of the cartesian set, the maximum size of
3316 * the union set and the multiplicity of the multi-index (which is the
3317 * cross sum of the arity array) returns the sum of cartesian and union,
3318 * and puts intermediately computed family sizes into nseqsz[] */
3319 size_t nsz = __nfam_perm_sum_size_a(
3320 &nsum, &nvar, &nperm, &midxsz, nseqsz, seqs, nseqs, arity);
3321 /* C99 we need you */
3322 Lisp_Object *expls[nseqs];
3323 /* the multi indices, we have a big one, and a custom one */
3324 size_t __midx[midxsz], *midx[nseqs]; /* the multi indices */
3325 Lisp_Object v[midxsz + 2 /*to survive the aggressive loop unrolling*/];
3326 size_t maxsz = __sys_stk_free() / sizeof(Lisp_Object);
3328 /* leave room for stuff after us,
3329 * we call a function on this, so leave plenty of space */
3333 Lisp_Object __vals[leni], *vals, result;
3334 struct gcpro gcpro1, gcpro2, gcpro3;
3336 /* catch some horst cases */
3338 return __dress_result(result_type, NULL, 0);
3339 } /* actually now we ought to catch the case ncart == nsum
3340 * which is nseqs == 1 */
3342 if (UNLIKELY(leni == 0)) {
3343 vals = xnew_array(Lisp_Object, nsz);
3348 /* initialise the value space */
3349 memset(vals, 0, nsz * sizeof(Lisp_Object));
3350 /* initialise the explosion pointers and ... */
3351 expls[0] = &vals[nvar];
3352 seq_explode((void**)expls[0], nseqsz[0], (seq_t)seqs[0]);
3353 expls[1] = expls[0] + nseqsz[0];
3354 seq_explode((void**)expls[1], nseqsz[1], (seq_t)seqs[1]);
3355 /* ... the multi-multi-index */
3356 midx[0] = &__midx[0];
3357 __initialise_multi_index(midx[0], arity[0]);
3358 midx[1] = &__midx[arity[0]];
3359 __initialise_multi_index(midx[1], arity[1]);
3360 /* ... the multi-multi-index */
3361 midx[0] = &__midx[0];
3362 __initialise_multi_index(midx[0], arity[0]);
3363 /* and the rest of the explosion pointers, gosh, that's going
3364 * to be an Index War */
3365 for (size_t i = 2; i < nseqs; i++) {
3366 expls[i] = expls[i-1] + nseqsz[i-1];
3367 seq_explode((void**)expls[i], nseqsz[i], (seq_t)seqs[i]);
3368 midx[i] = &__midx[arity[i-1]];
3369 __initialise_multi_index(midx[i], arity[i]);
3372 GCPRO1nn(fun, vals, nsz, seqs, nseqs);
3373 /* actually we would have to distinguish between cross_sum(arity) >= 4
3374 * and == 3 and == 2, because the __Sn functions unroll at least 3
3375 * iterations, howbeit it seems to work so we stick with this for now */
3376 if (LIKELY(!NILP(fun) && gf == NULL)) {
3379 /* fetch the data from the explosions, p-unrolled */
3380 v[0] = expls[0][__midx[0]];
3381 for (slot = 1; slot < arity[0]; slot++) {
3382 /* offload arity[0] slots onto v */
3383 v[slot] = expls[0][__midx[slot]];
3385 /* continue with the next arity[1] slots */
3386 v[slot] = expls[1][__midx[slot]];
3388 for (size_t j = 1; j < arity[1]; slot++, j++) {
3389 v[slot] = expls[1][__midx[slot]];
3391 /* now the rest of the crowd */
3392 for (size_t i = 2; i < nseqs; i++) {
3393 v[slot] = expls[i][__midx[slot]];
3395 for (size_t j = 1; j < arity[i]; slot++, j++) {
3396 v[slot] = expls[i][__midx[slot]];
3399 /* do the rain dance */
3400 l = __Sn_fun(vals, nperm, v, midxsz, fun, l);
3401 /* advance the multi-index */
3402 __advance_multi_index_4(midx, nseqsz, nseqs, arity);
3404 } else if (LIKELY(!NILP(fun))) {
3407 /* fetch the data from the explosions, p-unrolled */
3408 v[0] = expls[0][__midx[0]];
3409 for (slot = 1; slot < arity[0]; slot++) {
3410 /* offload arity[0] slots onto v */
3411 v[slot] = expls[0][__midx[slot]];
3413 /* continue with the next arity[1] slots */
3414 v[slot] = expls[1][__midx[slot]];
3416 for (size_t j = 1; j < arity[1]; slot++, j++) {
3417 v[slot] = expls[1][__midx[slot]];
3419 /* now the rest of the crowd */
3420 for (size_t i = 2; i < nseqs; i++) {
3421 v[slot] = expls[i][__midx[slot]];
3423 for (size_t j = 1; j < arity[i]; slot++, j++) {
3424 v[slot] = expls[i][__midx[slot]];
3427 /* do the rain dance */
3428 l = __Sn_glue_fun(vals, nperm, v, midxsz, fun, gf, l);
3429 /* advance the multi-index */
3430 __advance_multi_index_4(midx, nseqsz, nseqs, arity);
3433 glue_f tgf = gf ? gf : Flist;
3438 /* fetch the data from the explosions, p-unrolled */
3439 v[0] = expls[0][__midx[0]];
3440 for (slot = 1; slot < arity[0]; slot++) {
3441 /* offload arity[0] slots onto v */
3442 v[slot] = expls[0][__midx[slot]];
3444 /* continue with the next arity[1] slots */
3445 v[slot] = expls[1][__midx[slot]];
3447 for (size_t j = 1; j < arity[1]; slot++, j++) {
3448 v[slot] = expls[1][__midx[slot]];
3450 /* now the rest of the crowd */
3451 for (size_t i = 2; i < nseqs; i++) {
3452 v[slot] = expls[i][__midx[slot]];
3454 for (size_t j = 1; j < arity[i]; slot++, j++) {
3455 v[slot] = expls[i][__midx[slot]];
3458 /* do the rain dance */
3459 l = __Sn_glue(vals, nperm, v, midxsz, tgf, l);
3460 /* advance the multi-index */
3461 __advance_multi_index_4(midx, nseqsz, nseqs, arity);
3466 result = __dress_result(result_type, vals, nvar);
3467 if (UNLIKELY(leni == 0)) {
3474 static inline glue_f
3475 _obtain_glue(Lisp_Object glue)
3476 __attribute__((always_inline));
3477 static inline glue_f
3478 _obtain_glue(Lisp_Object glue)
3480 if (EQ(glue, Qlist)) {
3482 } else if (EQ(glue, Qdllist)) {
3484 } else if (EQ(glue, Qvector)) {
3486 } else if (EQ(glue, Qstring)) {
3488 } else if (EQ(glue, Qconcat)) {
3496 _maybe_downgrade(Lisp_Object *arity)
3498 bool downgrade = !NILP(*arity) && CONSP(*arity);
3501 for (Lisp_Object tmp = *arity; CONSP(tmp); i++, tmp = XCDR(tmp)) {
3502 if (UNLIKELY(!NATNUMP(XCAR(tmp)) || XCAR(tmp) == Qzero)) {
3503 signal_simple_error(
3504 ":arity does not specify a valid multi-index",
3506 } else if (XCAR(tmp) != Qone) {
3510 if (LIKELY(i != 1 && !downgrade)) {
3512 } else if (UNLIKELY(i == 1)) {
3513 *arity = XCAR(*arity);
3515 } else if (UNLIKELY(downgrade)) {
3524 DEFUN("mapfam", Fmapfam, 1, MANY, 0, /*
3525 Apply FUNCTION to elements in FAMILIES and collect the results
3529 FUNCTION &rest FAMILIES &key :result-type :mode :arity :glue
3530 :initiator :separator :terminator
3532 The first argument FUNCTION is the function to use for the map.
3533 If FUNCTION is `nil' the function #\'identity or one of its glue
3534 counterparts (see :glue) is implicitly used. This can be used
3535 to convert one family to another, see examples below.
3537 The rest of the arguments are FAMILIES, where a family is a
3538 sequence \(see `sequencep'\) or a dict-like map (hash-table,
3539 skiplist, etc.). The family types need not coincide.
3541 Keys may be specified as in :key value [:key value [...]], all
3542 keys are optional and may appear anywhere. In greater detail:
3544 :result-type specifies the container type of the result object, can be:
3545 - #'list to yield a list (default)
3546 - #'dllist to yield a dllist
3547 - #'vector to yield a vector
3548 - #'string to yield a string iff FUNCTION returns characters or
3549 integers within the character range
3550 - #'concat to yield a string iff FUNCTION returns character arrays or
3551 arrays of integers within the character range
3552 - #'bit-vector to yield a bit-vector, FUNCTION's return values will
3553 be treated 1 iff non-nil, and 0 otherwise.
3554 - 'litter or 'void to not collect the results at all
3555 - 'inplace to modify the first family in FAMILIES by side-effect if
3556 it is a sequence, and modify the value destructively if it is a
3557 dict. This works only in pointwise mode, see :mode.
3559 Generally, the result-type is a functor (most often a constructor)
3560 to be applied on the produced output sequence. It behaves as if the
3561 elements of the output sequence had been passed to the constructor
3562 function argument-wise. So it can be thought of as a shortcut to
3563 \(apply #'<constructor> result-sequence\).
3565 In the past result types were specified by the name of the map
3566 function which turned out to be extremely sluggish in case the
3567 result type is parametrised (i.e. passed as parameter).
3569 :mode specifies the way the arguments are passed to FUNCTION, can be:
3570 - 'pointwise or 'pntw (default): given FAMILIES consists of
3571 fam1, fam2, etc. this mode passes the first point of fam1 along
3572 with the first point of fam2 along with etc. to FUNCTION. Hereby
3573 a point is just one element in case the family is a sequence, and
3574 a key-value pair (as two separate arguments) if family is a dict
3575 (and arity does not specify this otherwise).
3576 - 'keywise or 'keyw: like 'pointwise in case of sequences, for dicts
3577 this passes only the key cell to FUNCTION.
3578 - 'cartesian or 'cart: construct the cartesian product of the points
3579 in FAMILIES and pass the resulting tuples to FUNCTION.
3580 - 'combination or 'comb: construct the set of all combinations of
3581 the points, formally this is the set of (fixed-size) subsets of the
3582 set of points, disregarding different orders.
3583 Note: the implementation will always preserve orders though, that is
3584 the combinatorial subsets of an ordered family will be ordered wrt
3585 to the same overlying order.
3586 - 'permutation or 'perm or 'variation or 'var: construct the set of
3587 all permutations of the points (also known as variations), formally
3588 this is the set of (fixed-size) tuples arising from rearranging
3589 (different ordering) the subsets of the set of points.
3591 Note: The combinatorial modes (cart, comb and perm) produce giant
3592 amounts of data (using glues) or a neverending series of function
3593 calls. In case you are using one of the above modes and pass user
3594 input to #'mapfam or allow your users to specify their own mapping
3595 functions make sure you restrain the (size of the) input arguments.
3597 To give a rough idea of the outcome sizes:
3598 family size arity #combinations #permutations #cartesians
3605 9 7 36 181440 4782969
3606 9 8 9 362880 43046721
3607 9 9 1 362880 387420489
3609 For the number of combinations:
3610 (binomial-coefficient SIZE ARITY)
3611 For the number of permutations:
3612 (* (binomial-coeeficient SIZE ARITY) (factorial ARITY))
3613 For the number of points in the cartesian product:
3616 Additional note: SXEmacs' implementation of explicit symmetric group
3617 traversal (wrt a Bruhat-like order) is currently the fastest on the
3618 planet, however it obviously cannot overcome the sheer size of large
3619 symmetric groups. Be aware that explicit unrolling S_11 eats up at
3620 least 300 MB of RAM, unrolling S_12 requires at least 3.6 GB of RAM,
3621 for S_13 it's approx 48 GB and so on.
3623 Additional note: Cartesian products are highly exponential in space
3624 and time complexity. However, unlike permutations (symm. groups)
3625 the cartesian points can be constructed rather easily using nested
3626 loops. So if you are just after a couple of cartesian points do not
3627 bother using mapfam to create them all and filter afterwards but
3628 directly use nested loops to create the points you need.
3630 :arity specifies how to choose and pass points from the families to
3631 FUNCTION. The value of :arity can be a normal index (positive
3632 integer) if there is only one family, and a multi-index if points
3633 are to be picked from multiple families.
3636 - 1 if there is only one family which is not a dictionary and mode
3637 'pointwise or 'combination
3638 - 1 if there is only one family (including dictionaries) and mode is
3640 - 2 if there is only one family and mode is 'cartesian
3641 - the length of the family if there is only one family and mode is
3643 - (1 1) if family is a dictionary and mode is 'pointwise or
3645 - (1 1 ... 1) if there are n families, irrespective of mode.
3647 So it is '(1 1) if two families are given, '(1 1 1) for 3 families
3650 Indices, multi-indices and modes:
3651 The general multi-index form of the :arity keyword specifies how many
3652 points are taking from each family to form a glue cell which is passed
3653 directly to FUNCTION (exploded of course) if that is non-nil, and
3654 passed to the glue if that is nil.
3655 The first index in the arity multi-index list corresponds to the
3656 number of points to choose from the first family, the second one to
3657 the second family respectively and so on.
3658 An ordinary index always refers to the first family irrespective how
3659 many families have been specified.
3661 The exact meaning of this multi-index depends on the mode (see also
3663 - In pointwise or keywise mode, always pick this number of points
3664 or elements (consecutively), example:
3665 Let '(1 2 3 a b c) be the family and 1 its arity, the sequence of
3666 picks goes: 1, 2, 3, a, b, c.
3667 Let '(1 2 3 a b c) be the family and 2 its arity, the sequence of
3668 picks goes: [1 2], [3 a], [b c]
3669 If a cell is not formable because there are too few elements left in
3670 the family the mapping will not take place at all, so be '(1 2 3)
3671 the family and 2 its arity, the sequence of picks goes: [1 2].
3673 Multiple families in pointwise or keywise mode behave similarly
3674 Be '(1 2 3) '(a b c) two families and '(1 1) the arity (which is the
3675 default arity anyway), the pick then goes: [1 a] [2 b] [3 c], which
3676 is exactly how CL's #'map behaves in this situation.
3677 Be '(1 2 3) '(a b c one-more) two families and '(1 1) the arity,
3678 then the pick sequence again is: [1 a] [2 b] [3 c].
3679 In general the family with the least elements determines the number
3680 of picks in this mode.
3682 For arbitrary multi-indices the same rules hold, example:
3683 Let '(1 2 3) '(a b c one-more) be two families and '(1 2) its arity,
3684 then the pick sequence will be: [1 a b] [2 c one-more]
3686 - In cartesian mode, the arity, if an ordinary index, specifies the
3687 number of cartesian copies of the first given family, example:
3688 Let [a b c] be a sequence and arity be 2, then the mapping will
3690 [a a] [a b] [a c] [b a] [b b] [b c] [c a] [c b] [c c]
3692 If given a multi-index the cross sum denotes the total dimension of
3693 the yield while each index specifies the number of copies of the
3694 respective family, so fundamentally each cartesian mapping can be
3695 rewritten by a multi-index consisting solely of ones and
3696 correspondingly many copies of the input families, example:
3697 Let [a b c] and [1 2 3] be two families and '(1 1) the arity, then
3698 the cartesian mode will give:
3699 [a 1] [a 2] [a 3] [b 1] [b 2] [b 3] [c 1] [c 2] [c 3]
3700 Clearly the input sequence [a b c] of arity 2 can be rewritten as
3701 two input sequences [a b c] [a b c] and arity '(1 1) and will yield
3702 the sequence shown above.
3704 Let [a b] and [1 2] be two families and '(1 2) the arity, the result
3706 [a 1 1] [a 1 2] [a 2 1] [a 2 2] [b 1 1] [b 1 2] [b 2 1] [b 2 2]
3708 - In combination mode, the arity, if an ordinary index, specifies the
3709 combination size, example:
3710 Let \'(1 2 3 a) be the input sequence and 2 its arity, then the
3711 sequence of picks goes:
3712 [1 2] [1 3] [1 a] [2 3] [2 a] [3 a].
3714 A multi-index over several families specifies the subset sizes of
3715 each of the families. The total combination set is then formed by
3716 taking the cartesian product of these, example:
3717 Let [1 2 3] and [a b c] be two sets and '(2 2) the considered arity,
3718 then the first family yields [1 2] [1 3] [2 3] and the second one
3719 [a b] [a c] [b c], thence the final outcome will be:
3720 [1 2 a b] [1 2 a c] [1 2 b c] [1 3 a b] [1 3 a c] [1 3 b c] ...
3722 Again, the combination mode is strictly order-preserving, both
3723 the order of the families (as a sequence of families) and the order
3724 of each family will be preserved upon mapping.
3726 - In permuation mode, an ordinary index as arity will specify the
3727 cardinality, read size, of the combinatorial subset which will
3729 Note: the default arity for the permutation mode if just one
3730 sequence is given is the length of this sequence!
3733 Let \'(a b c) be a family and no arity be given, then the sequence
3735 [a b c] [a c b] [b a c] [b c a] [c a b] [c b a]
3736 Let "abcd" be a family and the arity be 2, then the pick sequence
3738 "ab" "ba" "ac" "ca" "ad" "da" "bc" "cb" "bd" "db" "cd" "dc"
3740 Note: while order 2 and order 3 permutations look carefully
3741 constructed and easily predictable this is not true for higher order
3742 permutations! They are specially designed to be mappable as fast as
3743 possible and seem to have no predictable pattern whatsoever, the
3744 order is based on a 1-orbit representation of the underlying
3745 symmetric group which needs merely one transposition to get from one
3746 orbit element to the next one; for details cf. source code.
3748 If given a multi-index
3749 Let "abc" and "123" be two families and arity (2 2), the pick
3751 (perms-of "ab12"), (perms-of "ab13"), (perms-of "ab23"),
3752 (perms-of "ac12"), (perms-of "ac13"), (perms-of "ac23")
3753 where #'perms-of denotes all permutations of that one give sequence,
3754 and can be implemented as (mapfam nil :mode \'perm <seq>)
3756 :glue when multiple values are to be passed to FUNCTION (or if FUNCTION
3757 is `nil' in particular) this specifies which (container) structure to
3758 use to glue them together.
3759 IOW, if FUNCTION is just a single-valued function but the family, the
3760 arity and/or the mode induce more than just one value, glue can turn
3761 so-called exploded form into a single value. Possible constructors:
3762 - #'list (default) to glue the arguments as lists
3763 - #'vector to glue the arguments as vectors
3764 - #'dllist to glue the arguments as dllists
3765 - #'string to glue the arguments as strings, iff they are characters
3766 - #'concat to glue the arguments as strings from character sequences
3768 In pointwise and keywise mode the result sequence can be decorated:
3770 :initiator insert this object at the beginning of the output sequence
3771 only works in 'pointwise and 'keywise mode
3773 :terminator insert this object at the end of the output sequence
3774 only works in 'pointwise and 'keywise mode
3776 :separator insert this object between each pair of elements of the
3777 output sequence. Use this to mimic a #'mapconcat-like behaviour,
3778 but this works for any sequence not just strings.
3779 only works in 'pointwise and 'keywise mode
3784 Normal mapcar-like behaviour:
3785 \(mapfam #'1+ '(1 2 3 4)\)
3787 \(mapfam #'1+ :result-type 'vector '(1 2 3 4)\)
3789 \(mapfam #'1- :result-type 'dllist [1 2 3 4]\)
3792 Normal mapcar*-like behaviour:
3793 \(mapfam #'+ (1 2 3 4) (10 20 30 40)\)
3795 \(mapfam #'+ [1 2 3 4] (dllist 10 20 30 40) :result-type 'vector\)
3798 Construct an alist from a plist:
3799 \(mapfam #'cons '(a 1 b 2 c 3) :arity 2\)
3800 => ((a . 1) (b . 2) (c . 3))
3801 \(mapfam #'list '(a 1 b 2 c 3) :arity 3 :result-type 'vector\)
3802 => [(a 1 b) (2 c 3)]
3803 \(mapfam nil '(a 1 b 2 c 3) :arity 2 :glue 'list\)
3804 => ((a 1) (b 2) (c 3))
3805 \(mapfam nil '(a 1 b 2 c 3) :arity 2 :glue 'vector :result-type 'dllist\)
3806 => (dllist [a 1] [b 2] [c 3])
3808 Apply cons to 2-sets (subsets of order 2) of a list:
3809 \(mapfam #'cons :mode 'comb :arity 2 '(a b c d)\)
3810 => ((a . b) (a . c) (a . d) (b . c) (b . d) (c . d))
3811 \(mapfam #'cons :mode 'comb :arity 2 '(a b a c)\)
3812 => ((a . b) (a . a) (a . c) (b . a) (b . c) (a . c))
3814 The same for 3-sets (using the automatic glue):
3815 \(mapfam nil :mode 'comb :arity 3 '(a b c d)\)
3816 => ((a b c) (a b d) (b c d))
3817 \(mapfam nil :mode 'comb :arity 3 '(a b c d) :glue 'vector\)
3818 => ([a b c] [a b d] [b c d])
3819 Note: This is exactly what `ncombs' is doing.
3821 Given a tuple of elements determine all combinations of three
3822 elements thereof (the 3-sets of the the tuple):
3823 \(mapfam nil :mode 'comb :arity 3 [a b c d]\)
3824 => ((a b c) (a b d) (a c d) (b c d))
3825 \(mapfam nil :mode 'comb :arity 3 [a b c d e] :glue #'vector\)
3826 => ([a b c] [a b d] [a b e] [a c d] [a c e] [a d e]
3827 [b c d] [b c e] [b d e] [c d e])
3829 Glueing the combinations of two different lists:
3830 \(mapfam nil :mode 'comb '(a b c) '(1 2)\)
3831 => ((a 1) (b 1) (c 1) (a 2) (b 2) (c 2))
3832 \(mapfam nil :mode 'comb '(a b c) '(1 2) :arity '(2 1)\)
3833 => ((a b 1) (a c 1) (b c 1) (a b 2) (a c 2) (b c 2))
3834 \(mapfam nil :mode 'comb '(a b c) '(1 2 3) :arity '(2 2)\)
3835 => ((a b 1 2) (a c 1 2) (b c 1 2)
3836 (a b 1 3) (a c 1 3) (b c 1 3)
3837 (a b 2 3) (a c 2 3) (b c 2 3))
3839 Applying the plus function immediately:
3840 \(mapfam #'+ :mode 'comb '(10 20 30) '(1 2)\)
3841 => (11 21 31 12 22 32)
3842 \(mapfam #'+ :mode 'comb '(10 20 30) '(1 2) :arity '(2 1)\)
3843 => (31 41 51 22 42 52)
3845 Mimicking #'mapconcat:
3846 \(mapconcat #'identity '("the" "inverse" "of" "#'split-string") " "\)
3847 => "the inverse of #'split-string"
3848 \(mapfam nil :separator " " '("the" "inverse" "of" "#'split-string")\)
3849 => ("the" " " "inverse" " " "of" " " "#'split-string")
3850 \(mapfam nil :separator " " :result-type #'concat
3851 '("the inverse of #'split-string")\)
3852 => "the inverse of #'split-string"
3854 Using cartesian mode and #'concat to emulate :separator
3855 \(mapfam #'concat :result-type #'concat :mode 'cartesian
3856 '\("the" "inverse" "of" "#'split-string"\) '(" ")\)
3857 => "the inverse of #'split-string "
3858 \(mapfam #'concat :result-type #'concat :mode 'cartesian
3859 [" "] '\("the" "inverse" "of" "#'split-string"\)\)
3860 => " the inverse of #'split-string"
3862 Note a separator is not exactly like doing cartesian mapping over
3863 two sequences since it affects only pairs of elements and so the
3864 last/first tuple is missing.
3865 However, pointwise mode is still use full if each pair of elements
3866 requires a `different separator'.
3868 \(mapfam #'concat :result-type #'concat :mode 'pointwise
3869 '\("the" "inverse" "of" "#'split-string"\) '(" " "_" "-" "."\)\)
3870 => "the inverse_of-#'split-string."
3873 (int nargs, Lisp_Object *args))
3875 /* this is just one, huuuuge case distinctor */
3876 Lisp_Object fun = Qnil;
3877 Lisp_Object mode = Qnil, arity = Qnil;
3878 Lisp_Object res_type = Qlist;
3879 volatile struct decoration_s deco = {
3880 Qnull_pointer, Qnull_pointer, Qnull_pointer
3882 int nfams = 0, arity_len;
3883 bool found_fun_p = false;
3884 glue_f gluef = NULL;
3886 /* snarf the function */
3887 if (!KEYWORDP(args[0])) {
3891 /* snarf the keys and families */
3892 for (int i = found_fun_p; i < nargs; i++) {
3893 if (EQ(args[i], Q_result_type)) {
3894 res_type = args[++i];
3895 } else if (EQ(args[i], Q_arity)) {
3897 } else if (EQ(args[i], Q_mode)) {
3899 } else if (EQ(args[i], Q_glue)) {
3900 gluef = _obtain_glue(args[++i]);
3901 } else if (EQ(args[i], Q_separator)) {
3902 deco.sep = args[++i];
3903 } else if (EQ(args[i], Q_initiator)) {
3904 deco.ini = args[++i];
3905 } else if (EQ(args[i], Q_terminator)) {
3906 deco.ter = args[++i];
3907 } else if (!found_fun_p) {
3908 /* we found the function cell */
3912 /* must be a family */
3913 args[nfams++] = args[i];
3917 /* check the integrity of the options */
3918 /* first kick the most idiotic situations */
3920 (NILP(fun) && EQ(mode, Qvoid)) ||
3922 /* looks like an exphert is here */
3923 return __dress_result(res_type, NULL, 0);
3925 /* now, fill in default values */
3929 /* degrade a thoroughly fledges '(1 1 ... 1) arity to nil */
3930 arity_len = _maybe_downgrade(&arity);
3932 #define POINTWISEP(mode) \
3933 (EQ(mode, Qpntw) || EQ(mode, Qpointwise) || EQ(mode, Qpoints))
3934 #define KEYWISEP(mode) \
3935 (EQ(mode, Qkeyw) || EQ(mode, Qkeywise) || EQ(mode, Qkeys))
3936 #define COMBINATIONP(mode) \
3937 (EQ(mode, Qcomb) || EQ(mode, Qcombination) || EQ(mode, Qcombinations))
3938 #define PERMUTATIONP(mode) \
3939 (EQ(mode, Qperm) || EQ(mode, Qpermutation) || EQ(mode, Qpermutations))
3940 #define CARTESIANP(mode) \
3941 (EQ(mode, Qcart) || EQ(mode, Qcartesian))
3943 if (POINTWISEP(mode) && nfams == 1 && NILP(arity) && !DICTP(args[0])) {
3944 /* the arity is not specified and it's just one sequence */
3945 return __pntw_1seq(args[0], fun, 1UL, gluef, res_type, &deco);
3947 } else if (POINTWISEP(mode) && NILP(arity) && !DICTP(args[0])) {
3948 /* the arity is not specified and it's more than one sequence */
3949 return __pntw_nseq(args, nfams, fun, gluef, res_type);
3951 } else if (KEYWISEP(mode) && nfams == 1 && NILP(arity)) {
3952 /* the arity is not specified and it's just one sequence,
3953 * also we dont have to care about dicts since
3954 * keywise is specified */
3955 return __pntw_1seq(args[0], fun, 1UL, gluef, res_type, &deco);
3957 } else if (KEYWISEP(mode) && NILP(arity)) {
3958 /* the arity is not specified and it's more than one sequence,
3959 * also we dont have to care about dicts since
3960 * keywise is specified */
3961 return __pntw_nseq(args, nfams, fun, gluef, res_type);
3963 } else if (POINTWISEP(mode) && (nfams == 1 && NILP(arity))) {
3964 /* the arity is not specified, it's one sequence, and it
3965 * must be a dict, since the non-dict case was check already */
3966 return __pntw_1dict(args[0], fun, gluef, res_type);
3968 } else if (NATNUMP(arity) && (POINTWISEP(mode) || KEYWISEP(mode))) {
3969 /* the arity is a natnum, so we consider just the
3970 * first sequence, in case of dicts this equals keywise
3972 return __pntw_1seq(args[0], fun, XUINT(arity),
3973 gluef, res_type, &deco);
3974 } else if (POINTWISEP(mode) || KEYWISEP(mode)) {
3975 /* the most general case */
3976 size_t a[arity_len];
3977 volatile Lisp_Object tmp;
3980 for (i = 0, tmp = arity;
3981 CONSP(tmp) && i < nfams && i < arity_len;
3982 i++, tmp = XCDR(tmp)) {
3983 a[i] = XUINT(XCAR(tmp));
3985 return __pntw_nseq2(args, i, fun, gluef, res_type, a);
3988 if (COMBINATIONP(mode) && NATNUMP(arity)) {
3989 /* the arity is a natnum, so it's just one sequence,
3990 * if not who cares :) */
3991 return __comb_1seq(args[0], fun, XUINT(arity),
3993 } else if (COMBINATIONP(mode) && (nfams == 1 && NILP(arity))) {
3994 /* the arity is a natnum, so it's just one sequence,
3995 * if not who cares :) */
3996 return __comb_1seq(args[0], fun, -1UL, gluef, res_type);
3998 } else if (COMBINATIONP(mode) && NILP(arity)) {
3999 /* the arity is not specified and it's more than one sequence */
4000 return __cart_nseq(args, nfams, fun, 1UL, gluef, res_type);
4002 } else if (COMBINATIONP(mode)) {
4003 /* the most general case */
4004 size_t a[arity_len];
4005 volatile Lisp_Object tmp;
4008 for (i = 0, tmp = arity;
4009 CONSP(tmp) && i < nfams && i < arity_len;
4010 i++, tmp = XCDR(tmp)) {
4011 a[i] = XUINT(XCAR(tmp));
4013 return __comb_nseq2(args, i, fun, gluef, res_type, a);
4016 if (CARTESIANP(mode) && NATNUMP(arity)) {
4017 /* the arity is a natnum, so it's just one sequence,
4018 * if not who cares :) */
4019 return __cart_1seq(args[0], fun, XUINT(arity),
4021 } else if (CARTESIANP(mode) &&
4022 (nfams == 1 && NILP(arity))) {
4023 /* it's one sequence and arity isnt specified, go with 2 then */
4024 return __cart_1seq(args[0], fun, 2UL, gluef, res_type);
4026 } else if (CARTESIANP(mode) && NILP(arity)) {
4027 /* the arity is not specified and it's more than one sequence */
4028 return __cart_nseq(args, nfams, fun, 1UL, gluef, res_type);
4030 } else if (CARTESIANP(mode)) {
4031 /* the most general case */
4032 size_t a[arity_len];
4033 volatile Lisp_Object tmp;
4036 for (i = 0, tmp = arity;
4037 CONSP(tmp) && i < nfams && i < arity_len;
4038 i++, tmp = XCDR(tmp)) {
4039 a[i] = XUINT(XCAR(tmp));
4041 return __cart_nseq2(args, i, fun, gluef, res_type, a);
4044 if (PERMUTATIONP(mode) && NATNUMP(arity)) {
4045 /* the arity is a natnum, so it's just one sequence,
4046 * if not who cares :) */
4047 return __perm_1seq(args[0], fun, XUINT(arity),
4049 } else if (PERMUTATIONP(mode) && (nfams == 1 && NILP(arity))) {
4050 /* the arity is a natnum, so it's just one sequence,
4051 * if not who cares :) */
4052 return __perm_1seq(args[0], fun, -1UL, gluef, res_type);
4054 } else if (PERMUTATIONP(mode) && NILP(arity)) {
4055 /* the arity is not specified and it's more than one sequence */
4056 return __perm_nseq(args, nfams, fun, 1UL, gluef, res_type);
4058 } else if (PERMUTATIONP(mode)) {
4059 /* the most general case */
4060 size_t a[arity_len];
4061 volatile Lisp_Object tmp;
4064 for (i = 0, tmp = arity;
4065 CONSP(tmp) && i < nfams && i < arity_len;
4066 i++, tmp = XCDR(tmp)) {
4067 a[i] = XUINT(XCAR(tmp));
4069 return __perm_nseq2(args, i, fun, gluef, res_type, a);
4074 DEFUN("mapconcat", Fmapconcat, 3, 3, 0, /*
4075 Apply FUNCTION to each element of SEQUENCE, and concat the results to a string.
4076 Between each pair of results, insert SEPARATOR.
4078 Each result, and SEPARATOR, should be strings. Thus, using " " as SEPARATOR
4079 results in spaces between the values returned by FUNCTION. SEQUENCE itself
4080 may be a list, a vector, a dllist, a bit vector, or a string.
4082 (function, sequence, separator))
4084 EMACS_INT len = XINT(Flength(sequence));
4088 EMACS_INT nargs = len + len - 1;
4089 int speccount = specpdl_depth();
4092 return build_string("");
4094 XMALLOC_OR_ALLOCA(args, nargs, Lisp_Object);
4096 mapcar1(len, args, function, sequence);
4098 for (i = len - 1; i >= 0; i--)
4099 args[i + i] = args[i];
4101 for (i = 1; i < nargs; i += 2)
4102 args[i] = separator;
4104 result = Fconcat(nargs, args);
4105 XMALLOC_UNBIND(args, nargs, speccount);
4109 DEFUN("mapcar", Fmapcar, 2, 2, 0, /*
4110 Apply FUNCTION to each element of SEQUENCE; return a list of the results.
4111 The result is a list of the same length as SEQUENCE.
4112 SEQUENCE may be a list, a vector, a dllist, a bit vector, or a string.
4114 (function, sequence))
4116 size_t len = XINT(Flength(sequence));
4117 Lisp_Object *args = NULL;
4119 int speccount = specpdl_depth();
4121 XMALLOC_OR_ALLOCA(args, len, Lisp_Object);
4123 mapcar1(len, args, function, sequence);
4125 result = Flist(len, args);
4126 XMALLOC_UNBIND(args, len, speccount);
4130 DEFUN("mapdllist", Fmapdllist, 2, 2, 0, /*
4131 Apply FUNCTION to each element of SEQUENCE; return a dllist of the results.
4132 The result is a list of the same length as SEQUENCE.
4133 SEQUENCE may be a list, a vector, a dllist, a bit vector, or a string.
4135 (function, sequence))
4137 size_t len = XINT(Flength(sequence));
4138 Lisp_Object *args = NULL;
4140 int speccount = specpdl_depth();
4142 XMALLOC_OR_ALLOCA(args, len, Lisp_Object);
4144 mapcar1(len, args, function, sequence);
4146 result = Fdllist(len, args);
4147 XMALLOC_UNBIND(args, len, speccount);
4151 DEFUN("mapvector", Fmapvector, 2, 2, 0, /*
4152 Apply FUNCTION to each element of SEQUENCE; return a vector of the results.
4153 The result is a vector of the same length as SEQUENCE.
4154 SEQUENCE may be a list, a vector, a dllist, a bit vector, or a string.
4156 (function, sequence))
4158 size_t len = XINT(Flength(sequence));
4159 Lisp_Object result = make_vector(len, Qnil);
4160 struct gcpro gcpro1;
4163 mapcar1(len, XVECTOR_DATA(result), function, sequence);
4169 DEFUN("mapc-internal", Fmapc_internal, 2, 2, 0, /*
4170 Apply FUNCTION to each element of SEQUENCE.
4171 SEQUENCE may be a list, a vector, a bit vector, or a string.
4172 This function is like `mapcar' but does not accumulate the results,
4173 which is more efficient if you do not use the results.
4175 The difference between this and `mapc' is that `mapc' supports all
4176 the spiffy Common Lisp arguments. You should normally use `mapc'.
4178 (function, sequence))
4180 mapcar1(XINT(Flength(sequence)), 0, function, sequence);
4185 DEFUN("mapc-inplace", Fmapc_inplace, 2, 2, 0, /*
4186 Apply FUNCTION to each element of SEQUENCE and replace the
4187 element with the result.
4188 Return the (destructively) modified sequence.
4190 At the moment, SEQUENCE can be a list, a dllist, a vector,
4191 a bit-vector, or a string.
4193 Containers with type restrictions -- strings or bit-vectors here --
4194 cannot handle all results of FUNCTION. In case of bit-vectors,
4195 if the function yields `nil' or 0 the current bit is set to 0,
4196 if the function yields anything else, the bit is set to 1.
4197 Similarly in the string case any non-char result of FUNCTION sets
4198 the currently processed character to ^@ (octal value: 000).
4200 (function, sequence))
4203 else if (LISTP(sequence))
4204 list_map_inplace(function, sequence);
4205 else if (DLLISTP(sequence))
4206 dllist_map_inplace(function, sequence);
4207 else if (STRINGP(sequence))
4208 string_map_inplace(function, sequence);
4209 else if (VECTORP(sequence))
4210 vector_map_inplace(function, sequence);
4211 else if (BIT_VECTORP(sequence))
4212 bit_vector_map_inplace(function, sequence);
4218 /* to be emodule compliant */
4226 DEFKEYWORD(Q_arity);
4227 DEFKEYWORD(Q_result_type);
4228 DEFKEYWORD(Q_initiator);
4229 DEFKEYWORD(Q_separator);
4230 DEFKEYWORD(Q_terminator);
4231 /* symbols for result and glue */
4232 DEFSYMBOL(Qinplace);
4238 DEFSYMBOL(Qbit_vector);
4243 DEFSYMBOL(Qpointwise);
4246 DEFSYMBOL(Qkeywise);
4249 DEFSYMBOL(Qcombination);
4250 DEFSYMBOL(Qcombinations);
4252 DEFSYMBOL(Qpermutation);
4253 DEFSYMBOL(Qpermutations);
4255 DEFSYMBOL(Qcartesian);
4258 /* special map*s, compatibility */
4260 DEFSUBR(Fmapdllist);
4261 DEFSUBR(Fmapvector);
4262 DEFSUBR(Fmapc_internal);
4263 DEFSUBR(Fmapconcat);
4264 DEFSUBR(Fmapc_inplace);
4268 /* map.c ends here */