cgit.sxemacs.org Git - sxemacs/blob - src/map.c

   1 /*** map.c -- Maps
   2  *
   3  * Copyright (C) 2007 Sebastian Freundt
   4  *
   5  * Author:  Sebastian Freundt <hroptatyr@sxemacs.org>
   6  *
   7  * This file is part of SXEmacs.
   8  *
   9  * Redistribution and use in source and binary forms, with or without
  10  * modification, are permitted provided that the following conditions
  11  * are met:
  12  *
  13  * 1. Redistributions of source code must retain the above copyright
  14  *    notice, this list of conditions and the following disclaimer.
  15  *
  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.
  19  *
  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.
  23  *
  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.
  35  *
  36  ***
  37  * Comment:
  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.
  41  *
  42  ***/
  43
  44 /* Synched up with: Not in FSF, not in XE */
  45
  46 #include <sxemacs.h>
  47 #include "map.h"
  48 #include "dict.h"
  49 #include "skiplist.h"
  50
  51 Lisp_Object Qmap;
  52 Lisp_Object Q_arity, Q_result_type, Q_mode, Q_glue;
  53 Lisp_Object Q_separator, Q_initiator, Q_terminator;
  54 Lisp_Object Qpntw, Qpointwise, Qpoints;
  55 Lisp_Object Qkeyw, Qkeywise, Qkeys;
  56 Lisp_Object Qcomb, Qcombination, Qcombinations;
  57 Lisp_Object Qperm, Qpermutation, Qpermutations;
  58 Lisp_Object Qcart, Qcartesian;
  59
  60 typedef Lisp_Object(*glue_f)(int nargs, Lisp_Object *args);
  61
  62 static Lisp_Object Qinplace, Qlitter, Qconcat;
  63 static Lisp_Object Qvector, Qbit_vector;
  64
  65 EXFUN(Fstring, MANY);
  66 EXFUN(Fbit_vector, MANY);
  67
  68 /* until this is available globally */
  69 #define DICTP(x)        (HASH_TABLEP(x) || SKIPLISTP(x))
  70
  71 struct decoration_s {
  72         Lisp_Object ini, ter, sep;
  73 };
  74
  75 #define deco_ini(x)     ((x)->ini)
  76 #define deco_sep(x)     ((x)->sep)
  77 #define deco_ter(x)     ((x)->ter)
  78
  79 \f
  80 /* auxiliary */
  81 static inline Lisp_Object
  82 __Flist(int nargs, Lisp_Object *args)
  83         __attribute__((always_inline));
  84 static inline Lisp_Object
  85 __Flist(int nargs, Lisp_Object *args)
  86 {
  87         /* this is just Flist() but inlined */
  88         Lisp_Object val = Qnil;
  89         Lisp_Object *argp = args + nargs;
  90
  91         while (argp > args)
  92                 val = Fcons(*--argp, val);
  93         return val;
  94 }
  95
  96 static long unsigned int
  97 __ncombinations(register long unsigned int n, long unsigned int k)
  98 {
  99 /* == binomial(n, k) */
 100         if (UNLIKELY(n == k || k == 0)) {
 101                 return 1UL;
 102         } else if (UNLIKELY(k == 1 || n - k == 1)) {
 103                 return n;
 104         } else if (k == 2 || n - k == 2) {
 105                 return (n * (n-1)) >> 1;
 106         } else {
 107                 /* otherwise do the hard work */
 108                 long unsigned int num = n*(n-1)*(n-k+1), den = k*(k-1);
 109
 110                 /* swap k if necessary */
 111                 if (n - k < k) {
 112                         k = n - k;
 113                 }
 114
 115                 for (n -= 2, k -= 2; k > 1;) {
 116                         num *= n--;
 117                         den *= k--;
 118                 }
 119                 return num/den;
 120         }
 121 }
 122
 123 static long unsigned int
 124 __factorial(register long unsigned int n)
 125 {
 126         register long unsigned int r = n;
 127
 128         /* trivial cases first */
 129         switch (n) {
 130         case 0:
 131         case 1:
 132                 return 1UL;
 133         case 2:
 134                 return 2UL;
 135         case 3:
 136                 return 6UL;
 137         case 4:
 138                 return 24UL;
 139         case 5:
 140                 return 120UL;
 141         case 6:
 142                 return 720UL;
 143         case 7:
 144                 return 5040UL;
 145         case 8:
 146                 return 40320UL;
 147         default:
 148                 r = 40320UL * n;
 149         }
 150
 151         /* the loop */
 152         for (long unsigned int i = 9; i < n; i++) {
 153                 r *= i;
 154         }
 155         return r;
 156 }
 157
 158 static long unsigned int
 159 __nvariations(register long unsigned int n, long unsigned int k)
 160 {
 161 /* == binomial(n, k) * factorial(k) */
 162         if (UNLIKELY(k == 0)) {
 163                 return 1UL;
 164         } else if (UNLIKELY(k == n)) {
 165                 return __factorial(k);
 166         } else if (UNLIKELY(k == 1)) {
 167                 return n;
 168         } else if (UNLIKELY(n - k == 1)) {
 169                 return __factorial(n);
 170         } else if (k == 2) {
 171                 return n * (n-1);
 172         } else if (k == 3) {
 173                 return n * (n-1) * (n-2);
 174         } else {
 175                 /* otherwise do the hard work */
 176                 long unsigned int num = n--;
 177
 178                 num *= n--;
 179                 num *= n--;
 180                 num *= n--;
 181                 while (k-- > 4) {
 182                         num *= n--;
 183                 }
 184                 return num;
 185         }
 186 }
 187
 188 static long unsigned int
 189 __ncart(register long unsigned int n, long unsigned int k)
 190 {
 191 /* == n^k */
 192         long unsigned int res;
 193
 194         switch (k) {
 195         case 2:
 196                 return n*n;
 197         case 3:
 198                 return n*n*n;
 199         case 1:
 200                 return n;
 201         case 0:
 202                 return 1UL;
 203         default:
 204                 break;
 205         }
 206
 207         for (res = n * n * n * n, k -= 4; k > 0; k--) {
 208                 res *= n;
 209         }
 210         return res;
 211 }
 212
 213
 214 static inline void
 215 __advance_multi_index()
 216         __attribute__((always_inline));
 217 static inline void
 218 __advance_multi_index(long int idx[], long int j, long int fam_len)
 219 {
 220         /* partially unroll */
 221         if (LIKELY(++idx[--j] < fam_len)) {
 222                 return;
 223         }
 224         idx[j] = 0;
 225         if (LIKELY(++idx[--j] < fam_len)) {
 226                 return;
 227         }
 228         idx[j] = 0;
 229         if (LIKELY(++idx[--j] < fam_len)) {
 230                 return;
 231         }
 232         idx[j] = 0;
 233         while (j > 0) {
 234                 if (LIKELY(++idx[--j] < fam_len)) {
 235                         return;
 236                 }
 237                 idx[j] = 0;
 238         }
 239         return;
 240 }
 241
 242 static inline void
 243 __advance_multi_index_2()
 244         __attribute__((always_inline));
 245 static inline void
 246 __advance_multi_index_2(long int idx[], long int j, size_t flen[])
 247 {
 248 /* improved version of __a_m_v() which allows for differently-sized families */
 249         /* partially unroll */
 250         if (LIKELY((--j, ++idx[j] < (long int)flen[j]))) {
 251                 return;
 252         }
 253         idx[j] = 0;
 254         if (LIKELY((--j, ++idx[j] < (long int)flen[j]))) {
 255                 return;
 256         }
 257         idx[j] = 0;
 258         if (LIKELY((--j, ++idx[j] < (long int)flen[j]))) {
 259                 return;
 260         }
 261         idx[j] = 0;
 262         while (j > 0) {
 263                 if (LIKELY((--j, ++idx[j] < (long int)flen[j]))) {
 264                         return;
 265                 }
 266                 idx[j] = 0;
 267         }
 268         return;
 269 }
 270
 271 static inline void
 272 __advance_multi_index_3()
 273         __attribute__((always_inline));
 274 static inline void
 275 __advance_multi_index_3(
 276         long int idx[], long int j, size_t flen[],
 277         long int nseqs, size_t arity[])
 278 {
 279 /* improved version of __a_m_v_2() which allows for differently-sized families
 280  * and multiplicities thereof
 281  * this is for cartesian indexing, i.e. the order goes
 282  * [1,0]->[1,1]->[1,2]->[2,0] for arity (., 3) */
 283         long int mlt = arity[--nseqs];
 284
 285         if (LIKELY(++idx[--j] < (long int)flen[nseqs])) {
 286                 return;
 287         }
 288         idx[j] = 0;
 289         if (mlt-- == 0) {
 290                 mlt = arity[--nseqs];
 291         }
 292         if (LIKELY(++idx[--j] < (long int)flen[nseqs])) {
 293                 return;
 294         }
 295         idx[j] = 0;
 296         if (mlt-- == 0) {
 297                 mlt = arity[--nseqs];
 298         }
 299         if (LIKELY(++idx[--j] < (long int)flen[nseqs])) {
 300                 return;
 301         }
 302         idx[j] = 0;
 303         if (mlt-- == 0) {
 304                 mlt = arity[--nseqs];
 305         }
 306         while (j > 0 && nseqs >= 0) {
 307                 if (LIKELY(++idx[--j] < (long int)flen[nseqs])) {
 308                         return;
 309                 }
 310                 idx[j] = 0;
 311                 if (mlt-- == 0) {
 312                         mlt = arity[--nseqs];
 313                 }
 314         }
 315         return;
 316 }
 317
 318 static inline void
 319 __initialise_multi_index()
 320         __attribute__((always_inline));
 321 static inline void
 322 __initialise_multi_index(size_t midx[], size_t arity)
 323 {
 324         midx[0] = 0L;
 325         for (size_t j = 1; j < arity; j++) {
 326                 midx[j] = j;
 327         }
 328         return;
 329 }
 330
 331 static inline bool
 332 __advance_multi_index_comb()
 333         __attribute__((always_inline));
 334 static inline bool
 335 __advance_multi_index_comb(size_t idx[], size_t len, int arity)
 336 {
 337         register long int i;
 338
 339         for (i = arity-1; (i >= 0) && idx[i] >= len - arity + i; i--);
 340         idx[i]++;
 341         for (; ++i < arity; ) {
 342                 idx[i] = idx[i-1]+1;
 343         }
 344         return (idx[i-1] < len);
 345 }
 346
 347 static inline void
 348 __advance_multi_index_4()
 349         __attribute__((always_inline));
 350 static inline void
 351 __advance_multi_index_4(
 352         size_t *midx[], size_t flen[], long int j /*nseqs*/, size_t arity[])
 353 {
 354 /* like __a_m_v_3(), also allowing for differently-sized families
 355  * and multiplicities thereof, but for for combinatorial indexing,
 356  * i.e. the order goes
 357  * [1,2]->[1,3]->[2,3] for arity (., 3) */
 358         --j;
 359         if (LIKELY(__advance_multi_index_comb(midx[j], flen[j], arity[j]))) {
 360                 /* if there's more to come, bingo */
 361                 return;
 362         }
 363         /* otherwise reinitialise the mindex we're currently shagging */
 364         __initialise_multi_index(midx[j], arity[j]);
 365
 366         --j;
 367         if (LIKELY(__advance_multi_index_comb(midx[j], flen[j], arity[j]))) {
 368                 return;
 369         }
 370         /* otherwise reinitialise the mindex we're currently shagging */
 371         __initialise_multi_index(midx[j], arity[j]);
 372
 373         /* now loop mode */
 374         while (j-- > 0) {
 375                 if (LIKELY(__advance_multi_index_comb(
 376                                    midx[j], flen[j], arity[j]))) {
 377                         return;
 378                 }
 379                 /* otherwise reinitialise the mindex we're currently shagging */
 380                 __initialise_multi_index(midx[j], arity[j]);
 381         }
 382         return;
 383 }
 384
 385 \f
 386 /* This is the guts of several mapping functions.
 387    Apply FUNCTION to each element of SEQUENCE, one by one,
 388    storing the results into elements of VALS, a C vector of Lisp_Objects.
 389    LENI is the length of VALS, which should also be the length of SEQUENCE.
 390
 391    If VALS is a null pointer, do not accumulate the results. */
 392
 393 static void
 394 mapcar1(size_t leni, Lisp_Object * vals,
 395         Lisp_Object function, Lisp_Object sequence)
 396 {
 397         Lisp_Object result;
 398         Lisp_Object args[2];
 399         struct gcpro gcpro1;
 400
 401         args[0] = function;
 402
 403         if (vals) {
 404                 /* clean sweep */
 405                 memset(vals, 0, leni * sizeof(Lisp_Object));
 406                 GCPROn(vals, leni);
 407         }
 408
 409         if (LISTP(sequence)) {
 410                 /* A devious `function' could either:
 411                    - insert garbage into the list in front of us, causing XCDR to crash
 412                    - amputate the list behind us using (setcdr), causing the remaining
 413                    elts to lose their GCPRO status.
 414
 415                    if (vals != 0) we avoid this by copying the elts into the
 416                    `vals' array.  By a stroke of luck, `vals' is exactly large
 417                    enough to hold the elts left to be traversed as well as the
 418                    results computed so far.
 419
 420                    if (vals == 0) we don't have any free space available and
 421                    don't want to eat up any more stack with alloca().
 422                    So we use EXTERNAL_LIST_LOOP_3_NO_DECLARE and GCPRO the tail. */
 423
 424                 if (vals) {
 425                         Lisp_Object *val = vals;
 426                         size_t i;
 427
 428                         LIST_LOOP_2(elt, sequence) {
 429                             *val++ = elt;
 430                         }
 431
 432                         for (i = 0; i < leni; i++) {
 433                                 args[1] = vals[i];
 434                                 vals[i] = Ffuncall(2, args);
 435                         }
 436                 } else {
 437                         Lisp_Object elt, tail;
 438                         EMACS_INT len_unused;
 439                         struct gcpro ngcpro1;
 440
 441                         NGCPRO1(tail);
 442
 443                         {
 444                                 EXTERNAL_LIST_LOOP_4_NO_DECLARE(elt, sequence,
 445                                                                 tail,
 446                                                                 len_unused) {
 447                                         args[1] = elt;
 448                                         Ffuncall(2, args);
 449                                 }
 450                         }
 451
 452                         NUNGCPRO;
 453                 }
 454         } else if (VECTORP(sequence)) {
 455                 Lisp_Object *objs = XVECTOR_DATA(sequence);
 456
 457                 for (size_t i = 0; i < leni; i++) {
 458                         args[1] = *objs++;
 459                         result = Ffuncall(2, args);
 460                         if (vals) {
 461                                 vals[i] = result;
 462                         }
 463                 }
 464         } else if (DLLISTP(sequence)) {
 465                 dllist_item_t elt = XDLLIST_FIRST(sequence);
 466
 467                 for (size_t i = 0; elt; i++) {
 468                         args[1] = (Lisp_Object)elt->item;
 469                         result = Ffuncall(2, args);
 470                         if (vals) {
 471                                 vals[i] = result;
 472                         }
 473                         elt = elt->next;
 474                 }
 475         } else if (STRINGP(sequence)) {
 476                 /* The string data of `sequence' might be relocated during GC. */
 477                 Bytecount slen = XSTRING_LENGTH(sequence);
 478                 Bufbyte *p = NULL;
 479                 Bufbyte *end = NULL;
 480                 int speccount = specpdl_depth();
 481                 size_t i = 0;
 482
 483                 XMALLOC_ATOMIC_OR_ALLOCA(p, slen, Bufbyte);
 484                 end = p + slen;
 485
 486                 memcpy(p, XSTRING_DATA(sequence), slen);
 487
 488                 while (p < end) {
 489                         args[1] = make_char(charptr_emchar(p));
 490                         INC_CHARPTR(p);
 491                         result = Ffuncall(2, args);
 492                         if (vals) {
 493                                 vals[i++] = result;
 494                         }
 495                 }
 496                 XMALLOC_UNBIND(p, slen, speccount);
 497         } else if (BIT_VECTORP(sequence)) {
 498                 Lisp_Bit_Vector *v = XBIT_VECTOR(sequence);
 499
 500                 for (size_t i = 0; i < leni; i++) {
 501                         args[1] = make_int(bit_vector_bit(v, i));
 502                         result = Ffuncall(2, args);
 503                         if (vals) {
 504                                 vals[i] = result;
 505                         }
 506                 }
 507         } else {
 508                 /* unreachable, since Flength (sequence) did not get an error */
 509                 abort();
 510         }
 511
 512         if (vals) {
 513                 UNGCPRO;
 514         }
 515 }
 516
 517 static void
 518 list_map_inplace(Lisp_Object function, Lisp_Object list)
 519 {
 520         Lisp_Object args[2];
 521         struct gcpro gcpro1, gcpro2;
 522         Lisp_Object elt = list;
 523
 524         GCPRO2(function, list);
 525
 526         args[0] = function;
 527         while (!NILP(elt)) {
 528                 args[1] = XCAR(elt);
 529                 XCAR(elt) = Ffuncall(2, args);
 530                 elt = XCDR(elt);
 531         }
 532         UNGCPRO;
 533 }
 534
 535 static void
 536 vector_map_inplace(Lisp_Object function, Lisp_Object tuple)
 537 {
 538         Lisp_Object *objs = XVECTOR_DATA(tuple);
 539         Lisp_Object args[2];
 540         size_t i, len = XVECTOR_LENGTH(tuple);
 541         struct gcpro gcpro1, gcpro2, gcpro3;
 542
 543         GCPRO2n(function, tuple, args, countof(args));
 544
 545         args[0] = function;
 546         for (i = 0; i < len; i++) {
 547                 args[1] = *objs;
 548                 *objs++ = Ffuncall(2, args);
 549         }
 550
 551         UNGCPRO;
 552 }
 553
 554 static void
 555 string_map_inplace(Lisp_Object function, Lisp_Object string)
 556 {
 557         Lisp_Object args[2];
 558         size_t len = XSTRING_LENGTH(string);
 559         Bufbyte *p = XSTRING_DATA(string);
 560         Bufbyte *end = p + len;
 561         struct gcpro gcpro1, gcpro2, gcpro3;
 562
 563         GCPRO2n(function, string, args, countof(args));
 564
 565         args[0] = function;
 566         while (p < end) {
 567                 args[1] = make_char(charptr_emchar(p));
 568                 args[1] = Ffuncall(2, args);
 569                 if (CHARP(args[1]))
 570                         set_charptr_emchar(p, XCHAR(args[1]));
 571                 else
 572                         set_charptr_emchar(p, '\000');
 573                 INC_CHARPTR(p);
 574         }
 575
 576         UNGCPRO;
 577 }
 578
 579 static void
 580 bit_vector_map_inplace(Lisp_Object function, Lisp_Object bitvec)
 581 {
 582         Lisp_Bit_Vector *v = XBIT_VECTOR(bitvec);
 583         Lisp_Object args[2];
 584         struct gcpro gcpro1, gcpro2, gcpro3;
 585         size_t i, len = bit_vector_length(XBIT_VECTOR(bitvec));
 586
 587         GCPRO2n(function, bitvec, args, countof(args));
 588
 589         args[0] = function;
 590         for (i = 0; i < len; i++) {
 591                 args[1] = make_int(bit_vector_bit(v, i));
 592                 args[1] = Ffuncall(2, args);
 593                 if ((NUMBERP(args[1]) && ent_unrel_zerop(args[1])) ||
 594                     NILP(args[1]))
 595                         set_bit_vector_bit(v, i, 0);
 596                 else
 597                         set_bit_vector_bit(v, i, -1);
 598         }
 599
 600         UNGCPRO;
 601 }
 602
 603 /***
 604  * The mapfam approach
 605  */
 606
 607 /* auxiliary stuff */
 608 static inline size_t
 609 __fam_size(Lisp_Object fam)
 610 {
 611         return seq_length((seq_t)(void*)fam);
 612 }
 613
 614 static inline size_t
 615 __nfam_min_size(Lisp_Object fam[], size_t nfam)
 616 {
 617         size_t res;
 618
 619         /* catch the horst-case */
 620         if (UNLIKELY(nfam == 0)) {
 621                 return 0UL;
 622         }
 623         /* otherwise unroll a little */
 624         res = __fam_size(fam[0]);
 625         for (size_t j = 1; j < nfam; j++) {
 626                 size_t tmp = __fam_size(fam[j]);
 627                 if (tmp < res) {
 628                         res = tmp;
 629                 }
 630         }
 631         return res;
 632 }
 633
 634 static inline size_t
 635 __nfam_min_size_a(Lisp_Object fam[], size_t nfam, size_t arity[])
 636 {
 637         size_t res;
 638
 639         /* catch the horst-case */
 640         if (UNLIKELY(nfam == 0)) {
 641                 return 0UL;
 642         }
 643         /* otherwise unroll a little */
 644         res = __fam_size(fam[0]) / arity[0];
 645         for (size_t j = 1; j < nfam; j++) {
 646                 size_t tmp = __fam_size(fam[j]) / arity[j];
 647                 if (tmp < res) {
 648                         res = tmp;
 649                 }
 650         }
 651         return res;
 652 }
 653
 654 static inline size_t
 655 __nfam_cart_sum_size(size_t *sum, size_t *cart, size_t nfsz[],
 656                      Lisp_Object fam[], size_t nfam)
 657 {
 658 /* computes the size of the cartesian set and the maximum size of
 659  * the union set, returns the sum of cartesian and union, and puts
 660  * intermediately computed family sizes int nfsz */
 661
 662         /* catch the horst-case */
 663         if (UNLIKELY(nfam == 0)) {
 664                 *sum = *cart = 0;
 665                 return 0UL;
 666         } else if (nfam == 1) {
 667                 /* another horst case
 668                  * just 1 fam should always call fam_size() */
 669                 return *sum = *cart = nfsz[0] = __fam_size(fam[0]);
 670         }
 671         /* otherwise unroll a little */
 672         nfsz[0] = __fam_size(fam[0]);
 673         nfsz[1] = __fam_size(fam[1]);
 674         *sum = nfsz[0] + nfsz[1];
 675         *cart = nfsz[0] * nfsz[1];
 676         for (size_t j = 2; j < nfam; j++) {
 677                 nfsz[j] = __fam_size(fam[j]);
 678                 *sum += nfsz[j];
 679                 *cart *= nfsz[j];
 680         }
 681         return *sum + *cart;
 682 }
 683
 684 static inline void
 685 __my_pow_insitu(size_t *base, size_t expon)
 686 {
 687 /* improve me and put me somewhere else, ase-arith.h? */
 688         for (size_t i = 1, b = *base; i < expon; i++) {
 689                 *base *= b;
 690         }
 691         return;
 692 }
 693
 694 static inline size_t
 695 __my_pow_explicit(size_t base, size_t expon)
 696 {
 697 /* improve me and put me somewhere else, ase-arith.h? */
 698         size_t res = base;
 699         for (size_t i = 1; i < expon; i++) {
 700                 res *= base;
 701         }
 702         return res;
 703 }
 704
 705 static inline size_t
 706 __nfam_cart_sum_size_a(size_t *sum, size_t *cart, size_t *midxsz,
 707                        size_t nfsz[],
 708                        Lisp_Object fam[], size_t nfam, size_t arity[])
 709 {
 710 /* computes the size of the cartesian set (put into *cart), the maximum
 711  * size of the union set (returned) and the multiplicity of the
 712  * multi-index (which is the cross sum of the arity array) returns the
 713  * sum of cartesian and union, and puts intermediately computed family
 714  * sizes into nfsz */
 715
 716         /* catch the horst-case */
 717         if (UNLIKELY(nfam == 0)) {
 718                 *sum = *cart = *midxsz = 0;
 719                 return 0UL;
 720         } else if (nfam == 1) {
 721                 /* another horst case
 722                  * just 1 fam should always call fam_size() */
 723                 *sum = *cart = nfsz[0] = __fam_size(fam[0]);
 724                 __my_pow_insitu(cart, *midxsz = arity[0]);
 725                 return *sum + *cart;
 726         }
 727         /* otherwise unroll a little */
 728         nfsz[0] = __fam_size(fam[0]);
 729         nfsz[1] = __fam_size(fam[1]);
 730         *sum = nfsz[0] + nfsz[1];
 731         *midxsz = arity[0] + arity[1];
 732         *cart = __my_pow_explicit(nfsz[0], arity[0]) *
 733                 __my_pow_explicit(nfsz[1], arity[1]);
 734         for (size_t j = 2; j < nfam; j++) {
 735                 nfsz[j] = __fam_size(fam[j]);
 736                 *sum += nfsz[j];
 737                 *midxsz += arity[j];
 738                 *cart *= __my_pow_explicit(nfsz[j], arity[j]);
 739         }
 740         return *sum + *cart;
 741 }
 742
 743 static inline size_t
 744 __nfam_comb_sum_size_a(size_t *sum, size_t *comb, size_t *midxsz,
 745                        size_t nfsz[],
 746                        Lisp_Object fam[], size_t nfam, size_t arity[])
 747 {
 748 /* computes the size of the cartesian set (returned), the maximum size of
 749  * the union set and the multiplicity of the multi-index (which is the
 750  * cross sum of the arity array) returns the sum of cartesian and union,
 751  * and puts intermediately computed family sizes into nfsz */
 752
 753         /* catch the horst-case */
 754         if (UNLIKELY(nfam == 0)) {
 755                 *sum = *comb = *midxsz = 0;
 756                 return 0UL;
 757         } else if (nfam == 1) {
 758                 /* another horst case
 759                  * just 1 fam should always call fam_size() */
 760                 *sum = nfsz[0] = __fam_size(fam[0]);
 761                 *comb = __ncombinations(nfsz[0], *midxsz = arity[0]);
 762                 return *sum + *comb;
 763         }
 764         /* otherwise unroll a little */
 765         nfsz[0] = __fam_size(fam[0]);
 766         nfsz[1] = __fam_size(fam[1]);
 767         *sum = nfsz[0] + nfsz[1];
 768         *midxsz = arity[0] + arity[1];
 769         *comb = __ncombinations(nfsz[0], arity[0]) *
 770                 __ncombinations(nfsz[1], arity[1]);
 771         for (size_t j = 2; j < nfam; j++) {
 772                 nfsz[j] = __fam_size(fam[j]);
 773                 *sum += nfsz[j];
 774                 *midxsz += arity[j];
 775                 *comb *= __ncombinations(nfsz[j], arity[j]);
 776         }
 777         return *sum + *comb;
 778 }
 779
 780 static inline size_t
 781 __nfam_perm_sum_size(size_t *sum, size_t *cart, size_t *perm, size_t nfsz[],
 782                      Lisp_Object fam[], size_t nfam)
 783 {
 784 /* computes the size of the cartesian set and the maximum size of
 785  * the union set, returns the sum of cartesian and union, and puts
 786  * intermediately computed family sizes int nfsz */
 787
 788         /* catch the horst-case */
 789         if (UNLIKELY(nfam == 0)) {
 790                 *sum = *cart = *perm = 0;
 791                 return 0UL;
 792         } else if (nfam == 1) {
 793                 /* another horst case
 794                  * just 1 fam should always call fam_size() */
 795                 *perm = 1;
 796                 return *sum = *cart = nfsz[0] = __fam_size(fam[0]);
 797         }
 798         /* otherwise unroll a little */
 799         nfsz[0] = __fam_size(fam[0]);
 800         nfsz[1] = __fam_size(fam[1]);
 801         *sum = nfsz[0] + nfsz[1];
 802         *cart = nfsz[0] * nfsz[1];
 803         for (size_t j = 2; j < nfam; j++) {
 804                 nfsz[j] = __fam_size(fam[j]);
 805                 *sum += nfsz[j];
 806                 *cart *= nfsz[j];
 807         }
 808         *cart *= (*perm = __factorial(nfam));
 809         return *sum + *cart;
 810 }
 811
 812 static inline size_t
 813 __nfam_perm_sum_size_a(size_t *sum, size_t *var, size_t *perm, size_t *midxsz,
 814                        size_t nfsz[],
 815                        Lisp_Object fam[], size_t nfam, size_t arity[])
 816 {
 817 /* computes the size of the cartesian set (returned), the maximum size of
 818  * the union set and the multiplicity of the multi-index (which is the
 819  * cross sum of the arity array) returns the sum of cartesian and union,
 820  * and puts intermediately computed family sizes into nfsz */
 821
 822         /* catch the horst-case */
 823         if (UNLIKELY(nfam == 0)) {
 824                 *sum = *var = *perm = *midxsz = 0;
 825                 return 0UL;
 826         } else if (nfam == 1) {
 827                 /* another horst case
 828                  * just 1 fam should always call fam_size() */
 829                 *sum = nfsz[0] = __fam_size(fam[0]);
 830                 *perm = __factorial(*midxsz = arity[0]);
 831                 *var = __ncombinations(nfsz[0], arity[0]) * *perm;
 832                 return *sum + *var;
 833         }
 834         /* otherwise unroll a little */
 835         nfsz[0] = __fam_size(fam[0]);
 836         nfsz[1] = __fam_size(fam[1]);
 837         *sum = nfsz[0] + nfsz[1];
 838         *midxsz = arity[0] + arity[1];
 839         *var = __ncombinations(nfsz[0], arity[0]) *
 840                 __ncombinations(nfsz[1], arity[1]);
 841         for (size_t j = 2; j < nfam; j++) {
 842                 nfsz[j] = __fam_size(fam[j]);
 843                 *sum += nfsz[j];
 844                 *midxsz += arity[j];
 845                 *var *= __ncombinations(nfsz[j], arity[j]);
 846         }
 847         /* we computed the number of combinations above, now to compute
 848          * the number of variations we have to apply the S_{midxsz} on
 849          * each element, hence we simply multiply with the factorial of
 850          * midxsz (which is the cross sum of all arities) */
 851         *var *= (*perm = __factorial(*midxsz));
 852         return *sum + *var;
 853 }
 854
 855 /* combinations
 856  * dedicated subroutines for 2-combs and 3-combs because they are soooo easy
 857  */
 858 static void
 859 __2comb(Lisp_Object tgts[], size_t SXE_UNUSED(tlen),
 860         Lisp_Object supp[], size_t slen,
 861         Lisp_Object fun, glue_f gf)
 862 {
 863 /* assumes that everything is gcpro'd properly */
 864         Lisp_Object arr[3] = {fun, Qnil, Qnil};
 865
 866         if (LIKELY(!NILP(fun) && gf == NULL)) {
 867                 for (size_t i = 0, l = 0; i < slen-1; i++) {
 868                         for (size_t j = i+1; j < slen; j++) {
 869                                 /* set up the array */
 870                                 arr[1] = supp[i];
 871                                 arr[2] = supp[j];
 872                                 /* apply fun */
 873                                 tgts[l++] = Ffuncall(countof(arr), arr);
 874                         }
 875                 }
 876         } else if (LIKELY(!NILP(fun))) {
 877                 for (size_t i = 0, l = 0; i < slen-1; i++) {
 878                         for (size_t j = i+1; j < slen; j++) {
 879                                 /* set up the array */
 880                                 arr[1] = supp[i];
 881                                 arr[2] = supp[j];
 882                                 /* glue */
 883                                 arr[1] = gf(2, &arr[1]);
 884                                 /* apply fun */
 885                                 tgts[l++] = Ffuncall(2, arr);
 886                         }
 887                 }
 888         } else {
 889                 glue_f tgf = gf ? gf : Flist;
 890                 for (size_t i = 0, l = 0; i < slen-1; i++) {
 891                         for (size_t j = i+1; j < slen; j++) {
 892                                 /* set up the array */
 893                                 arr[1] = supp[i];
 894                                 arr[2] = supp[j];
 895                                 /* glue */
 896                                 tgts[l++] = tgf(2, &arr[1]);
 897                         }
 898                 }
 899         }
 900         return;
 901 }
 902
 903 static void
 904 __3comb(Lisp_Object tgts[], size_t SXE_UNUSED(tlen),
 905         Lisp_Object supp[], size_t slen,
 906         Lisp_Object fun, glue_f gf)
 907 {
 908 /* assumes that everything is gcpro'd properly */
 909         Lisp_Object arr[4] = {fun, Qnil, Qnil, Qnil};
 910
 911         if (LIKELY(!NILP(fun) && gf == NULL)) {
 912                 for (size_t i = 0, l = 0; i < slen-2; i++) {
 913                         for (size_t j = i+1; j < slen-1; j++) {
 914                                 for (size_t k = j+1; k < slen; k++) {
 915                                         /* set up the array */
 916                                         arr[1] = supp[i];
 917                                         arr[2] = supp[j];
 918                                         arr[3] = supp[k];
 919                                         /* apply fun */
 920                                         tgts[l++] = Ffuncall(countof(arr), arr);
 921                                 }
 922                         }
 923                 }
 924         } else if (LIKELY(!NILP(fun))) {
 925                 for (size_t i = 0, l = 0; i < slen-2; i++) {
 926                         for (size_t j = i+1; j < slen-1; j++) {
 927                                 for (size_t k = j+1; k < slen; k++) {
 928                                         /* set up the array */
 929                                         arr[1] = supp[i];
 930                                         arr[2] = supp[j];
 931                                         arr[3] = supp[k];
 932                                         /* glue */
 933                                         arr[1] = gf(3, &arr[1]);
 934                                         /* apply fun */
 935                                         tgts[l++] = Ffuncall(2, arr);
 936                                 }
 937                         }
 938                 }
 939         } else {
 940                 glue_f tgf = gf ? gf : Flist;
 941                 for (size_t i = 0, l = 0; i < slen-2; i++) {
 942                         for (size_t j = i+1; j < slen-1; j++) {
 943                                 for (size_t k = j+1; k < slen; k++) {
 944                                         /* set up the array */
 945                                         arr[1] = supp[i];
 946                                         arr[2] = supp[j];
 947                                         arr[3] = supp[k];
 948                                         /* glue */
 949                                         tgts[l++] = tgf(3, &arr[1]);
 950                                 }
 951                         }
 952                 }
 953         }
 954         return;
 955 }
 956
 957 static void
 958 __ncomb(Lisp_Object tgts[], size_t tlen,
 959         Lisp_Object supp[], size_t slen,
 960         Lisp_Object fun, glue_f gf,
 961         size_t arity)
 962 {
 963 /* assumes that everything is gcpro'd properly */
 964         size_t idx[arity+1];
 965         size_t l = 0;
 966         Lisp_Object fc[arity+1], *v = &fc[1];
 967
 968         /* setup */
 969         memset(idx, 0, arity*sizeof(long int));
 970         memset(v, 0, arity*sizeof(Lisp_Object));
 971         fc[0] = fun;
 972
 973         /* special case slen == arity */
 974         if (UNLIKELY(slen == arity)) {
 975                 if (LIKELY(!NILP(fun) && gf == NULL)) {
 976                         tgts[0] = Ffuncall(slen, supp);
 977                 } else if (LIKELY(!NILP(fun))) {
 978                         v[0] = gf(slen, supp);
 979                         tgts[0] = Ffuncall(2, fc);
 980                 } else {
 981                         glue_f tgf = gf ? gf : Flist;
 982                         tgts[0] = tgf(slen, supp);
 983                 }
 984                 return;
 985         }
 986
 987         /* setup, partially unrolled */
 988         idx[0] = 0;
 989         idx[1] = 1;
 990         for (size_t i = 2; i < arity; i++) {
 991                 idx[i] = i;
 992         }
 993
 994         if (LIKELY(!NILP(fun) && gf == NULL)) {
 995                 while (l < tlen) {
 996                         v[0] = supp[idx[0]];
 997                         v[1] = supp[idx[1]];
 998                         for (size_t i = 2; i < arity; i++) {
 999                                 v[i] = supp[idx[i]];
1000                         }
1001                         /* apply fun */
1002                         tgts[l++] = Ffuncall(countof(fc), fc);
1003                         /* increment, fooking back'n'forth-loop-based
1004                          * IMPROVE THAT */
1005                         (void)__advance_multi_index_comb(idx, slen, arity);
1006                 }
1007         } else if (LIKELY(!NILP(fun))) {
1008                 while (l < tlen) {
1009                         v[0] = supp[idx[0]];
1010                         v[1] = supp[idx[1]];
1011                         for (size_t i = 2; i < arity; i++) {
1012                                 v[i] = supp[idx[i]];
1013                         }
1014                         /* glue */
1015                         v[0] = gf(arity, v);
1016                         /* apply fun */
1017                         tgts[l++] = Ffuncall(2, fc);
1018                         /* increment, fooking back'n'forth-loop-based
1019                          * IMPROVE THAT */
1020                         (void)__advance_multi_index_comb(idx, slen, arity);
1021                 }
1022         } else {
1023                 glue_f tgf = gf ? gf : Flist;
1024                 while (l < tlen) {
1025                         v[0] = supp[idx[0]];
1026                         v[1] = supp[idx[1]];
1027