3 * Copyright (C) 2007 Sebastian Freundt
5 * Author: Sebastian Freundt <hroptatyr@sxemacs.org>
7 * This file is part of SXEmacs.
9 * Redistribution and use in source and binary forms, with or without
10 * modification, are permitted provided that the following conditions
13 * 1. Redistributions of source code must retain the above copyright
14 * notice, this list of conditions and the following disclaimer.
16 * 2. Redistributions in binary form must reproduce the above copyright
17 * notice, this list of conditions and the following disclaimer in the
18 * documentation and/or other materials provided with the distribution.
20 * 3. Neither the name of the author nor the names of any contributors
21 * may be used to endorse or promote products derived from this
22 * software without specific prior written permission.
24 * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR
25 * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
26 * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
27 * DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
28 * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
29 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
30 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
31 * BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
32 * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
33 * OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
34 * IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
38 * All the code below is just a first (tacky) draught. It is optimised
39 * in a way, but still, the ardent worshippers of the DRY principle
40 * would tar and feather me for that.
44 /* Synched up with: Not in FSF, not in XE */
53 Lisp_Object Q_arity, Q_result_type, Q_mode, Q_glue;
54 Lisp_Object Q_separator, Q_initiator, Q_terminator;
55 Lisp_Object Qpntw, Qpointwise, Qpoints;
56 Lisp_Object Qkeyw, Qkeywise, Qkeys;
57 Lisp_Object Qcomb, Qcombination, Qcombinations;
58 Lisp_Object Qperm, Qpermutation, Qpermutations;
59 Lisp_Object Qcart, Qcartesian;
61 typedef Lisp_Object(*glue_f)(int nargs, Lisp_Object *args);
63 static Lisp_Object Qinplace, Qlitter, Qconcat;
64 static Lisp_Object Qvector, Qbit_vector;
67 EXFUN(Fbit_vector, MANY);
69 /* until this is available globally */
70 #define DICTP(x) (HASH_TABLEP(x) || SKIPLISTP(x))
73 Lisp_Object ini, ter, sep;
78 static inline Lisp_Object
79 __Flist(int nargs, Lisp_Object *args)
80 __attribute__((always_inline));
81 static inline Lisp_Object
82 __Flist(int nargs, Lisp_Object *args)
84 /* this is just Flist() but inlined */
85 Lisp_Object val = Qnil;
86 Lisp_Object *argp = args + nargs;
89 val = Fcons(*--argp, val);
93 static long unsigned int
94 __ncombinations(register long unsigned int n, long unsigned int k)
96 /* == binomial(n, k) */
97 if (UNLIKELY(n == k || k == 0)) {
99 } else if (UNLIKELY(k == 1 || n - k == 1)) {
101 } else if (k == 2 || n - k == 2) {
102 return (n * (n-1)) >> 1;
104 /* otherwise do the hard work */
105 long unsigned int num = n*(n-1)*(n-k+1), den = k*(k-1);
107 /* swap k if necessary */
112 for (n -= 2, k -= 2; k > 1;) {
120 static long unsigned int
121 __factorial(register long unsigned int n)
123 register long unsigned int r = n;
125 /* trivial cases first */
149 for (long unsigned int i = 9; i < n; i++) {
155 static long unsigned int
156 __nvariations(register long unsigned int n, long unsigned int k)
158 /* == binomial(n, k) * factorial(k) */
159 if (UNLIKELY(k == 0)) {
161 } else if (UNLIKELY(k == n)) {
162 return __factorial(k);
163 } else if (UNLIKELY(k == 1)) {
165 } else if (UNLIKELY(n - k == 1)) {
166 return __factorial(n);
170 return n * (n-1) * (n-2);
172 /* otherwise do the hard work */
173 long unsigned int num = n--;
185 static long unsigned int
186 __ncart(register long unsigned int n, long unsigned int k)
189 long unsigned int res;
204 for (res = n * n * n * n, k -= 4; k > 0; k--) {
212 __advance_multi_index()
213 __attribute__((always_inline));
215 __advance_multi_index(long int idx[], long int j, long int fam_len)
217 /* partially unroll */
218 if (LIKELY(++idx[--j] < fam_len)) {
222 if (LIKELY(++idx[--j] < fam_len)) {
226 if (LIKELY(++idx[--j] < fam_len)) {
231 if (LIKELY(++idx[--j] < fam_len)) {
240 __advance_multi_index_2()
241 __attribute__((always_inline));
243 __advance_multi_index_2(long int idx[], long int j, size_t flen[])
245 /* improved version of __a_m_v() which allows for differently-sized families */
246 /* partially unroll */
247 if (LIKELY((--j, ++idx[j] < (long int)flen[j]))) {
251 if (LIKELY((--j, ++idx[j] < (long int)flen[j]))) {
255 if (LIKELY((--j, ++idx[j] < (long int)flen[j]))) {
260 if (LIKELY((--j, ++idx[j] < (long int)flen[j]))) {
269 __advance_multi_index_3()
270 __attribute__((always_inline));
272 __advance_multi_index_3(
273 long int idx[], long int j, size_t flen[],
274 long int nseqs, size_t arity[])
276 /* improved version of __a_m_v_2() which allows for differently-sized families
277 * and multiplicities thereof
278 * this is for cartesian indexing, i.e. the order goes
279 * [1,0]->[1,1]->[1,2]->[2,0] for arity (., 3) */
280 long int mlt = arity[--nseqs];
282 if (LIKELY(++idx[--j] < (long int)flen[nseqs])) {
287 mlt = arity[--nseqs];
289 if (LIKELY(++idx[--j] < (long int)flen[nseqs])) {
294 mlt = arity[--nseqs];
296 if (LIKELY(++idx[--j] < (long int)flen[nseqs])) {
301 mlt = arity[--nseqs];
303 while (j > 0 && nseqs >= 0) {
304 if (LIKELY(++idx[--j] < (long int)flen[nseqs])) {
309 mlt = arity[--nseqs];
316 __initialise_multi_index()
317 __attribute__((always_inline));
319 __initialise_multi_index(size_t midx[], size_t arity)
322 for (size_t j = 1; j < arity; j++) {
329 __advance_multi_index_comb()
330 __attribute__((always_inline));
332 __advance_multi_index_comb(size_t idx[], size_t len, int arity)
336 for (i = arity-1; (i >= 0) && idx[i] >= len - arity + i; i--);
338 for (; ++i < arity; ) {
341 return (idx[i-1] < len);
345 __advance_multi_index_4()
346 __attribute__((always_inline));
348 __advance_multi_index_4(
349 size_t *midx[], size_t flen[], long int j /*nseqs*/, size_t arity[])
351 /* like __a_m_v_3(), also allowing for differently-sized families
352 * and multiplicities thereof, but for for combinatorial indexing,
353 * i.e. the order goes
354 * [1,2]->[1,3]->[2,3] for arity (., 3) */
356 if (LIKELY(__advance_multi_index_comb(midx[j], flen[j], arity[j]))) {
357 /* if there's more to come, bingo */
360 /* otherwise reinitialise the mindex we're currently shagging */
361 __initialise_multi_index(midx[j], arity[j]);
364 if (LIKELY(__advance_multi_index_comb(midx[j], flen[j], arity[j]))) {
367 /* otherwise reinitialise the mindex we're currently shagging */
368 __initialise_multi_index(midx[j], arity[j]);
372 if (LIKELY(__advance_multi_index_comb(
373 midx[j], flen[j], arity[j]))) {
376 /* otherwise reinitialise the mindex we're currently shagging */
377 __initialise_multi_index(midx[j], arity[j]);
383 /* This is the guts of several mapping functions.
384 Apply FUNCTION to each element of SEQUENCE, one by one,
385 storing the results into elements of VALS, a C vector of Lisp_Objects.
386 LENI is the length of VALS, which should also be the length of SEQUENCE.
388 If VALS is a null pointer, do not accumulate the results. */
391 mapcar1(size_t leni, Lisp_Object * vals,
392 Lisp_Object function, Lisp_Object sequence)
402 memset(vals, 0, leni * sizeof(Lisp_Object));
406 if (LISTP(sequence)) {
407 /* A devious `function' could either:
408 - insert garbage into the list in front of us, causing XCDR to crash
409 - amputate the list behind us using (setcdr), causing the remaining
410 elts to lose their GCPRO status.
412 if (vals != 0) we avoid this by copying the elts into the
413 `vals' array. By a stroke of luck, `vals' is exactly large
414 enough to hold the elts left to be traversed as well as the
415 results computed so far.
417 if (vals == 0) we don't have any free space available and
418 don't want to eat up any more stack with alloca().
419 So we use EXTERNAL_LIST_LOOP_3_NO_DECLARE and GCPRO the tail. */
422 Lisp_Object *val = vals;
425 LIST_LOOP_2(elt, sequence) {
429 for (i = 0; i < leni; i++) {
431 vals[i] = Ffuncall(2, args);
434 Lisp_Object elt, tail;
435 EMACS_INT len_unused;
436 struct gcpro ngcpro1;
441 EXTERNAL_LIST_LOOP_4_NO_DECLARE(elt, sequence,
451 } else if (VECTORP(sequence)) {
452 Lisp_Object *objs = XVECTOR_DATA(sequence);
454 for (size_t i = 0; i < leni; i++) {
456 result = Ffuncall(2, args);
461 } else if (DLLISTP(sequence)) {
462 dllist_item_t elt = XDLLIST_FIRST(sequence);
464 for (size_t i = 0; elt; i++) {
465 args[1] = (Lisp_Object)elt->item;
466 result = Ffuncall(2, args);
472 } else if (STRINGP(sequence)) {
473 /* The string data of `sequence' might be relocated during GC. */
474 Bytecount slen = XSTRING_LENGTH(sequence);
477 int speccount = specpdl_depth();
480 XMALLOC_ATOMIC_OR_ALLOCA(p, slen, Bufbyte);
483 memcpy(p, XSTRING_DATA(sequence), slen);
486 args[1] = make_char(charptr_emchar(p));
488 result = Ffuncall(2, args);
493 XMALLOC_UNBIND(p, slen, speccount);
494 } else if (BIT_VECTORP(sequence)) {
495 Lisp_Bit_Vector *v = XBIT_VECTOR(sequence);
497 for (size_t i = 0; i < leni; i++) {
498 args[1] = make_int(bit_vector_bit(v, i));
499 result = Ffuncall(2, args);
505 /* unreachable, since Flength (sequence) did not get an error */
515 list_map_inplace(Lisp_Object function, Lisp_Object list)
518 struct gcpro gcpro1, gcpro2;
519 Lisp_Object elt = list;
521 GCPRO2(function, list);
526 XCAR(elt) = Ffuncall(2, args);
533 vector_map_inplace(Lisp_Object function, Lisp_Object tuple)
535 Lisp_Object *objs = XVECTOR_DATA(tuple);
537 size_t i, len = XVECTOR_LENGTH(tuple);
538 struct gcpro gcpro1, gcpro2, gcpro3;
540 GCPRO2n(function, tuple, args, countof(args));
543 for (i = 0; i < len; i++) {
545 *objs++ = Ffuncall(2, args);
552 string_map_inplace(Lisp_Object function, Lisp_Object string)
555 size_t len = XSTRING_LENGTH(string);
556 Bufbyte *p = XSTRING_DATA(string);
557 Bufbyte *end = p + len;
558 struct gcpro gcpro1, gcpro2, gcpro3;
560 GCPRO2n(function, string, args, countof(args));
564 args[1] = make_char(charptr_emchar(p));
565 args[1] = Ffuncall(2, args);
567 set_charptr_emchar(p, XCHAR(args[1]));
569 set_charptr_emchar(p, '\000');
577 bit_vector_map_inplace(Lisp_Object function, Lisp_Object bitvec)
579 Lisp_Bit_Vector *v = XBIT_VECTOR(bitvec);
581 struct gcpro gcpro1, gcpro2, gcpro3;
582 size_t i, len = bit_vector_length(XBIT_VECTOR(bitvec));
584 GCPRO2n(function, bitvec, args, countof(args));
587 for (i = 0; i < len; i++) {
588 args[1] = make_int(bit_vector_bit(v, i));
589 args[1] = Ffuncall(2, args);
590 if ((NUMBERP(args[1]) && ent_unrel_zerop(args[1])) ||
592 set_bit_vector_bit(v, i, 0);
594 set_bit_vector_bit(v, i, -1);
601 * The mapfam approach
604 /* auxiliary stuff */
606 __fam_size(Lisp_Object fam)
608 return seq_length((seq_t)(void*)fam);
612 __nfam_min_size(Lisp_Object fam[], size_t nfam)
616 /* catch the horst-case */
617 if (UNLIKELY(nfam == 0)) {
620 /* otherwise unroll a little */
621 res = __fam_size(fam[0]);
622 for (size_t j = 1; j < nfam; j++) {
623 size_t tmp = __fam_size(fam[j]);
632 __nfam_min_size_a(Lisp_Object fam[], size_t nfam, size_t arity[])
636 /* catch the horst-case */
637 if (UNLIKELY(nfam == 0)) {
640 /* otherwise unroll a little */
641 res = __fam_size(fam[0]) / arity[0];
642 for (size_t j = 1; j < nfam; j++) {
643 size_t tmp = __fam_size(fam[j]) / arity[j];
652 __nfam_cart_sum_size(size_t *sum, size_t *cart, size_t nfsz[],
653 Lisp_Object fam[], size_t nfam)
655 /* computes the size of the cartesian set and the maximum size of
656 * the union set, returns the sum of cartesian and union, and puts
657 * intermediately computed family sizes int nfsz */
659 /* catch the horst-case */
660 if (UNLIKELY(nfam == 0)) {
663 } else if (nfam == 1) {
664 /* another horst case
665 * just 1 fam should always call fam_size() */
666 return *sum = *cart = nfsz[0] = __fam_size(fam[0]);
668 /* otherwise unroll a little */
669 nfsz[0] = __fam_size(fam[0]);
670 nfsz[1] = __fam_size(fam[1]);
671 *sum = nfsz[0] + nfsz[1];
672 *cart = nfsz[0] * nfsz[1];
673 for (size_t j = 2; j < nfam; j++) {
674 nfsz[j] = __fam_size(fam[j]);
682 __my_pow_insitu(size_t *base, size_t expon)
684 /* improve me and put me somewhere else, ase-arith.h? */
685 for (size_t i = 1, b = *base; i < expon; i++) {
692 __my_pow_explicit(size_t base, size_t expon)
694 /* improve me and put me somewhere else, ase-arith.h? */
696 for (size_t i = 1; i < expon; i++) {
703 __nfam_cart_sum_size_a(size_t *sum, size_t *cart, size_t *midxsz,
705 Lisp_Object fam[], size_t nfam, size_t arity[])
707 /* computes the size of the cartesian set (put into *cart), the maximum
708 * size of the union set (returned) and the multiplicity of the
709 * multi-index (which is the cross sum of the arity array) returns the
710 * sum of cartesian and union, and puts intermediately computed family
713 /* catch the horst-case */
714 if (UNLIKELY(nfam == 0)) {
715 *sum = *cart = *midxsz = 0;
717 } else if (nfam == 1) {
718 /* another horst case
719 * just 1 fam should always call fam_size() */
720 *sum = *cart = nfsz[0] = __fam_size(fam[0]);
721 __my_pow_insitu(cart, *midxsz = arity[0]);
724 /* otherwise unroll a little */
725 nfsz[0] = __fam_size(fam[0]);
726 nfsz[1] = __fam_size(fam[1]);
727 *sum = nfsz[0] + nfsz[1];
728 *midxsz = arity[0] + arity[1];
729 *cart = __my_pow_explicit(nfsz[0], arity[0]) *
730 __my_pow_explicit(nfsz[1], arity[1]);
731 for (size_t j = 2; j < nfam; j++) {
732 nfsz[j] = __fam_size(fam[j]);
735 *cart *= __my_pow_explicit(nfsz[j], arity[j]);
741 __nfam_comb_sum_size_a(size_t *sum, size_t *comb, size_t *midxsz,
743 Lisp_Object fam[], size_t nfam, size_t arity[])
745 /* computes the size of the cartesian set (returned), the maximum size of
746 * the union set and the multiplicity of the multi-index (which is the
747 * cross sum of the arity array) returns the sum of cartesian and union,
748 * and puts intermediately computed family sizes into nfsz */
750 /* catch the horst-case */
751 if (UNLIKELY(nfam == 0)) {
752 *sum = *comb = *midxsz = 0;
754 } else if (nfam == 1) {
755 /* another horst case
756 * just 1 fam should always call fam_size() */
757 *sum = nfsz[0] = __fam_size(fam[0]);
758 *comb = __ncombinations(nfsz[0], *midxsz = arity[0]);
761 /* otherwise unroll a little */
762 nfsz[0] = __fam_size(fam[0]);
763 nfsz[1] = __fam_size(fam[1]);
764 *sum = nfsz[0] + nfsz[1];
765 *midxsz = arity[0] + arity[1];
766 *comb = __ncombinations(nfsz[0], arity[0]) *
767 __ncombinations(nfsz[1], arity[1]);
768 for (size_t j = 2; j < nfam; j++) {
769 nfsz[j] = __fam_size(fam[j]);
772 *comb *= __ncombinations(nfsz[j], arity[j]);
778 __nfam_perm_sum_size(size_t *sum, size_t *cart, size_t *perm, size_t nfsz[],
779 Lisp_Object fam[], size_t nfam)
781 /* computes the size of the cartesian set and the maximum size of
782 * the union set, returns the sum of cartesian and union, and puts
783 * intermediately computed family sizes int nfsz */
785 /* catch the horst-case */
786 if (UNLIKELY(nfam == 0)) {
787 *sum = *cart = *perm = 0;
789 } else if (nfam == 1) {
790 /* another horst case
791 * just 1 fam should always call fam_size() */
793 return *sum = *cart = nfsz[0] = __fam_size(fam[0]);
795 /* otherwise unroll a little */
796 nfsz[0] = __fam_size(fam[0]);
797 nfsz[1] = __fam_size(fam[1]);
798 *sum = nfsz[0] + nfsz[1];
799 *cart = nfsz[0] * nfsz[1];
800 for (size_t j = 2; j < nfam; j++) {
801 nfsz[j] = __fam_size(fam[j]);
805 *cart *= (*perm = __factorial(nfam));
810 __nfam_perm_sum_size_a(size_t *sum, size_t *var, size_t *perm, size_t *midxsz,
812 Lisp_Object fam[], size_t nfam, size_t arity[])
814 /* computes the size of the cartesian set (returned), the maximum size of
815 * the union set and the multiplicity of the multi-index (which is the
816 * cross sum of the arity array) returns the sum of cartesian and union,
817 * and puts intermediately computed family sizes into nfsz */
819 /* catch the horst-case */
820 if (UNLIKELY(nfam == 0)) {
821 *sum = *var = *perm = *midxsz = 0;
823 } else if (nfam == 1) {
824 /* another horst case
825 * just 1 fam should always call fam_size() */
826 *sum = nfsz[0] = __fam_size(fam[0]);
827 *perm = __factorial(*midxsz = arity[0]);
828 *var = __ncombinations(nfsz[0], arity[0]) * *perm;
831 /* otherwise unroll a little */
832 nfsz[0] = __fam_size(fam[0]);
833 nfsz[1] = __fam_size(fam[1]);
834 *sum = nfsz[0] + nfsz[1];
835 *midxsz = arity[0] + arity[1];
836 *var = __ncombinations(nfsz[0], arity[0]) *
837 __ncombinations(nfsz[1], arity[1]);
838 for (size_t j = 2; j < nfam; j++) {
839 nfsz[j] = __fam_size(fam[j]);
842 *var *= __ncombinations(nfsz[j], arity[j]);
844 /* we computed the number of combinations above, now to compute
845 * the number of variations we have to apply the S_{midxsz} on
846 * each element, hence we simply multiply with the factorial of
847 * midxsz (which is the cross sum of all arities) */
848 *var *= (*perm = __factorial(*midxsz));
853 * dedicated subroutines for 2-combs and 3-combs because they are soooo easy
856 __2comb(Lisp_Object tgts[], size_t SXE_UNUSED(tlen),
857 Lisp_Object supp[], size_t slen,
858 Lisp_Object fun, glue_f gf)
860 /* assumes that everything is gcpro'd properly */
861 Lisp_Object arr[3] = {fun, Qnil, Qnil};
863 if (LIKELY(!NILP(fun) && gf == NULL)) {
864 for (size_t i = 0, l = 0; i < slen-1; i++) {
865 for (size_t j = i+1; j < slen; j++) {
866 /* set up the array */
870 tgts[l++] = Ffuncall(countof(arr), arr);
873 } else if (LIKELY(!NILP(fun))) {
874 for (size_t i = 0, l = 0; i < slen-1; i++) {
875 for (size_t j = i+1; j < slen; j++) {
876 /* set up the array */
880 arr[1] = gf(2, &arr[1]);
882 tgts[l++] = Ffuncall(2, arr);
886 glue_f tgf = gf ? gf : Flist;
887 for (size_t i = 0, l = 0; i < slen-1; i++) {
888 for (size_t j = i+1; j < slen; j++) {
889 /* set up the array */
893 tgts[l++] = tgf(2, &arr[1]);
901 __3comb(Lisp_Object tgts[], size_t SXE_UNUSED(tlen),
902 Lisp_Object supp[], size_t slen,
903 Lisp_Object fun, glue_f gf)
905 /* assumes that everything is gcpro'd properly */
906 Lisp_Object arr[4] = {fun, Qnil, Qnil, Qnil};
908 if (LIKELY(!NILP(fun) && gf == NULL)) {
909 for (size_t i = 0, l = 0; i < slen-2; i++) {
910 for (size_t j = i+1; j < slen-1; j++) {
911 for (size_t k = j+1; k < slen; k++) {
912 /* set up the array */
917 tgts[l++] = Ffuncall(countof(arr), arr);
921 } else if (LIKELY(!NILP(fun))) {
922 for (size_t i = 0, l = 0; i < slen-2; i++) {
923 for (size_t j = i+1; j < slen-1; j++) {
924 for (size_t k = j+1; k < slen; k++) {
925 /* set up the array */
930 arr[1] = gf(3, &arr[1]);
932 tgts[l++] = Ffuncall(2, arr);
937 glue_f tgf = gf ? gf : Flist;
938 for (size_t i = 0, l = 0; i < slen-2; i++) {
939 for (size_t j = i+1; j < slen-1; j++) {
940 for (size_t k = j+1; k < slen; k++) {
941 /* set up the array */
946 tgts[l++] = tgf(3, &arr[1]);
955 __ncomb(Lisp_Object tgts[], size_t tlen,
956 Lisp_Object supp[], size_t slen,
957 Lisp_Object fun, glue_f gf,
960 /* assumes that everything is gcpro'd properly */
963 Lisp_Object fc[arity+1], *v = &fc[1];
966 memset(idx, 0, arity*sizeof(long int));
967 memset(v, 0, arity*sizeof(Lisp_Object));
970 /* special case slen == arity */
971 if (UNLIKELY(slen == arity)) {
972 if (LIKELY(!NILP(fun) && gf == NULL)) {
973 tgts[0] = Ffuncall(slen, supp);
974 } else if (LIKELY(!NILP(fun))) {
975 v[0] = gf(slen, supp);
976 tgts[0] = Ffuncall(2, fc);
978 glue_f tgf = gf ? gf : Flist;
979 tgts[0] = tgf(slen, supp);
984 /* setup, partially unrolled */
987 for (size_t i = 2; i < arity; i++) {
991 if (LIKELY(!NILP(fun) && gf == NULL)) {
995 for (size_t i = 2; i < arity; i++) {
999 tgts[l++] = Ffuncall(countof(fc), fc);
1000 /* increment, fooking back'n'forth-loop-based
1002 (void)__advance_multi_index_comb(idx, slen, arity);
1004 } else if (LIKELY(!NILP(fun))) {
1006 v[0] = supp[idx[0]];
1007 v[1] = supp[idx[1]];
1008 for (size_t i = 2; i < arity; i++) {
1009 v[i] = supp[idx[i]];
1012 v[0] = gf(arity, v);
1014 tgts[l++] = Ffuncall(2, fc);
1015 /* increment, fooking back'n'forth-loop-based
1017 (void)__advance_multi_index_comb(idx, slen, arity);
1020 glue_f tgf = gf ? gf : Flist;
1022 v[0] = supp[idx[0]];
1023 v[1] = supp[idx[1]];
1024 for (size_t i = 2; i < arity; i++) {
1025 v[i] = supp[idx[i]];
1028 tgts[l++] = tgf(arity, v);
1029 /* increment, fooking back'n'forth-loop-based
1031 (void)__advance_multi_index_comb(idx, slen, arity);
1039 * dedicated subroutines for 2-perms and 3-perms because they are soooo easy
1040 * 2-perms (transpositions) is just a 2-cycle along with its transposition,
1041 * so we can directly reuse the comb algorithm
1042 * 3-perms are just as simple, since the generation of S_3 can simply be put
1043 * as (), a, a^2, b, a*b, a^2*b where a is a 3-cycle and b a 2-cycle.
1045 static inline size_t
1046 __2perm_fun(Lisp_Object tgts[], size_t SXE_UNUSED(tlen),
1047 Lisp_Object supp[], size_t SXE_UNUSED(slen),
1050 __attribute__((always_inline));
1051 static inline size_t
1052 __2perm_fun(Lisp_Object tgts[], size_t SXE_UNUSED(tlen),
1053 Lisp_Object supp[], size_t SXE_UNUSED(slen),
1057 /* apply fun on S_2 on (the first two elements of) supp */
1058 Lisp_Object arr[3] = {fun, Qnil, Qnil};
1060 /* set up the array */
1064 tgts[offset++] = Ffuncall(countof(arr), arr);
1066 /* swap them == (1,2) */
1070 tgts[offset++] = Ffuncall(countof(arr), arr);
1074 static inline size_t
1075 __2perm_glue_fun(Lisp_Object tgts[], size_t SXE_UNUSED(tlen),
1076 Lisp_Object supp[], size_t SXE_UNUSED(slen),
1077 Lisp_Object fun, glue_f gf,
1079 __attribute__((always_inline));
1080 static inline size_t
1081 __2perm_glue_fun(Lisp_Object tgts[], size_t SXE_UNUSED(tlen),
1082 Lisp_Object supp[], size_t SXE_UNUSED(slen),
1083 Lisp_Object fun, glue_f gf,
1086 /* apply fun on the glue of S_2 on (the first two elements of) supp */
1087 Lisp_Object arr[3] = {fun, Qnil, Qnil};
1089 /* set up the array */
1093 arr[1] = gf(2, &arr[1]);
1095 tgts[offset++] = Ffuncall(2, arr);
1097 /* swap them == (1,2) */
1101 arr[1] = gf(2, &arr[1]);
1103 tgts[offset++] = Ffuncall(2, arr);
1107 static inline size_t
1108 __2perm_glue(Lisp_Object tgts[], size_t SXE_UNUSED(tlen),
1109 Lisp_Object supp[], size_t SXE_UNUSED(slen),
1112 __attribute__((always_inline));
1113 static inline size_t
1114 __2perm_glue(Lisp_Object tgts[], size_t SXE_UNUSED(tlen),
1115 Lisp_Object supp[], size_t SXE_UNUSED(slen),
1119 /* glue of S_2 on (the first two elements of) supp */
1120 volatile Lisp_Object tmp = supp[0];
1122 /* directly apply glue */
1123 tgts[offset++] = gf(2, supp);
1125 /* swap them == (1,2) */
1129 tgts[offset++] = gf(2, supp);
1133 static inline size_t
1134 _2perm(Lisp_Object tgts[], size_t tlen,
1135 Lisp_Object supp[], size_t slen,
1136 Lisp_Object fun, glue_f gf,
1139 /* assumes that everything is gcpro'd correctly */
1140 if (LIKELY(!NILP(fun) && gf == NULL)) {
1141 return __2perm_fun(tgts, tlen, supp, slen, fun, offset);
1142 } else if (LIKELY(!NILP(fun))) {
1143 return __2perm_glue_fun(tgts, tlen, supp, slen,
1146 return __2perm_glue(tgts, tlen, supp, slen,
1147 gf ? gf : Flist, offset);
1152 _comb_2perm(Lisp_Object *tgts, size_t tlen,
1153 Lisp_Object *supp, size_t slen,
1154 Lisp_Object fun, glue_f gf)
1156 /* loop over everything in supp and form combinations thereof,
1158 * assumes that everything is gcpro'd correctly */
1159 Lisp_Object v[2] = {Qnil, Qnil};
1161 if (LIKELY(!NILP(fun) && gf == NULL)) {
1162 for (size_t i = 0, l = 0; i < slen-1; i++) {
1163 for (size_t j = i+1; j < slen; j++) {
1166 l = __2perm_fun(tgts, tlen, v, 2, fun, l);
1170 } else if (LIKELY(!NILP(fun))) {
1171 for (size_t i = 0, l = 0; i < slen-1; i++) {
1172 for (size_t j = i+1; j < slen; j++) {
1175 l = __2perm_glue_fun(
1176 tgts, tlen, v, 2, fun, gf, l);
1181 glue_f tgf = gf ? gf : Flist;
1182 for (size_t i = 0, l = 0; i < slen-1; i++) {
1183 for (size_t j = i+1; j < slen; j++) {
1186 l = __2perm_glue(tgts, tlen, v, 2, tgf, l);
1194 static inline size_t
1195 __3perm_fun(Lisp_Object tgts[], size_t SXE_UNUSED(tlen),
1196 Lisp_Object supp[], size_t SXE_UNUSED(slen),
1199 __attribute__((always_inline));
1200 static inline size_t
1201 __3perm_fun(Lisp_Object tgts[], size_t SXE_UNUSED(tlen),
1202 Lisp_Object supp[], size_t SXE_UNUSED(slen),
1206 /* apply fun on S_3 on (the first 3 elements of) supp */
1207 Lisp_Object arr[4] = {fun, Qnil, Qnil, Qnil};
1209 /* we use gap's order of the elements of S3
1210 * gap> Elements(SymmetricGroup(3));
1211 * [ (), (2,3), (1,2), (1,2,3), (1,3,2), (1,3) ] */
1218 tgts[offset++] = Ffuncall(countof(arr), arr);
1224 tgts[offset++] = Ffuncall(countof(arr), arr);
1231 tgts[offset++] = Ffuncall(countof(arr), arr);
1237 tgts[offset++] = Ffuncall(countof(arr), arr);
1244 tgts[offset++] = Ffuncall(countof(arr), arr);
1250 tgts[offset++] = Ffuncall(countof(arr), arr);
1255 static inline size_t
1256 __3perm_glue_fun(Lisp_Object tgts[], size_t SXE_UNUSED(tlen),
1257 Lisp_Object supp[], size_t SXE_UNUSED(slen),
1258 Lisp_Object fun, glue_f gf,
1260 __attribute__((always_inline));
1261 static inline size_t
1262 __3perm_glue_fun(Lisp_Object tgts[], size_t SXE_UNUSED(tlen),
1263 Lisp_Object supp[], size_t SXE_UNUSED(slen),
1264 Lisp_Object fun, glue_f gf,
1267 /* apply fun on the glue of S_3 on (the first 3 elements of) supp */
1268 Lisp_Object arr[4] = {fun, Qnil, Qnil, Qnil};
1270 /* we use gap's order of the elements of S3
1271 * gap> Elements(SymmetricGroup(3));
1272 * [ (), (2,3), (1,2), (1,2,3), (1,3,2), (1,3) ] */
1279 arr[1] = gf(3, &arr[1]);
1281 tgts[offset++] = Ffuncall(2, arr);
1288 arr[1] = gf(3, &arr[1]);
1290 tgts[offset++] = Ffuncall(2, arr);
1297 arr[1] = gf(3, &arr[1]);
1299 tgts[offset++] = Ffuncall(2, arr);
1306 arr[1] = gf(3, &arr[1]);
1308 tgts[offset++] = Ffuncall(2, arr);
1315 arr[1] = gf(3, &arr[1]);
1317 tgts[offset++] = Ffuncall(2, arr);
1324 arr[1] = gf(3, &arr[1]);
1326 tgts[offset++] = Ffuncall(2, arr);
1331 static inline size_t
1332 __3perm_glue(Lisp_Object tgts[], size_t SXE_UNUSED(tlen),
1333 Lisp_Object supp[], size_t SXE_UNUSED(slen),
1336 __attribute__((always_inline));
1337 static inline size_t
1338 __3perm_glue(Lisp_Object tgts[], size_t SXE_UNUSED(tlen),
1339 Lisp_Object supp[], size_t SXE_UNUSED(slen),
1343 /* glue of S_3 on (the first 3 elements of) supp */
1344 volatile Lisp_Object tmp;
1346 /* we use gap's order of the elements of S3
1347 * gap> Elements(SymmetricGroup(3));
1348 * [ (), (2,3), (1,2), (1,2,3), (1,3,2), (1,3) ] */
1350 /* (), directly apply glue */
1351 tgts[offset++] = gf(3, supp);
1358 tgts[offset++] = gf(3, supp);
1360 /* (0,1) == (0,1)(1,2)(1,2) == (0,1,2)(1,2) */
1366 tgts[offset++] = gf(3, supp);
1368 /* (0,1,2) == (0,2)(0,1) */
1373 tgts[offset++] = gf(3, supp);
1375 /* (0,2,1) == (0,1,2)(0,1,2) */
1381 tgts[offset++] = gf(3, supp);
1383 /* (0,2) == (0,1)(0,2,1) */
1388 tgts[offset++] = gf(3, supp);
1394 _comb_3perm(Lisp_Object *tgts, size_t tlen,
1395 Lisp_Object *supp, size_t slen,
1396 Lisp_Object fun, glue_f gf)
1398 /* loop over everything in supp and form combinations thereof,
1400 * assumes that everything is gcpro'd correctly */
1401 Lisp_Object v[3] = {Qnil, Qnil, Qnil};
1403 if (LIKELY(!NILP(fun) && gf == NULL)) {
1404 for (size_t i = 0, l = 0; i < slen-2; i++) {
1405 for (size_t j = i+1; j < slen-1; j++) {
1406 for (size_t k = j+1; k < slen; k++) {
1411 tgts, tlen, v, 3, fun, l);
1416 } else if (LIKELY(!NILP(fun))) {
1417 for (size_t i = 0, l = 0; i < slen-2; i++) {
1418 for (size_t j = i+1; j < slen-1; j++) {
1419 for (size_t k = j+1; k < slen; k++) {
1423 l = __3perm_glue_fun(
1424 tgts, tlen, v, 3, fun, gf, l);
1430 glue_f tgf = gf ? gf : Flist;
1431 for (size_t i = 0, l = 0; i < slen-2; i++) {
1432 for (size_t j = i+1; j < slen-1; j++) {
1433 for (size_t k = j+1; k < slen; k++) {
1438 tgts, tlen, v, 3, tgf, l);
1447 __transpose(Lisp_Object arr[], size_t i, size_t j)
1448 __attribute__((always_inline));
1450 __transpose(Lisp_Object arr[], size_t i, size_t j)
1452 /* use xchg assembly? */
1453 volatile Lisp_Object tmp = arr[i];
1459 static inline long int
1460 __divmod3(long int *_div_, long int num)
1461 __attribute__((always_inline));
1463 /* idivl uses >48 cycles, which is too slow for division by constants */
1464 static inline long int
1465 __divmod3(long int *_div_, long int num)
1467 /* compute _DIV_ div 3 and _DIV_ mod 3,
1468 * store the divisor in `_DIV_', the remainder in `_REM_' */
1472 __asm__("idivl %[modulus]; /* eax,edx = eax idivl 3 */\n\t"
1473 : "=&d" (_rem_), "+%a" (*_div_)
1474 : [modulus] "rm" (3) : "cc");
1478 static inline long int
1479 __divmod3(long int *_div_, long int num)
1481 long int rem = num % 3;
1487 static inline long int
1488 __divmodk(long int *_div_, long int modulus)
1489 __attribute__((always_inline));
1491 static inline long int
1492 __divmodk(long int *_div_, long int modulus)
1494 /* compute _DIV_ div MODULUS and _DIV_ mod MODULUS,
1495 * store the divisor in `_DIV_', the remainder in `_REM_'
1496 * this assembler version takes ... cycles on x86 and x86_64 processors,
1497 * however the generated code below seems to be faster -- and is more
1498 * portable anyway, since it's C */
1501 __asm__("idivl %[modulus]; /* eax,edx = eax idivl 3 */\n\t"
1502 : "=&d" (_rem_), "+%a" (*_div_)
1503 : [modulus] "rm" (modulus) : "cc");
1507 static inline long int
1508 __divmodk(long int *_div_, long int modulus)
1510 long int rem = *_div_ % modulus;
1517 __bruhat(Lisp_Object arr[], long int k)
1518 __attribute__((always_inline));
1520 __bruhat(Lisp_Object arr[], long int k)
1522 /* computes the k-th transposition in quasi bruhat order and
1523 * applies it to arr */
1525 if (UNLIKELY(k == 0)) {
1529 /* odd Ks always connote (0,1) */
1530 __transpose(arr, 0, 1);
1532 } else if (__divmod3(&k, (k >>= 1))) {
1533 /* 1 mod 3 and 2 mod 3 go to (1,2) */
1534 __transpose(arr, 1, 2);
1538 /* otherwise k is 0 mod 3 (and we divided by 3 already)
1539 * now we've factored out S_3 already */
1540 switch (k & 3 /* k % 4 */) {
1542 __transpose(arr, 2, 3);
1545 __transpose(arr, 0, 3);
1548 __transpose(arr, 1, 3);
1555 /* S_2, S_3, and S_4 is handled about, go on with S_5 now */
1556 for (int i = 5; k; i++) {
1558 if ((rem = __divmodk(&k, i))) {
1559 if (i & 1 || (rem -= 2) < 0) {
1560 /* odd i always induces the
1561 * (i-1, i) transposition
1562 * in C this is (i-2, i-1) */
1563 __transpose(arr, i-2, i-1);
1565 /* even i is uglier :(
1566 * if rem == 1 -> (i-1, i)
1567 * if rem == 2 -> (1, i)
1568 * if rem == 3 -> (2, i)
1570 __transpose(arr, rem, i-1);
1571 /* note: we treated the rem == 1 case above */
1579 static inline size_t
1580 __Sn_fun(Lisp_Object tgts[], size_t tlen,
1581 Lisp_Object supp[], size_t slen,
1584 __attribute__((always_inline));
1585 static inline size_t
1586 __Sn_fun(Lisp_Object tgts[], size_t tlen,
1587 Lisp_Object supp[], size_t slen,
1591 /* apply FUN on S_n on (the first SLEN elements of) SUPP
1592 * put results into TGTS
1593 * assumes that everything is gcpro'd correctly
1594 * also assumes that tlen == __factorial(slen) */
1595 Lisp_Object arr[slen+1], *v = &arr[1];
1597 /* setup, partially unrolled */
1602 for (size_t i = 3; i < slen; i++) {
1606 /* now we're in the setting ... */
1607 /* we enter the perm loop now, the first addition is the vector
1608 * times identity permutation */
1609 while (tlen-- > 0) {
1610 tgts[offset++] = Ffuncall(countof(arr), arr);
1611 /* permute the working vector */
1612 __bruhat(v, offset);
1617 static inline size_t
1618 __Sn_glue_fun(Lisp_Object tgts[], size_t tlen,
1619 Lisp_Object supp[], size_t slen,
1620 Lisp_Object fun, glue_f gf,
1622 __attribute__((always_inline));
1623 static inline size_t
1624 __Sn_glue_fun(Lisp_Object tgts[], size_t tlen,
1625 Lisp_Object supp[], size_t slen,
1626 Lisp_Object fun, glue_f gf,
1629 /* apply FUN on glue of S_n on (the first SLEN elements of) SUPP
1630 * put results into TGTS
1631 * assumes that everything is gcpro'd correctly
1632 * also assumes that tlen == __factorial(slen) */
1633 Lisp_Object arr[slen+1], *v = &arr[1];
1635 /* setup, partially unrolled */
1640 for (size_t i = 3; i < slen; i++) {
1644 /* now we're in the setting ... */
1645 /* we enter the perm loop now, the first addition is the vector
1646 * times identity permutation */
1647 while (tlen-- > 0) {
1648 /* backup that first slot */
1649 volatile Lisp_Object tmp = v[0];
1651 tgts[offset++] = Ffuncall(2, arr);
1652 /* recover from backup slot */
1654 /* permute the working vector */
1655 __bruhat(v, offset);
1660 static inline size_t
1661 __Sn_glue(Lisp_Object tgts[], size_t tlen,
1662 Lisp_Object supp[], size_t slen,
1665 __attribute__((always_inline));
1666 static inline size_t
1667 __Sn_glue(Lisp_Object tgts[], size_t tlen,
1668 Lisp_Object supp[], size_t slen,
1672 /* glue of S_n on (the first SLEN elements of) SUPP
1673 * put results into TGTS
1674 * assumes that everything is gcpro'd correctly
1675 * also assumes that tlen == __factorial(slen) */
1676 Lisp_Object arr[slen];
1678 /* setup, partially unrolled */
1682 for (size_t i = 3; i < slen; i++) {
1686 /* now we're in the setting ... */
1687 /* we enter the perm loop now, the first addition is the vector
1688 * times identity permutation */
1689 while (tlen-- > 0) {
1690 tgts[offset++] = gf(countof(arr), arr);
1691 /* permute the working vector */
1692 __bruhat(arr, offset);
1697 static inline void /* inline this? */
1698 _Sn(Lisp_Object tgts[], size_t tlen,
1699 Lisp_Object supp[], size_t slen,
1700 Lisp_Object fun, glue_f gf)
1701 __attribute__((always_inline));
1703 _Sn(Lisp_Object tgts[], size_t tlen,
1704 Lisp_Object supp[], size_t slen,
1705 Lisp_Object fun, glue_f gf)
1707 /* assumes that everything is gcpro'd correctly
1708 * this is just an intermediate switch, the hard work happens in
1709 * __Sn_fun(), __Sn_glue_fun() and __Sn_glue() depending on whether
1710 * just a function and no glue has been specified, a function and a glue
1711 * function has been specified, or just a glue function has been
1712 * specified respectively */
1714 if (LIKELY(!NILP(fun) && gf == NULL)) {
1715 (void)__Sn_fun(tgts, tlen, supp, slen, fun, 0);
1716 } else if (LIKELY(!NILP(fun))) {
1717 (void)__Sn_glue_fun(tgts, tlen, supp, slen, fun, gf, 0);
1719 glue_f tgf = gf ? gf : Flist;
1720 (void)__Sn_glue(tgts, tlen, supp, slen, tgf, 0);
1726 _comb_Sn(Lisp_Object tgts[], size_t tlen,
1727 Lisp_Object supp[], size_t slen,
1728 Lisp_Object fun, glue_f gf,
1731 /* assumes that everything is gcpro'd correctly
1732 * this has the same signature as _Sn() but additionally there's the
1734 * this is basically the code for variations, i.e. applying the S_m
1735 * (m < n) on some subset of size m of a set of size n */
1736 Lisp_Object v[arity];
1737 size_t idx[arity+1];
1738 size_t l = 0, np = __factorial(arity);
1741 memset(idx, 0, arity*sizeof(long int));
1743 /* more setup, partially unrolled */
1747 for (size_t i = 3; i < arity; i++) {
1751 if (LIKELY(!NILP(fun) && gf == NULL)) {
1753 /* get the combinations, serves as starting set,
1754 * partially unrolled */
1755 v[0] = supp[idx[0]];
1756 v[1] = supp[idx[1]];
1757 v[2] = supp[idx[2]];
1758 for (size_t i = 3; i < arity; i++) {
1759 v[i] = supp[idx[i]];
1761 /* do the rain dance */
1762 l = __Sn_fun(tgts, np, v, arity, fun, l);
1763 /* increment, fooking back'n'forth-loop-based
1765 (void)__advance_multi_index_comb(idx, slen, arity);
1767 } else if (LIKELY(!NILP(fun))) {
1769 /* get the combinations, serves as starting set,
1770 * partially unrolled */
1771 v[0] = supp[idx[0]];
1772 v[1] = supp[idx[1]];
1773 v[2] = supp[idx[2]];
1774 for (size_t i = 3; i < arity; i++) {
1775 v[i] = supp[idx[i]];
1777 /* do the rain dance */
1778 l = __Sn_glue_fun(tgts, np, v, arity, fun, gf, l);
1779 /* increment, fooking back'n'forth-loop-based
1781 (void)__advance_multi_index_comb(idx, slen, arity);
1784 glue_f tgf = gf ? gf : Flist;
1786 /* get the combinations, serves as starting set,
1787 * partially unrolled */
1788 v[0] = supp[idx[0]];
1789 v[1] = supp[idx[1]];
1790 v[2] = supp[idx[2]];
1791 for (size_t i = 3; i < arity; i++) {
1792 v[i] = supp[idx[i]];
1794 /* do the rain dance */
1795 l = __Sn_glue(tgts, np, v, arity, tgf, l);
1796 /* increment, fooking back'n'forth-loop-based
1798 (void)__advance_multi_index_comb(idx, slen, arity);
1806 _2cart(Lisp_Object tgts[], size_t tlen,
1807 Lisp_Object supp[], size_t slen,
1808 Lisp_Object fun, glue_f gf)
1810 /* assumes that everything is gcpro'd properly
1811 * This function can GC */
1812 Lisp_Object arr[3] = {fun, Qnil, Qnil};
1814 if (LIKELY(!NILP(fun) && gf == NULL)) {
1815 for (size_t i = 0, l = 0; i < slen; i++) {
1816 for (size_t j = 0; j < slen; j++) {
1817 /* set up the array */
1821 tgts[l++] = Ffuncall(countof(arr), arr);
1824 } else if (LIKELY(!NILP(fun))) {
1825 for (size_t i = 0, l = 0; i < slen; i++) {
1826 for (size_t j = 0; j < slen; j++) {
1827 /* set up the array */
1831 arr[1] = gf(2, &arr[1]);
1833 tgts[l++] = Ffuncall(2, arr);
1837 glue_f tgf = gf ? gf : Flist;
1838 for (size_t i = 0, l = 0; i < slen; i++) {
1839 for (size_t j = 0; j < slen; j++) {
1840 /* set up the array */
1844 tgts[l++] = tgf(2, &arr[1]);
1852 _3cart(Lisp_Object tgts[], size_t tlen,
1853 Lisp_Object supp[], size_t slen,
1854 Lisp_Object fun, glue_f gf)
1856 /* assumes that everything is gcpro'd properly
1857 * This function can GC */
1858 Lisp_Object arr[4] = {fun, Qnil, Qnil, Qnil};
1860 if (LIKELY(!NILP(fun) && gf == NULL)) {
1861 for (size_t i = 0, l = 0; i < slen; i++) {
1862 for (size_t j = 0; j < slen; j++) {
1863 for (size_t k = 0; k < slen; k++) {
1864 /* set up the array */
1869 tgts[l++] = Ffuncall(countof(arr), arr);
1873 } else if (LIKELY(!NILP(fun))) {
1874 for (size_t i = 0, l = 0; i < slen; i++) {
1875 for (size_t j = 0; j < slen; j++) {
1876 for (size_t k = 0; k < slen; k++) {
1877 /* set up the array */
1882 arr[1] = gf(3, &arr[1]);
1884 tgts[l++] = Ffuncall(2, arr);
1889 glue_f tgf = gf ? gf : Flist;
1890 for (size_t i = 0, l = 0; i < slen; i++) {
1891 for (size_t j = 0; j < slen; j++) {
1892 for (size_t k = 0; k < slen; k++) {
1893 /* set up the array */
1898 tgts[l++] = tgf(3, &arr[1]);
1907 _ncart(Lisp_Object tgts[], size_t tlen,
1908 Lisp_Object supp[], size_t slen,
1909 Lisp_Object fun, glue_f gf,
1912 /* assumes that everything is gcpro'd properly
1913 * This function can GC */
1914 long int idx[arity]; /* the multi-index */
1916 Lisp_Object fc[arity+1], *v = &fc[1];
1919 memset(idx, 0, arity*sizeof(long int));
1920 memset(v, 0, arity*sizeof(Lisp_Object));
1923 /* now we're in the setting ... */
1924 if (LIKELY(!NILP(fun) && gf == NULL)) {
1926 /* get the fam data, partially unrolled */
1927 v[0] = supp[idx[0]];
1928 v[1] = supp[idx[1]];
1929 v[2] = supp[idx[2]];
1930 for (size_t i = 3; i < arity; i++) {
1931 v[i] = supp[idx[i]];
1934 tgts[l++] = Ffuncall(countof(fc), fc);
1935 /* advance the multi-index, partially unrolled */
1936 __advance_multi_index(idx, arity, slen);
1938 } else if (LIKELY(!NILP(fun))) {
1940 /* get the fam data, partially unrolled */
1941 v[0] = supp[idx[0]];
1942 v[1] = supp[idx[1]];
1943 v[2] = supp[idx[2]];
1944 for (size_t i = 3; i < arity; i++) {
1945 v[i] = supp[idx[i]];
1948 v[0] = gf(arity, v);
1950 tgts[l++] = Ffuncall(2, fc);
1951 /* advance the multi-index, partially unrolled */
1952 __advance_multi_index(idx, arity, slen);
1955 glue_f tgf = gf ? gf : Flist;
1957 /* get the fam data, partially unrolled */
1958 v[0] = supp[idx[0]];
1959 v[1] = supp[idx[1]];
1960 v[2] = supp[idx[2]];
1961 for (size_t i = 3; i < arity; i++) {
1962 v[i] = supp[idx[i]];
1965 tgts[l++] = tgf(arity, v);
1966 /* advance the multi-index, partially unrolled */
1967 __advance_multi_index(idx, arity, slen);
1975 __dress_result(Lisp_Object rtype, Lisp_Object arr[], size_t len)
1977 /* from most likely to least likely */
1978 if (EQ(rtype, Qlist)) {
1979 return __Flist(len, arr);
1980 } else if (EQ(rtype, Qvector)) {
1981 return Fvector(len, arr);
1982 } else if (EQ(rtype, Qdllist)) {
1983 return Fdllist(len, arr);
1984 } else if (EQ(rtype, Qlitter) || EQ(rtype, Qvoid)) {
1986 } else if (EQ(rtype, Qinplace)) {
1988 } else if (EQ(rtype, Qstring)) {
1989 return Fstring(len, arr);
1990 } else if (EQ(rtype, Qbit_vector)) {
1991 return Fbit_vector(len, arr);
1992 } else if (EQ(rtype, Qconcat)) {
1993 return Fconcat(len, arr);
1998 static inline size_t
1999 __explode_1dict(Lisp_Object *restrict tkeys, Lisp_Object *restrict tvals,
2000 Lisp_Object dict, size_t len)
2001 __attribute__((always_inline));
2002 static inline size_t
2003 __explode_1dict(Lisp_Object *restrict tkeys, Lisp_Object *restrict tvals,
2004 Lisp_Object dict, size_t len)
2007 dict_t d = (dict_t)(void*)dict;
2008 struct dict_iter_s _di, *di = &_di;
2010 dict_iter_init(d, di);
2013 Lisp_Object key, val;
2014 dict_iter_next(di, &key, &val);
2015 if (LIKELY(key != Qnull_pointer)) {
2029 __comb_1seq(Lisp_Object seq, Lisp_Object fun, size_t arity,
2030 glue_f gluef, Lisp_Object result_type)
2032 size_t fs = __fam_size(seq);
2033 size_t nc = __ncombinations(fs, arity != -1UL ? arity : (arity = fs));
2034 /* C99 we need you */
2035 size_t maxsz = __sys_stk_free() / sizeof(Lisp_Object);
2037 /* leave room for stuff after us,
2038 * we call a function on this, so leave plenty of space */
2040 ? nc + fs /* actually we just need nc + arity - 1 */
2042 Lisp_Object __vals[leni], *vals, *rvals, result;
2044 struct gcpro gcpro1;
2046 if (UNLIKELY(arity == 0 || nc == 0)) {
2048 return __dress_result(result_type, NULL, 0);
2051 if (UNLIKELY(leni == 0)) {
2052 speccnt = specpdl_depth();
2053 vals = xnew_array(Lisp_Object, nc + fs);
2054 record_unwind_protect(free_malloced_ptr, make_opaque_ptr(vals));
2059 /* explode the sequence */
2060 memset(vals, 0, nc * sizeof(Lisp_Object));
2061 (void)seq_explode((void*restrict*)&vals[nc], fs, (seq_t)seq);
2063 GCPROn(vals, nc+fs);
2066 /* the same as pntw mode */
2068 if (UNLIKELY(NILP(fun) || nc == 0UL)) {
2073 for (size_t i = nc; i < nc + fs; i++) {
2074 Lisp_Object args[2] = {fun, vals[i]};
2075 vals[i] = Ffuncall(2, args);
2080 __2comb(vals, nc, &vals[nc], fs, fun, gluef);
2084 __3comb(vals, nc, &vals[nc], fs, fun, gluef);
2088 __ncomb(vals, nc, &vals[nc], fs, fun, gluef, arity);
2092 result = __dress_result(result_type, rvals, nc);
2094 if (UNLIKELY(leni == 0)) {
2095 unbind_to(speccnt, Qnil);
2101 __perm_1seq(Lisp_Object seq, Lisp_Object fun, size_t arity,
2102 glue_f gluef, Lisp_Object result_type)
2104 size_t fs = __fam_size(seq);
2105 size_t nv = __nvariations(fs, arity != -1UL ? arity : (arity = fs));
2106 /* C99 we need you */
2107 size_t maxsz = __sys_stk_free() / sizeof(Lisp_Object);
2109 /* leave room for stuff after us,
2110 * we call a function on this, so leave plenty of space */
2114 Lisp_Object __vals[leni], *vals, *rvals = NULL, result;
2116 struct gcpro gcpro1;
2118 if (UNLIKELY(leni == 0)) {
2119 speccnt = specpdl_depth();
2120 vals = xnew_array(Lisp_Object, nv + fs);
2121 record_unwind_protect(free_malloced_ptr, make_opaque_ptr(vals));
2126 if (UNLIKELY(arity == 0)) {
2128 return __dress_result(result_type, NULL, 0);
2131 /* explode the sequence */
2132 memset(vals, 0, (nv) * sizeof(Lisp_Object));
2133 (void)seq_explode((void*restrict*)&vals[nv], fs, (seq_t)seq);
2135 GCPROn(vals, nv + fs);
2138 /* the same as pntw mode */
2140 if (UNLIKELY(NILP(fun) || nv == 0UL)) {
2145 for (size_t i = nv; i < nv+fs; i++) {
2146 Lisp_Object args[2] = {fun, vals[i]};
2147 vals[i] = Ffuncall(2, args);
2152 _comb_2perm(vals, nv, &vals[nv], fs, fun, gluef);
2156 _comb_3perm(vals, nv, &vals[nv], fs, fun, gluef);
2160 if (LIKELY(fs != arity)) {
2161 _comb_Sn(vals, nv, &vals[nv], fs, fun, gluef, arity);
2163 /* optimised for mere permutations */
2164 _Sn(vals, nv, &vals[nv], fs /*== arity*/, fun, gluef);
2169 result = __dress_result(result_type, rvals, nv);
2171 if (UNLIKELY(leni == 0)) {
2172 unbind_to(speccnt, Qnil);
2178 __cart_1seq(Lisp_Object seq, Lisp_Object fun, size_t arity,
2179 glue_f gluef, Lisp_Object result_type)
2181 size_t fs = __fam_size(seq);
2182 size_t nc = __ncart(fs, arity);
2183 /* C99 we need you */
2184 size_t maxsz = __sys_stk_free() / sizeof(Lisp_Object);
2186 /* leave room for stuff after us,
2187 * we call a function on this, so leave plenty of space */
2191 Lisp_Object __vals[leni], *vals, result;
2193 struct gcpro gcpro1;
2195 if (UNLIKELY(arity == 0)) {
2197 return __dress_result(result_type, NULL, 0);
2200 if (UNLIKELY(leni == 0)) {
2201 speccnt = specpdl_depth();
2202 vals = xnew_array(Lisp_Object, nc);
2203 record_unwind_protect(free_malloced_ptr, make_opaque_ptr(vals));
2208 /* explode the sequence */
2209 memset(vals, 0, (nc - fs) * sizeof(Lisp_Object));
2210 seq_explode((void*restrict*)&vals[nc - fs], fs, (seq_t)seq);
2215 /* the same as pntw mode */
2217 if (UNLIKELY(NILP(fun) || nc == 0UL)) {
2221 for (size_t i = 0; i < nc; i++) {
2222 Lisp_Object args[2] = {fun, vals[i]};
2223 vals[i] = Ffuncall(2, args);
2227 _2cart(vals, nc, &vals[nc-fs], fs, fun, gluef);
2230 _3cart(vals, nc, &vals[nc-fs], fs, fun, gluef);
2233 _ncart(vals, nc, &vals[nc-fs], fs, fun, gluef, arity);
2236 result = __dress_result(result_type, vals, nc);
2238 if (UNLIKELY(leni == 0)) {
2239 unbind_to(speccnt, Qnil);
2245 __pntw_1seq(Lisp_Object seq, Lisp_Object fun, size_t arity,
2246 glue_f gluef, Lisp_Object result_type,
2247 struct decoration_s deco)
2249 size_t nseq = __fam_size(seq);
2250 /* C99 we need you */
2251 size_t maxsz = __sys_stk_free() / sizeof(Lisp_Object);
2252 size_t totlen = nseq + 2 /* for ini and ter */ + (deco.sep ? nseq : 0);
2254 /* leave room for stuff after us,
2255 * we call a function on this, so leave plenty of space */
2260 Lisp_Object __vals[leni+1], *vals, *seqelts, result;
2263 /* expherts alarm */
2264 return __dress_result(result_type, NULL, 0);
2266 if (UNLIKELY(leni == 0)) {
2267 vals = xnew_array(Lisp_Object, totlen);
2272 /* start maybe with the initiator */
2273 if (UNLIKELY(deco.ini != Qnull_pointer)) {
2274 vals[len++] = deco.ini;
2276 /* explode the sequence */
2277 if (LIKELY(deco.sep == Qnull_pointer)) {
2278 seqelts = &vals[len];
2280 seqelts = vals + (deco.sep ? nseq : 0);
2281 memset(&vals[len], 0, sizeof(Lisp_Object) * nseq);
2283 (void)seq_explode((void*restrict*)seqelts, nseq, (seq_t)seq);
2285 /* fill the rest with naughts */
2286 memset(&seqelts[nseq], 0, (totlen - len - nseq) * sizeof(Lisp_Object));
2291 if (deco.sep != Qnull_pointer) {
2293 for (size_t i = 0; i < nseq; i++) {
2294 vals[len++] = seqelts[i];
2295 vals[len++] = deco.sep;
2297 /* because we dont want the last element to
2298 * be followed by a separator */
2305 /* condense the stuff */
2306 for (size_t i = 0, bar = nseq & -2;
2307 /* traverse to the previous even number */
2310 ? gluef(2, &seqelts[i])
2311 : list2(seqelts[i], seqelts[i+1]);
2312 if (UNLIKELY(deco.sep != Qnull_pointer)) {
2313 vals[len++] = deco.sep;
2316 if (UNLIKELY(deco.sep != Qnull_pointer)) {
2317 /* strike the last separator */
2322 /* condense the stuff */
2324 /* traverse to the last 3-divisible index */
2325 i+3 <= nseq; i += 3) {
2327 ? gluef(3, &seqelts[i])
2331 if (UNLIKELY(deco.sep != Qnull_pointer)) {
2332 vals[len++] = deco.sep;
2335 if (UNLIKELY(deco.sep != Qnull_pointer)) {
2336 /* strike the last separator */
2341 /* condense the stuff */
2343 /* traverse to the last sane index */
2344 i+arity <= nseq; i += arity) {
2346 ? gluef(arity, &seqelts[i])
2347 : Flist(arity, &seqelts[i]);
2348 if (UNLIKELY(deco.sep != Qnull_pointer)) {
2349 vals[len++] = deco.sep;
2352 if (UNLIKELY(deco.sep != Qnull_pointer)) {
2353 /* kick the last one */
2358 struct gcpro gcpro1;
2362 GCPROn(vals, totlen);
2364 for (size_t i = 0; i < nseq; i++) {
2365 Lisp_Object args[2] = {fun, seqelts[i]};
2366 vals[len++] = Ffuncall(2, args);
2367 if (UNLIKELY(deco.sep != Qnull_pointer)) {
2368 vals[len++] = deco.sep;
2371 if (UNLIKELY(deco.sep != Qnull_pointer)) {
2372 /* strike the last separator */
2380 GCPROn(vals, totlen);
2382 for (size_t i = 0, bar = nseq & -2;
2383 /* traverse to the last even index */
2385 Lisp_Object args[3] = {fun, seqelts[i], seqelts[i+1]};
2386 vals[len++] = Ffuncall(countof(args), args);
2387 if (UNLIKELY(deco.sep != Qnull_pointer)) {
2388 vals[len++] = deco.sep;
2391 if (UNLIKELY(deco.sep != Qnull_pointer)) {
2392 /* strike the last separator */
2403 /* traverse to the last 3-divisible index */
2404 i+3 <= nseq; i += 3) {
2405 Lisp_Object args[4] = {
2406 fun, seqelts[i], seqelts[i+1],
2408 vals[len++] = Ffuncall(countof(args), args);
2409 if (UNLIKELY(deco.sep != Qnull_pointer)) {
2410 vals[len++] = deco.sep;
2413 if (UNLIKELY(deco.sep != Qnull_pointer)) {
2414 /* strike the last separator */
2425 /* traverse to the last 3-divisible index */
2426 i+arity <= nseq; i += arity) {
2427 Lisp_Object args[arity+1];
2430 args[1] = seqelts[i];
2431 args[2] = seqelts[i+1];
2432 args[3] = seqelts[i+2];
2433 args[4] = seqelts[i+3];
2434 for (size_t j = 4; j < arity; j++) {
2435 args[j+1] = seqelts[i+j];
2437 vals[len++] = Ffuncall(countof(args), args);
2438 if (UNLIKELY(deco.sep != Qnull_pointer)) {
2440 vals[len++] = deco.sep;
2443 if (UNLIKELY(deco.sep != Qnull_pointer)) {
2444 /* kick the last one */
2452 /* top off with the terminator */
2453 if (UNLIKELY(deco.ter != Qnull_pointer)) {
2454 vals[len++] = deco.ter;
2457 result = __dress_result(result_type, vals, len);
2458 if (UNLIKELY(leni == 0)) {
2465 __pntw_1dict(Lisp_Object dict, Lisp_Object fun,
2466 glue_f gluef, Lisp_Object result_type)
2468 /* basically like maphash/mapskiplist */
2469 size_t ndict = dict_size((dict_t)(void*)dict);
2470 /* C99 we need you */
2471 size_t maxsz = __sys_stk_free() / sizeof(Lisp_Object);
2473 /* leave room for stuff after us,
2474 * we call a function on this, so leave plenty of space */
2479 Lisp_Object __keys[leni], __vals[leni], *keys, *vals, result;
2481 if (UNLIKELY(leni == 0)) {
2482 keys = xnew_array(Lisp_Object, 2 * ndict);
2483 vals = &keys[ndict];
2489 /* explode the sequence */
2490 len = __explode_1dict(keys, vals, dict, ndict);
2492 if (LIKELY(!NILP(fun) && len > 0UL)) {
2493 struct gcpro gcpro1, gcpro2;
2495 GCPRO1n(dict, vals, len);
2497 for (size_t i = 0; i < len; i++) {
2498 Lisp_Object args[3] = {fun, keys[i], vals[i]};
2499 vals[i] = Ffuncall(countof(args), args);
2504 for (size_t i = 0; i < len; i++) {
2505 Lisp_Object args[2] = {keys[i], vals[i]};
2507 ? gluef(countof(args), args)
2508 : Flist(countof(args), args);
2512 result = __dress_result(result_type, vals, len);
2513 if (UNLIKELY(leni == 0)) {
2520 __pntw_nseq(Lisp_Object seqs[], size_t nseqs, Lisp_Object fun,
2521 glue_f gluef, Lisp_Object result_type)
2523 /* defaults to arity 1,1,...,1 */
2524 size_t nmin = __nfam_min_size(seqs, nseqs);
2525 /* C99 we need you */
2526 struct seq_iter_s its[nseqs];
2527 size_t maxsz = __sys_stk_free() / sizeof(Lisp_Object);
2529 /* leave room for stuff after us,
2530 * we call a function on this, so leave plenty of space */
2534 Lisp_Object __vals[leni], *vals, result;
2535 struct gcpro gcpro1, gcpro2, gcpro3;
2537 if (UNLIKELY(leni == 0)) {
2538 vals = xnew_array(Lisp_Object, nmin);
2543 /* initialise the value space */
2544 memset(vals, 0, nmin * sizeof(Lisp_Object));
2545 /* initialise the iterators */
2546 for (size_t i = 0; i < nseqs; i++) {
2547 seq_iter_init((seq_t)seqs[i], &its[i]);
2550 GCPRO1nn(fun, vals, nmin, seqs, nseqs);
2551 if (UNLIKELY(NILP(fun))) {
2552 for (size_t i = 0; i < nmin; i++) {
2553 Lisp_Object args[nseqs];
2556 seq_iter_next(&its[0], (void**)&args[0]);
2558 seq_iter_next(&its[1], (void**)&args[1]);
2559 /* ... and the rest */
2560 for (size_t j = 2; j < nseqs; j++) {
2561 seq_iter_next(&its[j], (void**)&args[j]);
2564 ? gluef(countof(args), args)
2565 : Flist(countof(args), args);
2568 for (size_t i = 0; i < nmin; i++) {
2569 Lisp_Object args[nseqs+1];
2572 seq_iter_next(&its[0], (void**)&args[1]);
2574 seq_iter_next(&its[1], (void**)&args[2]);
2575 /* ... and the rest */
2576 for (size_t j = 2; j < nseqs; j++) {
2577 seq_iter_next(&its[j], (void**)&args[j+1]);
2580 vals[i] = Ffuncall(countof(args), args);
2585 /* deinitialise the iterators */
2586 for (size_t i = 0; i < nseqs; i++) {
2587 seq_iter_fini(&its[i]);
2590 result = __dress_result(result_type, vals, nmin);
2591 if (UNLIKELY(leni == 0)) {
2597 static inline size_t
2598 __arity_cross_sum(size_t arity[], size_t narity)
2600 size_t res = arity[0];
2601 for (size_t j = 1; j < narity; j++) {
2608 __explode_n(seq_iter_t si, void *tgt[], size_t n)
2610 /* explodes the sequence in SI N times, puts the stuff into tgt,
2611 * consequently tgt[] is N elements richer thereafter */
2613 seq_iter_next(si, &tgt[0]);
2614 for (size_t j = 1; j < n; j++) {
2615 seq_iter_next(si, &tgt[j]);
2621 __pntw_nseq2(Lisp_Object seqs[], size_t nseqs, Lisp_Object fun,
2622 glue_f gluef, Lisp_Object result_type, size_t arity[])
2624 size_t nmin = __nfam_min_size_a(seqs, nseqs, arity);
2625 /* C99 we need you */
2626 struct seq_iter_s its[nseqs];
2627 size_t aXsum = __arity_cross_sum(arity, nseqs);
2628 size_t maxsz = __sys_stk_free() / sizeof(Lisp_Object);
2630 /* leave room for stuff after us,
2631 * we call a function on this, so leave plenty of space */
2635 Lisp_Object __vals[leni], *vals, result;
2636 struct gcpro gcpro1, gcpro2, gcpro3;
2638 if (UNLIKELY(leni == 0)) {
2639 vals = xnew_array(Lisp_Object, nmin);
2644 /* initialise the value space */
2645 memset(vals, 0, nmin * sizeof(Lisp_Object));
2646 /* initialise the iterators */
2647 for (size_t i = 0; i < nseqs; i++) {
2648 seq_iter_init((seq_t)seqs[i], &its[i]);
2651 GCPRO1nn(fun, vals, nmin, seqs, nseqs);
2652 if (UNLIKELY(NILP(fun))) {
2653 for (size_t i = 0; i < nmin; i++) {
2654 Lisp_Object args[aXsum];
2657 /* partially unroll this, as we know that it's
2658 * definitely one seq to consider */
2659 __explode_n(&its[0], (void**)&args[0], off = arity[0]);
2660 /* ... actually we know it's even more than one
2661 * seq otherwise we'd be in the 1seq counterpart
2663 __explode_n(&its[1], (void**)&args[off], arity[1]);
2664 for (j = 2, off += arity[1];
2665 j < nseqs; off += arity[j++]) {
2667 &its[j], (void**)&args[off], arity[j]);
2670 ? gluef(countof(args), args)
2671 : Flist(countof(args), args);
2674 for (size_t i = 0; i < nmin; i++) {
2675 Lisp_Object args[aXsum+1];
2678 /* partially unroll this, as we know that it's
2679 * definitely one seq to consider */
2680 __explode_n(&its[0], (void**)&args[1], off = arity[0]);
2681 /* ... actually we know it's even more than one
2682 * seq otherwise we'd be in the 1seq counterpart
2684 __explode_n(&its[1], (void**)&args[++off], arity[1]);
2685 for (j = 2, off += arity[1];
2686 j < nseqs; off += arity[j++]) {
2688 &its[j], (void**)&args[off], arity[j]);
2691 vals[i] = Ffuncall(countof(args), args);
2696 /* deinitialise the iterators */
2697 for (size_t i = 0; i < nseqs; i++) {
2698 seq_iter_fini(&its[i]);
2701 result = __dress_result(result_type, vals, nmin);
2702 if (UNLIKELY(leni == 0)) {
2709 __cart_nseq(Lisp_Object seqs[], size_t nseqs, Lisp_Object fun, size_t arity,
2710 glue_f gf, Lisp_Object result_type)
2712 /* defaults to arity 1,1,...,1
2713 * there is no __comb_nseq() as combinations are defined to be
2714 * (cart (comb s1) (comb s2) ...), so in the arity 1,1,...,1 case this
2715 * equals __cart_nseq() */
2716 size_t nseqsz[nseqs];
2717 size_t nsum, ncart, l = 0;
2718 size_t nsz = __nfam_cart_sum_size(&nsum, &ncart, nseqsz, seqs, nseqs);
2719 /* C99 we need you */
2720 Lisp_Object *expls[nseqs];
2721 long int idx[nseqs]; /* the multi index */
2722 Lisp_Object fc[nseqs+1], *v = &fc[1];
2723 size_t maxsz = __sys_stk_free() / sizeof(Lisp_Object);
2725 /* leave room for stuff after us,
2726 * we call a function on this, so leave plenty of space */
2730 Lisp_Object __vals[leni], *vals, result;
2731 struct gcpro gcpro1, gcpro2, gcpro3;
2733 /* catch some horst cases */
2735 return __dress_result(result_type, NULL, 0);
2736 } /* actually now we ought to catch the case ncart == nsum
2737 * which is nseqs == 1 */
2739 if (UNLIKELY(leni == 0)) {
2740 vals = xnew_array(Lisp_Object, nsz);
2745 /* initialise the value space */
2746 memset(vals, 0, nsz * sizeof(Lisp_Object));
2747 /* initialise the explosion pointers */
2748 expls[0] = &vals[ncart];
2749 seq_explode((void**)expls[0], nseqsz[0], (seq_t)seqs[0]);
2750 expls[1] = expls[0] + nseqsz[0];
2751 seq_explode((void**)expls[1], nseqsz[1], (seq_t)seqs[1]);
2752 for (size_t i = 2; i < nseqs; i++) {
2753 expls[i] = expls[i-1] + nseqsz[i-1];
2754 seq_explode((void**)expls[i], nseqsz[i], (seq_t)seqs[i]);
2756 /* setup multiindex */
2757 memset(idx, 0, nseqs * sizeof(long int));
2760 GCPRO1nn(fun, vals, nsz, seqs, nseqs);
2761 if (LIKELY(!NILP(fun) && gf == NULL)) {
2763 /* fetch the data from the explosions, p-unrolled */
2764 v[0] = expls[0][idx[0]];
2765 v[1] = expls[1][idx[1]];
2766 for (size_t i = 2; i < nseqs; i++) {
2767 v[i] = expls[i][idx[i]];
2770 vals[l++] = Ffuncall(countof(fc), fc);
2771 /* advance the multi-index */
2772 __advance_multi_index_2(idx, countof(idx), nseqsz);
2774 } else if (LIKELY(!NILP(fun))) {
2776 /* fetch the data from the explosions, p-unrolled */
2777 v[0] = expls[0][idx[0]];
2778 v[1] = expls[1][idx[1]];
2779 for (size_t i = 2; i < nseqs; i++) {
2780 v[i] = expls[i][idx[i]];
2783 v[0] = gf(countof(idx), v);
2785 vals[l++] = Ffuncall(2, fc);
2786 /* advance the multi-index */
2787 __advance_multi_index_2(idx, countof(idx), nseqsz);
2790 glue_f tgf = gf ? gf : Flist;
2792 /* fetch the data from the explosions, p-unrolled */
2793 v[0] = expls[0][idx[0]];
2794 v[1] = expls[1][idx[1]];
2795 for (size_t i = 2; i < nseqs; i++) {
2796 v[i] = expls[i][idx[i]];
2799 vals[l++] = tgf(countof(idx), v);
2800 /* advance the multi-index */
2801 __advance_multi_index_2(idx, countof(idx), nseqsz);
2806 result = __dress_result(result_type, vals, ncart);
2807 if (UNLIKELY(leni == 0)) {
2814 __cart_nseq2(Lisp_Object seqs[], size_t nseqs, Lisp_Object fun,
2815 glue_f gf, Lisp_Object result_type, size_t arity[])
2817 size_t nseqsz[nseqs];
2818 size_t nsum, ncart, midxsz /* size of the multi index */, l = 0;
2819 size_t nsz = __nfam_cart_sum_size_a(
2820 &nsum, &ncart, &midxsz, nseqsz, seqs, nseqs, arity);
2821 /* C99 we need you */
2822 Lisp_Object *expls[nseqs];
2823 long int idx[midxsz]; /* the multi index */
2824 Lisp_Object fc[midxsz+1], *v = &fc[1];
2825 size_t maxsz = __sys_stk_free() / sizeof(Lisp_Object);
2827 /* leave room for stuff after us,
2828 * we call a function on this, so leave plenty of space */
2832 Lisp_Object __vals[leni], *vals, result;
2833 struct gcpro gcpro1, gcpro2, gcpro3;
2835 /* catch some horst cases */
2837 return __dress_result(result_type, NULL, 0);
2838 } /* actually now we ought to catch the case ncart == nsum
2839 * which is nseqs == 1 */
2841 if (UNLIKELY(leni == 0)) {
2842 vals = xnew_array(Lisp_Object, nsz);
2847 /* initialise the value space */
2848 memset(vals, 0, nsz * sizeof(Lisp_Object));
2849 /* initialise the explosion pointers */
2850 expls[0] = &vals[ncart];
2851 seq_explode((void**)expls[0], nseqsz[0], (seq_t)seqs[0]);
2852 expls[1] = expls[0] + nseqsz[0];
2853 seq_explode((void**)expls[1], nseqsz[1], (seq_t)seqs[1]);
2854 for (size_t i = 2; i < nseqs; i++) {
2855 expls[i] = expls[i-1] + nseqsz[i-1];
2856 seq_explode((void**)expls[i], nseqsz[i], (seq_t)seqs[i]);
2858 /* setup multiindex */
2859 memset(idx, 0, countof(idx) * sizeof(long int));
2862 GCPRO1nn(fun, vals, nsz, seqs, nseqs);
2863 if (LIKELY(!NILP(fun) && gf == NULL)) {
2866 /* fetch the data from the explosions, p-unrolled */
2867 v[0] = expls[0][idx[0]];
2868 for (slot = 1; slot < arity[0]; slot++) {
2869 /* offload arity[0] slots onto v */
2870 v[slot] = expls[0][idx[slot]];
2872 /* continue with the next arity[1] slots */
2873 v[slot] = expls[1][idx[slot]];
2875 for (size_t j = 1; j < arity[1]; slot++, j++) {
2876 v[slot] = expls[1][idx[slot]];
2878 /* now the rest of the crowd */
2879 for (size_t i = 2; i < nseqs; i++) {
2880 v[slot] = expls[i][idx[slot]];
2882 for (size_t j = 1; j < arity[i]; slot++, j++) {
2883 v[slot] = expls[i][idx[slot]];
2887 vals[l++] = Ffuncall(countof(fc), fc);
2888 /* advance the multi-index */
2889 __advance_multi_index_3(
2890 idx, countof(idx), nseqsz, nseqs, arity);
2892 } else if (LIKELY(!NILP(fun))) {
2895 /* fetch the data from the explosions, p-unrolled */
2896 v[0] = expls[0][idx[0]];
2897 for (slot = 1; slot < arity[0]; slot++) {
2898 /* offload arity[0] slots onto v */
2899 v[slot] = expls[0][idx[slot]];
2901 /* continue with the next arity[1] slots */
2902 v[slot] = expls[1][idx[slot]];
2904 for (size_t j = 1; j < arity[1]; slot++, j++) {
2905 v[slot] = expls[1][idx[slot]];
2907 /* now the rest of the crowd */
2908 for (size_t i = 2; i < nseqs; i++) {
2909 v[slot] = expls[i][idx[slot]];
2911 for (size_t j = 1; j < arity[i]; slot++, j++) {
2912 v[slot] = expls[i][idx[slot]];
2916 v[0] = gf(countof(idx), v);
2918 vals[l++] = Ffuncall(2, fc);
2919 /* advance the multi-index */
2920 __advance_multi_index_3(
2921 idx, countof(idx), nseqsz, nseqs, arity);
2924 glue_f tgf = gf ? gf : Flist;
2927 /* fetch the data from the explosions, p-unrolled */
2928 v[0] = expls[0][idx[0]];
2929 for (slot = 1; slot < arity[0]; slot++) {
2930 /* offload arity[0] slots onto v */
2931 v[slot] = expls[0][idx[slot]];
2933 /* continue with the next arity[1] slots */
2934 v[slot] = expls[1][idx[slot]];
2936 for (size_t j = 1; j < arity[1]; slot++, j++) {
2937 v[slot] = expls[1][idx[slot]];
2939 /* now the rest of the crowd */
2940 for (size_t i = 2; i < nseqs; i++) {
2941 v[slot] = expls[i][idx[slot]];
2943 for (size_t j = 1; j < arity[i]; slot++, j++) {
2944 v[slot] = expls[i][idx[slot]];
2948 vals[l++] = tgf(countof(idx), v);
2949 /* advance the multi-index */
2950 __advance_multi_index_3(
2951 idx, countof(idx), nseqsz, nseqs, arity);
2956 result = __dress_result(result_type, vals, ncart);
2957 if (UNLIKELY(leni == 0)) {
2964 __comb_nseq2(Lisp_Object seqs[], size_t nseqs, Lisp_Object fun,
2965 glue_f gf, Lisp_Object result_type, size_t arity[])
2967 /* this is the dodgiest one, since
2968 * comb(seq1, seq2, ..., seqn) => cart(comb(seq1), comb(seq2), ..., comb(seqn))
2970 size_t nseqsz[nseqs];
2971 size_t nsum, ncomb, midxsz /* size of the multi index */, l = 0;
2972 /* computes the size of the cartesian set, the maximum size of
2973 * the union set and the multiplicity of the multi-index (which is the
2974 * cross sum of the arity array) returns the sum of cartesian and union,
2975 * and puts intermediately computed family sizes into nseqsz[] */
2976 size_t nsz = __nfam_comb_sum_size_a(
2977 &nsum, &ncomb, &midxsz, nseqsz, seqs, nseqs, arity);
2978 /* C99 we need you */
2979 Lisp_Object *expls[nseqs];
2980 /* the multi indices, we have a big one, and a custom one */
2981 size_t __midx[midxsz], *midx[nseqs]; /* the multi indices */
2982 Lisp_Object fc[midxsz+1], *v = &fc[1];
2983 size_t maxsz = __sys_stk_free() / sizeof(Lisp_Object);
2985 /* leave room for stuff after us,
2986 * we call a function on this, so leave plenty of space */
2990 Lisp_Object __vals[leni], *vals, result;
2991 struct gcpro gcpro1, gcpro2, gcpro3;
2993 /* catch some horst cases */
2995 return __dress_result(result_type, NULL, 0);
2996 } /* actually now we ought to catch the case ncart == nsum
2997 * which is nseqs == 1 */
2999 if (UNLIKELY(leni == 0)) {
3000 vals = xnew_array(Lisp_Object, nsz);
3005 /* initialise the value space */
3006 memset(vals, 0, nsz * sizeof(Lisp_Object));
3007 /* initialise the explosion pointers and ... */
3008 expls[0] = &vals[ncomb];
3009 seq_explode((void**)expls[0], nseqsz[0], (seq_t)seqs[0]);
3010 expls[1] = expls[0] + nseqsz[0];
3011 seq_explode((void**)expls[1], nseqsz[1], (seq_t)seqs[1]);
3012 /* ... the multi-multi-index */
3013 midx[0] = &__midx[0];
3014 __initialise_multi_index(midx[0], arity[0]);
3015 midx[1] = &__midx[arity[0]];
3016 __initialise_multi_index(midx[1], arity[1]);
3017 /* and the rest of the explosion pointers, gosh, that's going
3018 * to be an Index War */
3019 for (size_t i = 2; i < nseqs; i++) {
3020 expls[i] = expls[i-1] + nseqsz[i-1];
3021 seq_explode((void**)expls[i], nseqsz[i], (seq_t)seqs[i]);
3022 midx[i] = &__midx[arity[i-1]];
3023 __initialise_multi_index(midx[i], arity[i]);
3028 GCPRO1nn(fun, vals, nsz, seqs, nseqs);
3029 if (LIKELY(!NILP(fun) && gf == NULL)) {
3032 /* fetch the data from the explosions, p-unrolled */
3033 v[0] = expls[0][__midx[0]];
3034 for (slot = 1; slot < arity[0]; slot++) {
3035 /* offload arity[0] slots onto v */
3036 v[slot] = expls[0][__midx[slot]];
3038 /* continue with the next arity[1] slots */
3039 v[slot] = expls[1][__midx[slot]];
3041 for (size_t j = 1; j < arity[1]; slot++, j++) {
3042 v[slot] = expls[1][__midx[slot]];
3044 /* now the rest of the crowd */
3045 for (size_t i = 2; i < nseqs; i++) {
3046 v[slot] = expls[i][__midx[slot]];
3048 for (size_t j = 1; j < arity[i]; slot++, j++) {
3049 v[slot] = expls[i][__midx[slot]];
3053 vals[l++] = Ffuncall(countof(fc), fc);
3054 /* advance the multi-index */
3055 __advance_multi_index_4(midx, nseqsz, nseqs, arity);
3057 } else if (LIKELY(!NILP(fun))) {
3060 /* fetch the data from the explosions, p-unrolled */
3061 v[0] = expls[0][__midx[0]];
3062 for (slot = 1; slot < arity[0]; slot++) {
3063 /* offload arity[0] slots onto v */
3064 v[slot] = expls[0][__midx[slot]];
3066 /* continue with the next arity[1] slots */
3067 v[slot] = expls[1][__midx[slot]];
3069 for (size_t j = 1; j < arity[1]; slot++, j++) {
3070 v[slot] = expls[1][__midx[slot]];
3072 /* now the rest of the crowd */
3073 for (size_t i = 2; i < nseqs; i++) {
3074 v[slot] = expls[i][__midx[slot]];
3076 for (size_t j = 1; j < arity[i]; slot++, j++) {
3077 v[slot] = expls[i][__midx[slot]];
3081 v[0] = gf(countof(__midx), v);
3083 vals[l++] = Ffuncall(2, fc);
3084 /* advance the multi-index */
3085 __advance_multi_index_4(midx, nseqsz, nseqs, arity);
3088 glue_f tgf = gf ? gf : Flist;
3093 /* fetch the data from the explosions, p-unrolled */
3094 v[0] = expls[0][__midx[0]];
3095 for (slot = 1; slot < arity[0]; slot++) {
3096 /* offload arity[0] slots onto v */
3097 v[slot] = expls[0][__midx[slot]];
3099 /* continue with the next arity[1] slots */
3100 v[slot] = expls[1][__midx[slot]];
3102 for (size_t j = 1; j < arity[1]; slot++, j++) {
3103 v[slot] = expls[1][__midx[slot]];
3105 /* now the rest of the crowd */
3106 for (size_t i = 2; i < nseqs; i++) {
3107 v[slot] = expls[i][__midx[slot]];
3109 for (size_t j = 1; j < arity[i]; slot++, j++) {
3110 v[slot] = expls[i][__midx[slot]];
3114 vals[l++] = tgf(countof(__midx), v);
3115 /* advance the multi-index */
3116 __advance_multi_index_4(midx, nseqsz, nseqs, arity);
3121 result = __dress_result(result_type, vals, ncomb);
3122 if (UNLIKELY(leni == 0)) {
3129 __perm_nseq(Lisp_Object seqs[], size_t nseqs, Lisp_Object fun, size_t arity,
3130 glue_f gf, Lisp_Object result_type)
3132 /* defaults to arity 1,1,...,1 */
3133 size_t nseqsz[nseqs];
3134 size_t ns, ncp, np, l = 0;
3135 size_t nsz = __nfam_perm_sum_size(&ns, &ncp, &np, nseqsz, seqs, nseqs);
3136 /* C99 we need you */
3137 Lisp_Object *expls[nseqs];
3138 long int idx[nseqs]; /* the multi index */
3139 Lisp_Object fc[nseqs+1], *v = &fc[1];
3140 size_t maxsz = __sys_stk_free() / sizeof(Lisp_Object);
3142 /* leave room for stuff after us,
3143 * we call a function on this, so leave plenty of space */
3147 Lisp_Object __vals[leni], *vals, result;
3148 struct gcpro gcpro1, gcpro2, gcpro3;
3150 /* catch some horst cases */
3152 return __dress_result(result_type, NULL, 0);
3153 } /* actually now we ought to catch the case nperm == nsum
3154 * which is nseqs == 1 */
3156 if (UNLIKELY(leni == 0)) {
3157 vals = xnew_array(Lisp_Object, nsz);
3162 /* initialise the value space */
3163 memset(vals, 0, nsz * sizeof(Lisp_Object));
3164 /* initialise the explosion pointers */
3165 expls[0] = &vals[ncp];
3166 seq_explode((void**)expls[0], nseqsz[0], (seq_t)seqs[0]);
3167 expls[1] = expls[0] + nseqsz[0];
3168 seq_explode((void**)expls[1], nseqsz[1], (seq_t)seqs[1]);
3169 for (size_t i = 2; i < nseqs; i++) {
3170 expls[i] = expls[i-1] + nseqsz[i-1];
3171 seq_explode((void**)expls[i], nseqsz[i], (seq_t)seqs[i]);
3173 /* setup multiindex */
3174 memset(idx, 0, nseqs * sizeof(long int));
3177 GCPRO1nn(fun, vals, nsz, seqs, nseqs);
3180 if (LIKELY(!NILP(fun) && gf == NULL)) {
3182 /* fetch the data from the explosions */
3183 v[0] = expls[0][idx[0]];
3184 v[1] = expls[1][idx[1]];
3185 l = __2perm_fun(vals, 2, v, 2, fun, l);
3186 /* advance the multi-index */
3187 __advance_multi_index_2(idx, 2, nseqsz);
3190 } else if (LIKELY(!NILP(fun))) {
3192 /* fetch the data from the explosions */
3193 v[0] = expls[0][idx[0]];
3194 v[1] = expls[1][idx[1]];
3195 l = __2perm_glue_fun(vals, 2, v, 2, fun, gf, l);
3196 /* advance the multi-index */
3197 __advance_multi_index_2(idx, 2, nseqsz);
3201 glue_f tgf = gf ? gf : Flist;
3203 /* fetch the data from the explosions */
3204 v[0] = expls[0][idx[0]];
3205 v[1] = expls[1][idx[1]];
3206 l = __2perm_glue(vals, 2, v, 2, tgf, l);
3207 /* advance the multi-index */
3208 __advance_multi_index_2(idx, 2, nseqsz);
3214 if (LIKELY(!NILP(fun) && gf == NULL)) {
3216 /* fetch the data from the explosions */
3217 v[0] = expls[0][idx[0]];
3218 v[1] = expls[1][idx[1]];
3219 v[2] = expls[2][idx[2]];
3220 l = __3perm_fun(vals, 0, v, 3, fun, l);
3221 /* advance the multi-index */
3222 __advance_multi_index_2(idx, 3, nseqsz);
3224 } else if (LIKELY(!NILP(fun))) {
3226 /* fetch the data from the explosions */
3227 v[0] = expls[0][idx[0]];
3228 v[1] = expls[1][idx[1]];
3229 v[2] = expls[2][idx[2]];
3230 l = __3perm_glue_fun(vals, 0, v, 3, fun, gf, l);
3231 /* advance the multi-index */
3232 __advance_multi_index_2(idx, 3, nseqsz);
3235 glue_f tgf = gf ? gf : Flist;
3237 /* fetch the data from the explosions */
3238 v[0] = expls[0][idx[0]];
3239 v[1] = expls[1][idx[1]];
3240 v[2] = expls[2][idx[2]];
3241 l = __3perm_glue(vals, 0, v, 3, tgf, l);
3242 /* advance the multi-index */
3243 __advance_multi_index_2(idx, 3, nseqsz);
3249 if (LIKELY(!NILP(fun) && gf == NULL)) {
3251 /* fetch the data from the explosions */
3252 v[0] = expls[0][idx[0]];
3253 v[1] = expls[1][idx[1]];
3254 for (size_t i = 2; i < nseqs; i++) {
3255 v[i] = expls[i][idx[i]];
3257 /* have Sn operating */
3258 l = __Sn_fun(vals, np, v, nseqs, fun, l);
3259 /* advance the multi-index */
3260 __advance_multi_index_2(idx, nseqs, nseqsz);
3262 } else if (LIKELY(!NILP(fun))) {
3264 /* fetch the data from the explosions */
3265 v[0] = expls[0][idx[0]];
3266 v[1] = expls[1][idx[1]];
3267 for (size_t i = 2; i < nseqs; i++) {
3268 v[i] = expls[i][idx[i]];
3270 /* have Sn operating */
3272 vals, np, v, nseqs, fun, gf, l);
3273 /* advance the multi-index */
3274 __advance_multi_index_2(idx, nseqs, nseqsz);
3277 glue_f tgf = gf ? gf : Flist;
3279 /* fetch the data from the explosions */
3280 v[0] = expls[0][idx[0]];
3281 v[1] = expls[1][idx[1]];
3282 for (size_t i = 2; i < nseqs; i++) {
3283 v[i] = expls[i][idx[i]];
3285 /* have Sn operating */
3286 l = __Sn_glue(vals, np, v, nseqs, tgf, l);
3287 /* advance the multi-index */
3288 __advance_multi_index_2(idx, nseqs, nseqsz);
3295 result = __dress_result(result_type, vals, ncp);
3296 if (UNLIKELY(leni == 0)) {
3303 __perm_nseq2(Lisp_Object seqs[], size_t nseqs, Lisp_Object fun,
3304 glue_f gf, Lisp_Object result_type, size_t arity[])
3306 /* this is the utmost dodgiest one, since
3307 * perm(seq1, seq2, ..., seqn) => perm(comb(seq1, seq2, ..., seqn))
3309 size_t nseqsz[nseqs];
3310 size_t nsum, nvar, nperm, midxsz /* size of the multi index */, l = 0;
3311 /* computes the size of the cartesian set, the maximum size of
3312 * the union set and the multiplicity of the multi-index (which is the
3313 * cross sum of the arity array) returns the sum of cartesian and union,
3314 * and puts intermediately computed family sizes into nseqsz[] */
3315 size_t nsz = __nfam_perm_sum_size_a(
3316 &nsum, &nvar, &nperm, &midxsz, nseqsz, seqs, nseqs, arity);
3317 /* C99 we need you */
3318 Lisp_Object *expls[nseqs];
3319 /* the multi indices, we have a big one, and a custom one */
3320 size_t __midx[midxsz], *midx[nseqs]; /* the multi indices */
3321 Lisp_Object v[midxsz + 2 /*to survive the aggressive loop unrolling*/];
3322 size_t maxsz = __sys_stk_free() / sizeof(Lisp_Object);
3324 /* leave room for stuff after us,
3325 * we call a function on this, so leave plenty of space */
3329 Lisp_Object __vals[leni], *vals, result;
3330 struct gcpro gcpro1, gcpro2, gcpro3;
3332 /* catch some horst cases */
3334 return __dress_result(result_type, NULL, 0);
3335 } /* actually now we ought to catch the case ncart == nsum
3336 * which is nseqs == 1 */
3338 if (UNLIKELY(leni == 0)) {
3339 vals = xnew_array(Lisp_Object, nsz);
3344 /* initialise the value space */
3345 memset(vals, 0, nsz * sizeof(Lisp_Object));
3346 /* initialise the explosion pointers and ... */
3347 expls[0] = &vals[nvar];
3348 seq_explode((void**)expls[0], nseqsz[0], (seq_t)seqs[0]);
3349 expls[1] = expls[0] + nseqsz[0];
3350 seq_explode((void**)expls[1], nseqsz[1], (seq_t)seqs[1]);
3351 /* ... the multi-multi-index */
3352 midx[0] = &__midx[0];
3353 __initialise_multi_index(midx[0], arity[0]);
3354 midx[1] = &__midx[arity[0]];
3355 __initialise_multi_index(midx[1], arity[1]);
3356 /* ... the multi-multi-index */
3357 midx[0] = &__midx[0];
3358 __initialise_multi_index(midx[0], arity[0]);
3359 /* and the rest of the explosion pointers, gosh, that's going
3360 * to be an Index War */
3361 for (size_t i = 2; i < nseqs; i++) {
3362 expls[i] = expls[i-1] + nseqsz[i-1];
3363 seq_explode((void**)expls[i], nseqsz[i], (seq_t)seqs[i]);
3364 midx[i] = &__midx[arity[i-1]];
3365 __initialise_multi_index(midx[i], arity[i]);
3368 GCPRO1nn(fun, vals, nsz, seqs, nseqs);
3369 /* actually we would have to distinguish between cross_sum(arity) >= 4
3370 * and == 3 and == 2, because the __Sn functions unroll at least 3
3371 * iterations, howbeit it seems to work so we stick with this for now */
3372 if (LIKELY(!NILP(fun) && gf == NULL)) {
3375 /* fetch the data from the explosions, p-unrolled */
3376 v[0] = expls[0][__midx[0]];
3377 for (slot = 1; slot < arity[0]; slot++) {
3378 /* offload arity[0] slots onto v */
3379 v[slot] = expls[0][__midx[slot]];
3381 /* continue with the next arity[1] slots */
3382 v[slot] = expls[1][__midx[slot]];
3384 for (size_t j = 1; j < arity[1]; slot++, j++) {
3385 v[slot] = expls[1][__midx[slot]];
3387 /* now the rest of the crowd */
3388 for (size_t i = 2; i < nseqs; i++) {
3389 v[slot] = expls[i][__midx[slot]];
3391 for (size_t j = 1; j < arity[i]; slot++, j++) {
3392 v[slot] = expls[i][__midx[slot]];
3395 /* do the rain dance */
3396 l = __Sn_fun(vals, nperm, v, midxsz, fun, l);
3397 /* advance the multi-index */
3398 __advance_multi_index_4(midx, nseqsz, nseqs, arity);
3400 } else if (LIKELY(!NILP(fun))) {
3403 /* fetch the data from the explosions, p-unrolled */
3404 v[0] = expls[0][__midx[0]];
3405 for (slot = 1; slot < arity[0]; slot++) {
3406 /* offload arity[0] slots onto v */
3407 v[slot] = expls[0][__midx[slot]];
3409 /* continue with the next arity[1] slots */
3410 v[slot] = expls[1][__midx[slot]];
3412 for (size_t j = 1; j < arity[1]; slot++, j++) {
3413 v[slot] = expls[1][__midx[slot]];
3415 /* now the rest of the crowd */
3416 for (size_t i = 2; i < nseqs; i++) {
3417 v[slot] = expls[i][__midx[slot]];
3419 for (size_t j = 1; j < arity[i]; slot++, j++) {
3420 v[slot] = expls[i][__midx[slot]];
3423 /* do the rain dance */
3424 l = __Sn_glue_fun(vals, nperm, v, midxsz, fun, gf, l);
3425 /* advance the multi-index */
3426 __advance_multi_index_4(midx, nseqsz, nseqs, arity);
3429 glue_f tgf = gf ? gf : Flist;
3434 /* fetch the data from the explosions, p-unrolled */
3435 v[0] = expls[0][__midx[0]];
3436 for (slot = 1; slot < arity[0]; slot++) {
3437 /* offload arity[0] slots onto v */
3438 v[slot] = expls[0][__midx[slot]];
3440 /* continue with the next arity[1] slots */
3441 v[slot] = expls[1][__midx[slot]];
3443 for (size_t j = 1; j < arity[1]; slot++, j++) {
3444 v[slot] = expls[1][__midx[slot]];
3446 /* now the rest of the crowd */
3447 for (size_t i = 2; i < nseqs; i++) {
3448 v[slot] = expls[i][__midx[slot]];
3450 for (size_t j = 1; j < arity[i]; slot++, j++) {
3451 v[slot] = expls[i][__midx[slot]];
3454 /* do the rain dance */
3455 l = __Sn_glue(vals, nperm, v, midxsz, tgf, l);
3456 /* advance the multi-index */
3457 __advance_multi_index_4(midx, nseqsz, nseqs, arity);
3462 result = __dress_result(result_type, vals, nvar);
3463 if (UNLIKELY(leni == 0)) {
3470 static inline glue_f
3471 _obtain_glue(Lisp_Object glue)
3472 __attribute__((always_inline));
3473 static inline glue_f
3474 _obtain_glue(Lisp_Object glue)
3476 if (EQ(glue, Qlist)) {
3478 } else if (EQ(glue, Qdllist)) {
3480 } else if (EQ(glue, Qvector)) {
3482 } else if (EQ(glue, Qstring)) {
3484 } else if (EQ(glue, Qconcat)) {
3492 _maybe_downgrade(Lisp_Object *arity)
3494 bool downgrade = !NILP(*arity) && CONSP(*arity);
3497 for (Lisp_Object tmp = *arity; CONSP(tmp); i++, tmp = XCDR(tmp)) {
3498 if (UNLIKELY(!NATNUMP(XCAR(tmp)) || XCAR(tmp) == Qzero)) {
3499 signal_simple_error(
3500 ":arity does not specify a valid multi-index",
3502 } else if (XCAR(tmp) != Qone) {
3506 if (LIKELY(i != 1 && !downgrade)) {
3508 } else if (UNLIKELY(i == 1)) {
3509 *arity = XCAR(*arity);
3511 } else if (UNLIKELY(downgrade)) {
3520 DEFUN("mapfam", Fmapfam, 1, MANY, 0, /*
3521 Apply FUNCTION to elements in FAMILIES and collect the results
3525 FUNCTION &rest FAMILIES &key :result-type :mode :arity :glue
3526 :initiator :separator :terminator
3528 The first argument FUNCTION is the function to use for the map.
3529 If FUNCTION is `nil' the function #\'identity or one of its glue
3530 counterparts (see :glue) is implicitly used. This can be used
3531 to convert one family to another, see examples below.
3533 The rest of the arguments are FAMILIES, where a family is a
3534 sequence \(see `sequencep'\) or a dict-like map (hash-table,
3535 skiplist, etc.). The family types need not coincide.
3537 Keys may be specified as in :key value [:key value [...]], all
3538 keys are optional and may appear anywhere. In greater detail:
3540 :result-type specifies the container type of the result object, can be:
3541 - #'list to yield a list (default)
3542 - #'dllist to yield a dllist
3543 - #'vector to yield a vector
3544 - #'string to yield a string iff FUNCTION returns characters or
3545 integers within the character range
3546 - #'concat to yield a string iff FUNCTION returns character arrays or
3547 arrays of integers within the character range
3548 - #'bit-vector to yield a bit-vector, FUNCTION's return values will
3549 be treated 1 iff non-nil, and 0 otherwise.
3550 - 'litter or 'void to not collect the results at all
3551 - 'inplace to modify the first family in FAMILIES by side-effect if
3552 it is a sequence, and modify the value destructively if it is a
3553 dict. This works only in pointwise mode, see :mode.
3555 Generally, the result-type is a functor (most often a constructor)
3556 to be applied on the produced output sequence. It behaves as if the
3557 elements of the output sequence had been passed to the constructor
3558 function argument-wise. So it can be thought of as a shortcut to
3559 \(apply #'<constructor> result-sequence\).
3561 In the past result types were specified by the name of the map
3562 function which turned out to be extremely sluggish in case the
3563 result type is parametrised (i.e. passed as parameter).
3565 :mode specifies the way the arguments are passed to FUNCTION, can be:
3566 - 'pointwise or 'pntw (default): given FAMILIES consists of
3567 fam1, fam2, etc. this mode passes the first point of fam1 along
3568 with the first point of fam2 along with etc. to FUNCTION. Hereby
3569 a point is just one element in case the family is a sequence, and
3570 a key-value pair (as two separate arguments) if family is a dict
3571 (and arity does not specify this otherwise).
3572 - 'keywise or 'keyw: like 'pointwise in case of sequences, for dicts
3573 this passes only the key cell to FUNCTION.
3574 - 'cartesian or 'cart: construct the cartesian product of the points
3575 in FAMILIES and pass the resulting tuples to FUNCTION.
3576 - 'combination or 'comb: construct the set of all combinations of
3577 the points, formally this is the set of (fixed-size) subsets of the
3578 set of points, disregarding different orders.
3579 Note: the implementation will always preserve orders though, that is
3580 the combinatorial subsets of an ordered family will be ordered wrt
3581 to the same overlying order.
3582 - 'permutation or 'perm or 'variation or 'var: construct the set of
3583 all permutations of the points (also known as variations), formally
3584 this is the set of (fixed-size) tuples arising from rearranging
3585 (different ordering) the subsets of the set of points.
3587 Note: The combinatorial modes (cart, comb and perm) produce giant
3588 amounts of data (using glues) or a neverending series of function
3589 calls. In case you are using one of the above modes and pass user
3590 input to #'mapfam or allow your users to specify their own mapping
3591 functions make sure you restrain the (size of the) input arguments.
3593 To give a rough idea of the outcome sizes:
3594 family size arity #combinations #permutations #cartesians
3601 9 7 36 181440 4782969
3602 9 8 9 362880 43046721
3603 9 9 1 362880 387420489
3605 For the number of combinations:
3606 (binomial-coefficient SIZE ARITY)
3607 For the number of permutations:
3608 (* (binomial-coeeficient SIZE ARITY) (factorial ARITY))
3609 For the number of points in the cartesian product:
3612 Additional note: SXEmacs' implementation of explicit symmetric group
3613 traversal (wrt a Bruhat-like order) is currently the fastest on the
3614 planet, however it obviously cannot overcome the sheer size of large
3615 symmetric groups. Be aware that explicit unrolling S_11 eats up at
3616 least 300 MB of RAM, unrolling S_12 requires at least 3.6 GB of RAM,
3617 for S_13 it's approx 48 GB and so on.
3619 Additional note: Cartesian products are highly exponential in space
3620 and time complexity. However, unlike permutations (symm. groups)
3621 the cartesian points can be constructed rather easily using nested
3622 loops. So if you are just after a couple of cartesian points do not
3623 bother using mapfam to create them all and filter afterwards but
3624 directly use nested loops to create the points you need.
3626 :arity specifies how to choose and pass points from the families to
3627 FUNCTION. The value of :arity can be a normal index (positive
3628 integer) if there is only one family, and a multi-index if points
3629 are to be picked from multiple families.
3632 - 1 if there is only one family which is not a dictionary and mode
3633 'pointwise or 'combination
3634 - 1 if there is only one family (including dictionaries) and mode is
3636 - 2 if there is only one family and mode is 'cartesian
3637 - the length of the family if there is only one family and mode is
3639 - (1 1) if family is a dictionary and mode is 'pointwise or
3641 - (1 1 ... 1) if there are n families, irrespective of mode.
3643 So it is '(1 1) if two families are given, '(1 1 1) for 3 families
3646 Indices, multi-indices and modes:
3647 The general multi-index form of the :arity keyword specifies how many
3648 points are taking from each family to form a glue cell which is passed
3649 directly to FUNCTION (exploded of course) if that is non-nil, and
3650 passed to the glue if that is nil.
3651 The first index in the arity multi-index list corresponds to the
3652 number of points to choose from the first family, the second one to
3653 the second family respectively and so on.
3654 An ordinary index always refers to the first family irrespective how
3655 many families have been specified.
3657 The exact meaning of this multi-index depends on the mode (see also
3659 - In pointwise or keywise mode, always pick this number of points
3660 or elements (consecutively), example:
3661 Let '(1 2 3 a b c) be the family and 1 its arity, the sequence of
3662 picks goes: 1, 2, 3, a, b, c.
3663 Let '(1 2 3 a b c) be the family and 2 its arity, the sequence of
3664 picks goes: [1 2], [3 a], [b c]
3665 If a cell is not formable because there are too few elements left in
3666 the family the mapping will not take place at all, so be '(1 2 3)
3667 the family and 2 its arity, the sequence of picks goes: [1 2].
3669 Multiple families in pointwise or keywise mode behave similarly
3670 Be '(1 2 3) '(a b c) two families and '(1 1) the arity (which is the
3671 default arity anyway), the pick then goes: [1 a] [2 b] [3 c], which
3672 is exactly how CL's #'map behaves in this situation.
3673 Be '(1 2 3) '(a b c one-more) two families and '(1 1) the arity,
3674 then the pick sequence again is: [1 a] [2 b] [3 c].
3675 In general the family with the least elements determines the number
3676 of picks in this mode.
3678 For arbitrary multi-indices the same rules hold, example:
3679 Let '(1 2 3) '(a b c one-more) be two families and '(1 2) its arity,
3680 then the pick sequence will be: [1 a b] [2 c one-more]
3682 - In cartesian mode, the arity, if an ordinary index, specifies the
3683 number of cartesian copies of the first given family, example:
3684 Let [a b c] be a sequence and arity be 2, then the mapping will
3686 [a a] [a b] [a c] [b a] [b b] [b c] [c a] [c b] [c c]
3688 If given a multi-index the cross sum denotes the total dimension of
3689 the yield while each index specifies the number of copies of the
3690 respective family, so fundamentally each cartesian mapping can be
3691 rewritten by a multi-index consisting solely of ones and
3692 correspondingly many copies of the input families, example:
3693 Let [a b c] and [1 2 3] be two families and '(1 1) the arity, then
3694 the cartesian mode will give:
3695 [a 1] [a 2] [a 3] [b 1] [b 2] [b 3] [c 1] [c 2] [c 3]
3696 Clearly the input sequence [a b c] of arity 2 can be rewritten as
3697 two input sequences [a b c] [a b c] and arity '(1 1) and will yield
3698 the sequence shown above.
3700 Let [a b] and [1 2] be two families and '(1 2) the arity, the result
3702 [a 1 1] [a 1 2] [a 2 1] [a 2 2] [b 1 1] [b 1 2] [b 2 1] [b 2 2]
3704 - In combination mode, the arity, if an ordinary index, specifies the
3705 combination size, example:
3706 Let \'(1 2 3 a) be the input sequence and 2 its arity, then the
3707 sequence of picks goes:
3708 [1 2] [1 3] [1 a] [2 3] [2 a] [3 a].
3710 A multi-index over several families specifies the subset sizes of
3711 each of the families. The total combination set is then formed by
3712 taking the cartesian product of these, example:
3713 Let [1 2 3] and [a b c] be two sets and '(2 2) the considered arity,
3714 then the first family yields [1 2] [1 3] [2 3] and the second one
3715 [a b] [a c] [b c], thence the final outcome will be:
3716 [1 2 a b] [1 2 a c] [1 2 b c] [1 3 a b] [1 3 a c] [1 3 b c] ...
3718 Again, the combination mode is strictly order-preserving, both
3719 the order of the families (as a sequence of families) and the order
3720 of each family will be preserved upon mapping.
3722 - In permuation mode, an ordinary index as arity will specify the
3723 cardinality, read size, of the combinatorial subset which will
3725 Note: the default arity for the permutation mode if just one
3726 sequence is given is the length of this sequence!
3729 Let \'(a b c) be a family and no arity be given, then the sequence
3731 [a b c] [a c b] [b a c] [b c a] [c a b] [c b a]
3732 Let "abcd" be a family and the arity be 2, then the pick sequence
3734 "ab" "ba" "ac" "ca" "ad" "da" "bc" "cb" "bd" "db" "cd" "dc"
3736 Note: while order 2 and order 3 permutations look carefully
3737 constructed and easily predictable this is not true for higher order
3738 permutations! They are specially designed to be mappable as fast as
3739 possible and seem to have no predictable pattern whatsoever, the
3740 order is based on a 1-orbit representation of the underlying
3741 symmetric group which needs merely one transposition to get from one
3742 orbit element to the next one; for details cf. source code.
3744 If given a multi-index
3745 Let "abc" and "123" be two families and arity (2 2), the pick
3747 (perms-of "ab12"), (perms-of "ab13"), (perms-of "ab23"),
3748 (perms-of "ac12"), (perms-of "ac13"), (perms-of "ac23")
3749 where #'perms-of denotes all permutations of that one give sequence,
3750 and can be implemented as (mapfam nil :mode \'perm <seq>)
3752 :glue when multiple values are to be passed to FUNCTION (or if FUNCTION
3753 is `nil' in particular) this specifies which (container) structure to
3754 use to glue them together.
3755 IOW, if FUNCTION is just a single-valued function but the family, the
3756 arity and/or the mode induce more than just one value, glue can turn
3757 so-called exploded form into a single value. Possible constructors:
3758 - #'list (default) to glue the arguments as lists
3759 - #'vector to glue the arguments as vectors
3760 - #'dllist to glue the arguments as dllists
3761 - #'string to glue the arguments as strings, iff they are characters
3762 - #'concat to glue the arguments as strings from character sequences
3764 In pointwise and keywise mode the result sequence can be decorated:
3766 :initiator insert this object at the beginning of the output sequence
3767 only works in 'pointwise and 'keywise mode
3769 :terminator insert this object at the end of the output sequence
3770 only works in 'pointwise and 'keywise mode
3772 :separator insert this object between each pair of elements of the
3773 output sequence. Use this to mimic a #'mapconcat-like behaviour,
3774 but this works for any sequence not just strings.
3775 only works in 'pointwise and 'keywise mode
3780 Normal mapcar-like behaviour:
3781 \(mapfam #'1+ '(1 2 3 4)\)
3783 \(mapfam #'1+ :result-type 'vector '(1 2 3 4)\)
3785 \(mapfam #'1- :result-type 'dllist [1 2 3 4]\)
3788 Normal mapcar*-like behaviour:
3789 \(mapfam #'+ (1 2 3 4) (10 20 30 40)\)
3791 \(mapfam #'+ [1 2 3 4] (dllist 10 20 30 40) :result-type 'vector\)
3794 Construct an alist from a plist:
3795 \(mapfam #'cons '(a 1 b 2 c 3) :arity 2\)
3796 => ((a . 1) (b . 2) (c . 3))
3797 \(mapfam #'list '(a 1 b 2 c 3) :arity 3 :result-type 'vector\)
3798 => [(a 1 b) (2 c 3)]
3799 \(mapfam nil '(a 1 b 2 c 3) :arity 2 :glue 'list\)
3800 => ((a 1) (b 2) (c 3))
3801 \(mapfam nil '(a 1 b 2 c 3) :arity 2 :glue 'vector :result-type 'dllist\)
3802 => (dllist [a 1] [b 2] [c 3])
3804 Apply cons to 2-sets (subsets of order 2) of a list:
3805 \(mapfam #'cons :mode 'comb :arity 2 '(a b c d)\)
3806 => ((a . b) (a . c) (a . d) (b . c) (b . d) (c . d))
3807 \(mapfam #'cons :mode 'comb :arity 2 '(a b a c)\)
3808 => ((a . b) (a . a) (a . c) (b . a) (b . c) (a . c))
3810 The same for 3-sets (using the automatic glue):
3811 \(mapfam nil :mode 'comb :arity 3 '(a b c d)\)
3812 => ((a b c) (a b d) (b c d))
3813 \(mapfam nil :mode 'comb :arity 3 '(a b c d) :glue 'vector\)
3814 => ([a b c] [a b d] [b c d])
3815 Note: This is exactly what `ncombs' is doing.
3817 Given a tuple of elements determine all combinations of three
3818 elements thereof (the 3-sets of the the tuple):
3819 \(mapfam nil :mode 'comb :arity 3 [a b c d]\)
3820 => ((a b c) (a b d) (a c d) (b c d))
3821 \(mapfam nil :mode 'comb :arity 3 [a b c d e] :glue #'vector\)
3822 => ([a b c] [a b d] [a b e] [a c d] [a c e] [a d e]
3823 [b c d] [b c e] [b d e] [c d e])
3825 Glueing the combinations of two different lists:
3826 \(mapfam nil :mode 'comb '(a b c) '(1 2)\)
3827 => ((a 1) (b 1) (c 1) (a 2) (b 2) (c 2))
3828 \(mapfam nil :mode 'comb '(a b c) '(1 2) :arity '(2 1)\)
3829 => ((a b 1) (a c 1) (b c 1) (a b 2) (a c 2) (b c 2))
3830 \(mapfam nil :mode 'comb '(a b c) '(1 2 3) :arity '(2 2)\)
3831 => ((a b 1 2) (a c 1 2) (b c 1 2)
3832 (a b 1 3) (a c 1 3) (b c 1 3)
3833 (a b 2 3) (a c 2 3) (b c 2 3))
3835 Applying the plus function immediately:
3836 \(mapfam #'+ :mode 'comb '(10 20 30) '(1 2)\)
3837 => (11 21 31 12 22 32)
3838 \(mapfam #'+ :mode 'comb '(10 20 30) '(1 2) :arity '(2 1)\)
3839 => (31 41 51 22 42 52)
3841 Mimicking #'mapconcat:
3842 \(mapconcat #'identity '("the" "inverse" "of" "#'split-string") " "\)
3843 => "the inverse of #'split-string"
3844 \(mapfam nil :separator " " '("the" "inverse" "of" "#'split-string")\)
3845 => ("the" " " "inverse" " " "of" " " "#'split-string")
3846 \(mapfam nil :separator " " :result-type #'concat
3847 '("the inverse of #'split-string")\)
3848 => "the inverse of #'split-string"
3850 Using cartesian mode and #'concat to emulate :separator
3851 \(mapfam #'concat :result-type #'concat :mode 'cartesian
3852 '\("the" "inverse" "of" "#'split-string"\) '(" ")\)
3853 => "the inverse of #'split-string "
3854 \(mapfam #'concat :result-type #'concat :mode 'cartesian
3855 [" "] '\("the" "inverse" "of" "#'split-string"\)\)
3856 => " the inverse of #'split-string"
3858 Note a separator is not exactly like doing cartesian mapping over
3859 two sequences since it affects only pairs of elements and so the
3860 last/first tuple is missing.
3861 However, pointwise mode is still use full if each pair of elements
3862 requires a `different separator'.
3864 \(mapfam #'concat :result-type #'concat :mode 'pointwise
3865 '\("the" "inverse" "of" "#'split-string"\) '(" " "_" "-" "."\)\)
3866 => "the inverse_of-#'split-string."
3869 (int nargs, Lisp_Object *args))
3871 /* this is just one, huuuuge case distinctor */
3872 Lisp_Object fun = Qnil;
3873 Lisp_Object mode = Qnil, arity = Qnil;
3874 Lisp_Object res_type = Qlist;
3875 struct decoration_s deco = {
3876 Qnull_pointer, Qnull_pointer, Qnull_pointer
3878 int nfams = 0, arity_len;
3879 bool found_fun_p = false;
3880 glue_f gluef = NULL;
3882 /* snarf the function */
3883 if (!KEYWORDP(args[0])) {
3887 /* snarf the keys and families */
3888 for (int i = found_fun_p; i < nargs; i++) {
3889 if (EQ(args[i], Q_result_type)) {
3890 res_type = args[++i];
3891 } else if (EQ(args[i], Q_arity)) {
3893 } else if (EQ(args[i], Q_mode)) {
3895 } else if (EQ(args[i], Q_glue)) {
3896 gluef = _obtain_glue(args[++i]);
3897 } else if (EQ(args[i], Q_separator)) {
3898 deco.sep = args[++i];
3899 } else if (EQ(args[i], Q_initiator)) {
3900 deco.ini = args[++i];
3901 } else if (EQ(args[i], Q_terminator)) {
3902 deco.ter = args[++i];
3903 } else if (!found_fun_p) {
3904 /* we found the function cell */
3908 /* must be a family */
3909 args[nfams++] = args[i];
3913 /* check the integrity of the options */
3914 /* first kick the most idiotic situations */
3916 (NILP(fun) && EQ(mode, Qvoid)) ||
3918 /* looks like an exphert is here */
3919 return __dress_result(res_type, NULL, 0);
3921 /* now, fill in default values */
3925 /* degrade a thoroughly fledges '(1 1 ... 1) arity to nil */
3926 arity_len = _maybe_downgrade(&arity);
3928 #define POINTWISEP(mode) \
3929 (EQ(mode, Qpntw) || EQ(mode, Qpointwise) || EQ(mode, Qpoints))
3930 #define KEYWISEP(mode) \
3931 (EQ(mode, Qkeyw) || EQ(mode, Qkeywise) || EQ(mode, Qkeys))
3932 #define COMBINATIONP(mode) \
3933 (EQ(mode, Qcomb) || EQ(mode, Qcombination) || EQ(mode, Qcombinations))
3934 #define PERMUTATIONP(mode) \
3935 (EQ(mode, Qperm) || EQ(mode, Qpermutation) || EQ(mode, Qpermutations))
3936 #define CARTESIANP(mode) \
3937 (EQ(mode, Qcart) || EQ(mode, Qcartesian))
3939 if (POINTWISEP(mode) && nfams == 1 && NILP(arity) && !DICTP(args[0])) {
3940 /* the arity is not specified and it's just one sequence */
3941 return __pntw_1seq(args[0], fun, 1UL, gluef, res_type, deco);
3943 } else if (POINTWISEP(mode) && NILP(arity) && !DICTP(args[0])) {
3944 /* the arity is not specified and it's more than one sequence */
3945 return __pntw_nseq(args, nfams, fun, gluef, res_type);
3947 } else if (KEYWISEP(mode) && nfams == 1 && NILP(arity)) {
3948 /* the arity is not specified and it's just one sequence,
3949 * also we dont have to care about dicts since
3950 * keywise is specified */
3951 return __pntw_1seq(args[0], fun, 1UL, gluef, res_type, deco);
3953 } else if (KEYWISEP(mode) && NILP(arity)) {
3954 /* the arity is not specified and it's more than one sequence,
3955 * also we dont have to care about dicts since
3956 * keywise is specified */
3957 return __pntw_nseq(args, nfams, fun, gluef, res_type);
3959 } else if (POINTWISEP(mode) && (nfams == 1 && NILP(arity))) {
3960 /* the arity is not specified, it's one sequence, and it
3961 * must be a dict, since the non-dict case was check already */
3962 return __pntw_1dict(args[0], fun, gluef, res_type);
3964 } else if (NATNUMP(arity) && (POINTWISEP(mode) || KEYWISEP(mode))) {
3965 /* the arity is a natnum, so we consider just the
3966 * first sequence, in case of dicts this equals keywise
3968 return __pntw_1seq(args[0], fun, XUINT(arity),
3969 gluef, res_type, deco);
3970 } else if (POINTWISEP(mode) || KEYWISEP(mode)) {
3971 /* the most general case */
3972 size_t a[arity_len];
3973 volatile Lisp_Object tmp;
3976 for (i = 0, tmp = arity;
3977 CONSP(tmp) && i < nfams && i < arity_len;
3978 i++, tmp = XCDR(tmp)) {
3979 a[i] = XUINT(XCAR(tmp));
3981 return __pntw_nseq2(args, i, fun, gluef, res_type, a);
3984 if (COMBINATIONP(mode) && NATNUMP(arity)) {
3985 /* the arity is a natnum, so it's just one sequence,
3986 * if not who cares :) */
3987 return __comb_1seq(args[0], fun, XUINT(arity),
3989 } else if (COMBINATIONP(mode) && (nfams == 1 && NILP(arity))) {
3990 /* the arity is a natnum, so it's just one sequence,
3991 * if not who cares :) */
3992 return __comb_1seq(args[0], fun, -1UL, gluef, res_type);
3994 } else if (COMBINATIONP(mode) && NILP(arity)) {
3995 /* the arity is not specified and it's more than one sequence */
3996 return __cart_nseq(args, nfams, fun, 1UL, gluef, res_type);
3998 } else if (COMBINATIONP(mode)) {
3999 /* the most general case */
4000 size_t a[arity_len];
4001 volatile Lisp_Object tmp;
4004 for (i = 0, tmp = arity;
4005 CONSP(tmp) && i < nfams && i < arity_len;
4006 i++, tmp = XCDR(tmp)) {
4007 a[i] = XUINT(XCAR(tmp));
4009 return __comb_nseq2(args, i, fun, gluef, res_type, a);
4012 if (CARTESIANP(mode) && NATNUMP(arity)) {
4013 /* the arity is a natnum, so it's just one sequence,
4014 * if not who cares :) */
4015 return __cart_1seq(args[0], fun, XUINT(arity),
4017 } else if (CARTESIANP(mode) &&
4018 (nfams == 1 && NILP(arity))) {
4019 /* it's one sequence and arity isnt specified, go with 2 then */
4020 return __cart_1seq(args[0], fun, 2UL, gluef, res_type);
4022 } else if (CARTESIANP(mode) && NILP(arity)) {
4023 /* the arity is not specified and it's more than one sequence */
4024 return __cart_nseq(args, nfams, fun, 1UL, gluef, res_type);
4026 } else if (CARTESIANP(mode)) {
4027 /* the most general case */
4028 size_t a[arity_len];
4029 volatile Lisp_Object tmp;
4032 for (i = 0, tmp = arity;
4033 CONSP(tmp) && i < nfams && i < arity_len;
4034 i++, tmp = XCDR(tmp)) {
4035 a[i] = XUINT(XCAR(tmp));
4037 return __cart_nseq2(args, i, fun, gluef, res_type, a);
4040 if (PERMUTATIONP(mode) && NATNUMP(arity)) {
4041 /* the arity is a natnum, so it's just one sequence,
4042 * if not who cares :) */
4043 return __perm_1seq(args[0], fun, XUINT(arity),
4045 } else if (PERMUTATIONP(mode) && (nfams == 1 && NILP(arity))) {
4046 /* the arity is a natnum, so it's just one sequence,
4047 * if not who cares :) */
4048 return __perm_1seq(args[0], fun, -1UL, gluef, res_type);
4050 } else if (PERMUTATIONP(mode) && NILP(arity)) {
4051 /* the arity is not specified and it's more than one sequence */
4052 return __perm_nseq(args, nfams, fun, 1UL, gluef, res_type);
4054 } else if (PERMUTATIONP(mode)) {
4055 /* the most general case */
4056 size_t a[arity_len];
4057 volatile Lisp_Object tmp;
4060 for (i = 0, tmp = arity;
4061 CONSP(tmp) && i < nfams && i < arity_len;
4062 i++, tmp = XCDR(tmp)) {
4063 a[i] = XUINT(XCAR(tmp));
4065 return __perm_nseq2(args, i, fun, gluef, res_type, a);
4070 DEFUN("mapconcat", Fmapconcat, 3, 3, 0, /*
4071 Apply FUNCTION to each element of SEQUENCE, and concat the results to a string.
4072 Between each pair of results, insert SEPARATOR.
4074 Each result, and SEPARATOR, should be strings. Thus, using " " as SEPARATOR
4075 results in spaces between the values returned by FUNCTION. SEQUENCE itself
4076 may be a list, a vector, a dllist, a bit vector, or a string.
4078 (function, sequence, separator))
4080 EMACS_INT len = XINT(Flength(sequence));
4084 EMACS_INT nargs = len + len - 1;
4085 int speccount = specpdl_depth();
4088 return build_string("");
4090 XMALLOC_OR_ALLOCA(args, nargs, Lisp_Object);
4092 mapcar1(len, args, function, sequence);
4094 for (i = len - 1; i >= 0; i--)
4095 args[i + i] = args[i];
4097 for (i = 1; i < nargs; i += 2)
4098 args[i] = separator;
4100 result = Fconcat(nargs, args);
4101 XMALLOC_UNBIND(args, nargs, speccount);
4105 DEFUN("mapcar", Fmapcar, 2, 2, 0, /*
4106 Apply FUNCTION to each element of SEQUENCE; return a list of the results.
4107 The result is a list of the same length as SEQUENCE.
4108 SEQUENCE may be a list, a vector, a dllist, a bit vector, or a string.
4110 (function, sequence))
4112 size_t len = XINT(Flength(sequence));
4113 Lisp_Object *args = NULL;
4115 int speccount = specpdl_depth();
4117 XMALLOC_OR_ALLOCA(args, len, Lisp_Object);
4119 mapcar1(len, args, function, sequence);
4121 result = Flist(len, args);
4122 XMALLOC_UNBIND(args, len, speccount);
4126 DEFUN("mapdllist", Fmapdllist, 2, 2, 0, /*
4127 Apply FUNCTION to each element of SEQUENCE; return a dllist of the results.
4128 The result is a list of the same length as SEQUENCE.
4129 SEQUENCE may be a list, a vector, a dllist, a bit vector, or a string.
4131 (function, sequence))
4133 size_t len = XINT(Flength(sequence));
4134 Lisp_Object *args = NULL;
4136 int speccount = specpdl_depth();
4138 XMALLOC_OR_ALLOCA(args, len, Lisp_Object);
4140 mapcar1(len, args, function, sequence);
4142 result = Fdllist(len, args);
4143 XMALLOC_UNBIND(args, len, speccount);
4147 DEFUN("mapvector", Fmapvector, 2, 2, 0, /*
4148 Apply FUNCTION to each element of SEQUENCE; return a vector of the results.
4149 The result is a vector of the same length as SEQUENCE.
4150 SEQUENCE may be a list, a vector, a dllist, a bit vector, or a string.
4152 (function, sequence))
4154 size_t len = XINT(Flength(sequence));
4155 Lisp_Object result = make_vector(len, Qnil);
4156 struct gcpro gcpro1;
4159 mapcar1(len, XVECTOR_DATA(result), function, sequence);
4165 DEFUN("mapc-internal", Fmapc_internal, 2, 2, 0, /*
4166 Apply FUNCTION to each element of SEQUENCE.
4167 SEQUENCE may be a list, a vector, a bit vector, or a string.
4168 This function is like `mapcar' but does not accumulate the results,
4169 which is more efficient if you do not use the results.
4171 The difference between this and `mapc' is that `mapc' supports all
4172 the spiffy Common Lisp arguments. You should normally use `mapc'.
4174 (function, sequence))
4176 mapcar1(XINT(Flength(sequence)), 0, function, sequence);
4181 DEFUN("mapc-inplace", Fmapc_inplace, 2, 2, 0, /*
4182 Apply FUNCTION to each element of SEQUENCE and replace the
4183 element with the result.
4184 Return the (destructively) modified sequence.
4186 At the moment, SEQUENCE can be a list, a dllist, a vector,
4187 a bit-vector, or a string.
4189 Containers with type restrictions -- strings or bit-vectors here --
4190 cannot handle all results of FUNCTION. In case of bit-vectors,
4191 if the function yields `nil' or 0 the current bit is set to 0,
4192 if the function yields anything else, the bit is set to 1.
4193 Similarly in the string case any non-char result of FUNCTION sets
4194 the currently processed character to ^@ (octal value: 000).
4196 (function, sequence))
4199 else if (LISTP(sequence))
4200 list_map_inplace(function, sequence);
4201 else if (DLLISTP(sequence))
4202 dllist_map_inplace(function, sequence);
4203 else if (STRINGP(sequence))
4204 string_map_inplace(function, sequence);
4205 else if (VECTORP(sequence))
4206 vector_map_inplace(function, sequence);
4207 else if (BIT_VECTORP(sequence))
4208 bit_vector_map_inplace(function, sequence);
4214 /* to be emodule compliant */
4222 DEFKEYWORD(Q_arity);
4223 DEFKEYWORD(Q_result_type);
4224 DEFKEYWORD(Q_initiator);
4225 DEFKEYWORD(Q_separator);
4226 DEFKEYWORD(Q_terminator);
4227 /* symbols for result and glue */
4228 DEFSYMBOL(Qinplace);
4233 DEFSYMBOL(Qbit_vector);
4238 DEFSYMBOL(Qpointwise);
4241 DEFSYMBOL(Qkeywise);
4244 DEFSYMBOL(Qcombination);
4245 DEFSYMBOL(Qcombinations);
4247 DEFSYMBOL(Qpermutation);
4248 DEFSYMBOL(Qpermutations);
4250 DEFSYMBOL(Qcartesian);
4253 /* special map*s, compatibility */
4255 DEFSUBR(Fmapdllist);
4256 DEFSUBR(Fmapvector);
4257 DEFSUBR(Fmapc_internal);
4258 DEFSUBR(Fmapconcat);
4259 DEFSUBR(Fmapc_inplace);
4263 /* map.c ends here */