"Fossies" - the Fresh Open Source Software Archive

Member "scm/ramap.c" (22 Oct 2017, 50718 Bytes) of package /linux/privat/scm-5f3.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) C and C++ source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "ramap.c" see the Fossies "Dox" file reference documentation and the latest Fossies "Diffs" side-by-side code changes report: 5f2_vs_5f3.

    1 /* "ramap.c" Array mapping functions for APL-Scheme.
    2  * Copyright (C) 1994, 1995, 2006 Free Software Foundation, Inc.
    3  *
    4  * This program is free software: you can redistribute it and/or modify
    5  * it under the terms of the GNU Lesser General Public License as
    6  * published by the Free Software Foundation, either version 3 of the
    7  * License, or (at your option) any later version.
    8  *
    9  * This program is distributed in the hope that it will be useful, but
   10  * WITHOUT ANY WARRANTY; without even the implied warranty of
   11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
   12  * Lesser General Public License for more details.
   13  *
   14  * You should have received a copy of the GNU Lesser General Public
   15  * License along with this program.  If not, see
   16  * <http://www.gnu.org/licenses/>.
   17  */
   18 
   19 /* Author: Radey Shouman */
   20 
   21 #include "scm.h"
   22 
   23 SCM sc2array P((SCM s, SCM ra, SCM prot));
   24 
   25 typedef struct {
   26   char *name;
   27   SCM sproc;
   28   int (* vproc)();
   29 } ra_iproc;
   30 
   31 # define BVE_REF(a, i) ((VELTS(a)[(i)/LONG_BIT] & (1L<<((i)%LONG_BIT))) ? 1 : 0)
   32 # define BVE_SET(a, i) (VELTS(a)[(i)/LONG_BIT] |= (1L<<((i)%LONG_BIT)))
   33 # define BVE_CLR(a, i) (VELTS(a)[(i)/LONG_BIT] &= ~(1L<<((i)%LONG_BIT)))
   34 /* Fast, recycling vector ref */
   35 # define RVREF(ra, i, e) (e = cvref(ra, i, e))
   36 /* #define RVREF(ra, i, e) (cvref(ra, i, UNDEFINED)) to turn off */
   37 
   38 /* IVDEP means "ignore vector dependencies", meaning we guarantee that
   39    elements of vector operands are not aliased */
   40 # ifdef _UNICOS
   41 #  define IVDEP(test, line) if (test) {_Pragma("ivdep"); line} else {line}
   42 # else
   43 #  define IVDEP(test, line) line
   44 # endif
   45 
   46 static sizet cind(ra, inds)
   47      SCM ra;
   48      long *inds;
   49 {
   50   sizet i;
   51   int k;
   52   if (!ARRAYP(ra)) return *inds;
   53   i = ARRAY_BASE(ra);
   54   for (k = 0; k < ARRAY_NDIM(ra); k++)
   55     i += (inds[k] - ARRAY_DIMS(ra)[k].lbnd)*ARRAY_DIMS(ra)[k].inc;
   56   return i;
   57 }
   58 
   59   /* Checker for array mapping functions:
   60      return values: 4 --> shapes, increments, and bases are the same;
   61             3 --> shapes and increments are the same;
   62             2 --> shapes are the same;
   63             1 --> ras are at least as big as ra0;
   64             0 --> no match.
   65    */
   66 int ra_matchp(ra0, ras)
   67      SCM ra0, ras;
   68 {
   69   SCM ra1;
   70   array_dim dims;
   71   array_dim *s0 = &dims;
   72   array_dim *s1;
   73   sizet bas0 = 0;
   74   int i, ndim = 1;
   75   int exact = 2    /* 4 */; /* Don't care about values >2 (yet?) */
   76   if (IMP(ra0)) return 0;
   77   switch TYP7(ra0) {
   78   default: return 0;
   79   case tc7_vector:
   80   case tcs_uves:
   81     s0->lbnd = 0;
   82     s0->inc = 1;
   83     s0->ubnd = (long)LENGTH(ra0) - 1;
   84     break;
   85   case tc7_smob:
   86     if (!ARRAYP(ra0)) return 0;
   87     ndim = ARRAY_NDIM(ra0);
   88     s0 = ARRAY_DIMS(ra0);
   89     bas0 = ARRAY_BASE(ra0);
   90     break;
   91   }
   92   while NIMP(ras) {
   93     ra1 = CAR(ras);
   94     switch (IMP(ra1) ? 0 : TYP7(ra1)) {
   95     default: scalar:
   96       CAR(ras) = sc2array(ra1, ra0, EOL); break;
   97     case tc7_vector:
   98     case tcs_uves:
   99       if (1 != ndim) return 0;
  100       switch (exact) {
  101       case 4: if (0 != bas0) exact = 3;
  102       case 3: if (1 != s0->inc) exact = 2;
  103       case 2: if ((0==s0->lbnd) && (s0->ubnd==LENGTH(ra1) - 1)) break;
  104     exact = 1;
  105       case 1: if (s0->lbnd < 0 || s0->ubnd >= LENGTH(ra1))
  106     if (s0->lbnd <= s0->ubnd) return 0;
  107       }
  108       break;
  109     case tc7_smob:
  110       if (!ARRAYP(ra1)) goto scalar;
  111       if (ndim != ARRAY_NDIM(ra1)) {
  112     if (0==ARRAY_NDIM(ra1))
  113       goto scalar;
  114     else
  115       return 0;
  116       }
  117       s1 = ARRAY_DIMS(ra1);
  118       if (bas0 != ARRAY_BASE(ra1)) exact = 3;
  119       for (i = 0; i < ndim; i++)
  120     switch (exact) {
  121     case 4: case 3:
  122       if (s0[i].inc != s1[i].inc)
  123         exact = 2;
  124     case 2:
  125       if (s0[i].lbnd==s1[i].lbnd && s0[i].ubnd==s1[i].ubnd)
  126         break;
  127       exact = 1;
  128     default:
  129       if (s0[i].lbnd < s1[i].lbnd || s0[i].ubnd > s1[i].ubnd)
  130         if (s0[i].lbnd <= s0[i].ubnd) return 0;
  131     }
  132       break;
  133     }
  134     ras = CDR(ras);
  135   }
  136   return exact;
  137 }
  138 
  139 static char s_ra_mismatch[] = "array shape mismatch";
  140 int ramapc(cproc, data, ra0, lra, what)
  141      int (*cproc)();
  142      SCM data, ra0, lra;
  143      const char *what;
  144 {
  145   SCM z, vra0, ra1, vra1;
  146   SCM lvra, *plvra;
  147   int k, kmax = (ARRAYP(ra0) ? ARRAY_NDIM(ra0) - 1 : 0);
  148   switch (ra_matchp(ra0, lra)) {
  149   default:
  150   case 0: wta(ra0, s_ra_mismatch, what);
  151   case 2: case 3: case 4:   /* Try unrolling arrays */
  152     if (kmax < 0) goto gencase;
  153     vra0 = (0==kmax ? ra0 : array_contents(ra0, UNDEFINED));
  154     if (IMP(vra0)) goto gencase;
  155     if (!ARRAYP(vra0)) {
  156       vra1 = make_ra(1);
  157       ARRAY_BASE(vra1) = 0;
  158       ARRAY_DIMS(vra1)->lbnd = 0;
  159       ARRAY_DIMS(vra1)->ubnd = LENGTH(vra0) - 1;
  160       ARRAY_DIMS(vra1)->inc = 1;
  161       ARRAY_V(vra1) = vra0;
  162       vra0 = vra1;
  163     }
  164     lvra = EOL;
  165     plvra = &lvra;
  166     for (z = lra; NIMP(z); z = CDR(z)) {
  167       vra1 = ra1 = (0==kmax ? CAR(z) : array_contents(CAR(z), UNDEFINED));
  168       if (FALSEP(ra1)) goto gencase;
  169       if (!ARRAYP(ra1)) {
  170     vra1 = make_ra(1);
  171     ARRAY_DIMS(vra1)->lbnd = ARRAY_DIMS(vra0)->lbnd;
  172     ARRAY_DIMS(vra1)->ubnd = ARRAY_DIMS(vra0)->ubnd;
  173     ARRAY_BASE(vra1) = 0;
  174     ARRAY_DIMS(vra1)->inc = 1;
  175     ARRAY_V(vra1) = ra1;
  176       }
  177       *plvra = cons(vra1, EOL);
  178       plvra = &CDR(*plvra);
  179     }
  180     return (UNBNDP(data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra));
  181   case 1: gencase:      /* Have to loop over all dimensions. */
  182     {
  183       SCM hp_indv;
  184       long auto_indv[5];
  185       long *indv = &auto_indv[0];
  186       if (ARRAY_NDIM(ra0) >= 5) {
  187     scm_protect_temp(&hp_indv);
  188     hp_indv = make_uve(ARRAY_NDIM(ra0)+0L, MAKINUM(-32L));
  189     indv = (long *)VELTS(hp_indv);
  190       }
  191       vra0 = make_ra(1);
  192       if (ARRAYP(ra0)) {
  193     if (kmax < 0) {
  194       ARRAY_DIMS(vra0)->lbnd = 0;
  195       ARRAY_DIMS(vra0)->ubnd = 0;
  196       ARRAY_DIMS(vra0)->inc = 1;
  197     }
  198     else {
  199       ARRAY_DIMS(vra0)->lbnd = ARRAY_DIMS(ra0)[kmax].lbnd;
  200       ARRAY_DIMS(vra0)->ubnd = ARRAY_DIMS(ra0)[kmax].ubnd;
  201       ARRAY_DIMS(vra0)->inc = ARRAY_DIMS(ra0)[kmax].inc;
  202     }
  203     ARRAY_BASE(vra0) = ARRAY_BASE(ra0);
  204     ARRAY_V(vra0) = ARRAY_V(ra0);
  205       }
  206       else {
  207     ARRAY_DIMS(vra0)->lbnd = 0;
  208     ARRAY_DIMS(vra0)->ubnd = LENGTH(ra0) - 1;
  209     ARRAY_DIMS(vra0)->inc = 1;
  210     ARRAY_BASE(vra0) = 0;
  211     ARRAY_V(vra0) = ra0;
  212     ra0 = vra0;
  213       }
  214       lvra = EOL;
  215       plvra = &lvra;
  216       for (z = lra; NIMP(z); z = CDR(z)) {
  217     ra1 = CAR(z);
  218     vra1 = make_ra(1);
  219     ARRAY_DIMS(vra1)->lbnd = ARRAY_DIMS(vra0)->lbnd;
  220     ARRAY_DIMS(vra1)->ubnd = ARRAY_DIMS(vra0)->ubnd;
  221     if (ARRAYP(ra1)) {
  222       if (kmax >= 0)
  223         ARRAY_DIMS(vra1)->inc = ARRAY_DIMS(ra1)[kmax].inc;
  224       ARRAY_V(vra1) = ARRAY_V(ra1);
  225     }
  226     else {
  227       ARRAY_DIMS(vra1)->inc = 1;
  228       ARRAY_V(vra1) = ra1;
  229     }
  230     *plvra = cons(vra1, EOL);
  231     plvra = &CDR(*plvra);
  232       }
  233       for (k = 0; k <= kmax; k++)
  234     indv[k] = ARRAY_DIMS(ra0)[k].lbnd;
  235       k = kmax;
  236       do {
  237     if (k==kmax) {
  238       SCM y = lra;
  239       ARRAY_BASE(vra0) = cind(ra0, indv);
  240       for (z = lvra; NIMP(z); z = CDR(z), y = CDR(y))
  241         ARRAY_BASE(CAR(z)) = cind(CAR(y), indv);
  242       if (0==(UNBNDP(data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra)))
  243         return 0;
  244       k--;
  245       continue;
  246     }
  247     if (indv[k] < ARRAY_DIMS(ra0)[k].ubnd) {
  248       indv[k]++;
  249       k++;
  250       continue;
  251     }
  252     indv[k] = ARRAY_DIMS(ra0)[k].lbnd - 1;
  253     k--;
  254       } while (k >= 0);
  255       return 1;
  256     }
  257   }
  258 }
  259 
  260 SCM array_fill(ra, fill)
  261      SCM ra, fill;
  262 {
  263   ramapc(rafill, fill, ra, EOL, s_array_fill);
  264   return UNSPECIFIED;
  265 }
  266 
  267 static char s_sarray_copy[] = "serial-array:copy!";
  268 static char s_array_copy[] = "array:copy!";
  269 static int racp(src, dst)
  270      SCM dst, src;
  271 {
  272   long n = (ARRAY_DIMS(src)->ubnd - ARRAY_DIMS(src)->lbnd + 1);
  273   long inc_d, inc_s = ARRAY_DIMS(src)->inc;
  274   sizet i_d, i_s = ARRAY_BASE(src);
  275   dst = CAR(dst);
  276   inc_d = ARRAY_DIMS(dst)->inc;
  277   i_d = ARRAY_BASE(dst);
  278   src = ARRAY_V(src);
  279   dst = ARRAY_V(dst);
  280   switch TYP7(dst) {
  281   default: gencase: case tc7_vector:
  282     for (; n-- > 0; i_s += inc_s, i_d += inc_d)
  283       aset(dst, cvref(src, i_s, UNDEFINED), MAKINUM(i_d));
  284     break;
  285   case tc7_string: if (tc7_string != TYP7(src)) goto gencase;
  286     for (; n-- > 0; i_s += inc_s, i_d += inc_d)
  287       CHARS(dst)[i_d] = CHARS(src)[i_s];
  288     break;
  289   case tc7_Vbool: if (tc7_Vbool != TYP7(src)) goto gencase;
  290     if (1==inc_d && 1==inc_s && i_s%LONG_BIT==i_d%LONG_BIT && n>=LONG_BIT) {
  291       long *sv = (long *)VELTS(src);
  292       long *dv = (long *)VELTS(dst);
  293       sv += i_s/LONG_BIT;
  294       dv += i_d/LONG_BIT;
  295       if (i_s % LONG_BIT) { /* leading partial word */
  296     *dv = (*dv & ~(~0L<<(i_s%LONG_BIT))) | (*sv & (~0L<<(i_s%LONG_BIT)));
  297     dv++;
  298     sv++;
  299     n -= LONG_BIT - (i_s % LONG_BIT);
  300       }
  301       IVDEP(src != dst,
  302         for (; n >= LONG_BIT; n -= LONG_BIT, sv++, dv++)
  303           *dv = *sv;)
  304     if (n)          /* trailing partial word */
  305       *dv = (*dv & (~0L<<n)) | (*sv & ~(~0L<<n));
  306     }
  307     else {
  308       for (; n-- > 0; i_s += inc_s, i_d += inc_d)
  309     if (VELTS(src)[i_s/LONG_BIT] & (1L << (i_s%LONG_BIT)))
  310       VELTS(dst)[i_d/LONG_BIT] |= (1L << (i_d%LONG_BIT));
  311     else
  312       VELTS(dst)[i_d/LONG_BIT] &= ~(1L << (i_d%LONG_BIT));
  313     }
  314     break;
  315   case tc7_VfixN32:
  316   case tc7_VfixZ32: {
  317     long *d = (long *)VELTS(dst), *s = (long *)VELTS(src);
  318     if (TYP7(src)==TYP7(dst)) {
  319       IVDEP(src != dst,
  320         for (; n-- > 0; i_s += inc_s, i_d += inc_d)
  321           d[i_d] = s[i_s];)
  322     }
  323     else if (tc7_VfixZ32==TYP7(dst))
  324       for (; n-- > 0; i_s += inc_s, i_d += inc_d)
  325     d[i_d] = num2long(cvref(src, i_s, UNDEFINED),
  326               (char *)ARG2, s_array_copy);
  327     else
  328       for (; n-- > 0; i_s += inc_s, i_d += inc_d)
  329     d[i_d] = num2ulong(cvref(src, i_s, UNDEFINED),
  330                (char *)ARG2, s_array_copy);
  331     break;
  332   }
  333 # ifdef FLOATS
  334   case tc7_VfloR32: {
  335     float *d = (float *)VELTS(dst);
  336     float *s = (float *)VELTS(src);
  337     switch TYP7(src) {
  338     default: goto gencase;
  339     case tc7_VfixZ32: case tc7_VfixN32:
  340       IVDEP(src != dst,
  341         for (; n-- > 0; i_s += inc_s, i_d += inc_d)
  342           d[i_d] = ((long *)s)[i_s]; )
  343     break;
  344     case tc7_VfloR32:
  345       IVDEP(src != dst,
  346         for (; n-- > 0; i_s += inc_s, i_d += inc_d)
  347           d[i_d] = s[i_s]; )
  348     break;
  349     case tc7_VfloR64:
  350       IVDEP(src != dst,
  351         for (; n-- > 0; i_s += inc_s, i_d += inc_d)
  352           d[i_d] = ((double *)s)[i_s]; )
  353     break;
  354     }
  355     break;
  356   }
  357   case tc7_VfloR64: {
  358     double *d = (double *)VELTS(dst);
  359     double *s = (double *)VELTS(src);
  360     switch TYP7(src) {
  361     default: goto gencase;
  362     case tc7_VfixZ32: case tc7_VfixN32:
  363       IVDEP(src != dst,
  364         for (; n-- > 0; i_s += inc_s, i_d += inc_d)
  365           d[i_d] = ((long *)s)[i_s]; )
  366     break;
  367     case tc7_VfloR32:
  368       IVDEP(src != dst,
  369         for (; n-- > 0; i_s += inc_s, i_d += inc_d)
  370           d[i_d] = ((float *)s)[i_s];)
  371     break;
  372     case tc7_VfloR64:
  373       IVDEP(src != dst,
  374         for (; n-- > 0; i_s += inc_s, i_d += inc_d)
  375           d[i_d] = s[i_s];)
  376     break;
  377     }
  378     break;
  379   }
  380   case tc7_VfloC32: {
  381     float (*d)[2] = (float (*)[2])VELTS(dst);
  382     float (*s)[2] = (float (*)[2])VELTS(src);
  383     switch TYP7(src) {
  384     default: goto gencase;
  385     case tc7_VfixZ32: case tc7_VfixN32:
  386       IVDEP(src != dst,
  387         for (; n-- > 0; i_s += inc_s, i_d += inc_d) {
  388           d[i_d][0] = ((long *)s)[i_s];
  389           d[i_d][1] = 0.0;
  390         })
  391     break;
  392     case tc7_VfloR32:
  393       IVDEP(src != dst,
  394         for (; n-- > 0; i_s += inc_s, i_d += inc_d) {
  395           d[i_d][0] = ((float *)s)[i_s];
  396           d[i_d][1] = 0.0;
  397         })
  398     break;
  399     case tc7_VfloR64:
  400       IVDEP(src != dst,
  401         for (; n-- > 0; i_s += inc_s, i_d += inc_d) {
  402           d[i_d][0] = ((double *)s)[i_s];
  403           d[i_d][1] = 0.0;
  404         })
  405     break;
  406     case tc7_VfloC32:
  407       IVDEP(src != dst,
  408         for (; n-- > 0; i_s += inc_s, i_d += inc_d) {
  409           d[i_d][0] = s[i_s][0];
  410           d[i_d][1] = s[i_s][1];
  411         })
  412     break;
  413     case tc7_VfloC64:
  414       IVDEP(src != dst,
  415         for (; n-- > 0; i_s += inc_s, i_d += inc_d) {
  416           d[i_d][0] = ((double (*)[2])s)[i_s][0];
  417           d[i_d][1] = ((double (*)[2])s)[i_s][1];
  418         })
  419     break;
  420     }
  421   }
  422   case tc7_VfloC64: {
  423     double (*d)[2] = (double (*)[2])VELTS(dst);
  424     double (*s)[2] = (double (*)[2])VELTS(src);
  425     switch TYP7(src) {
  426     default: goto gencase;
  427     case tc7_VfixZ32: case tc7_VfixN32:
  428       IVDEP(src != dst,
  429         for (; n-- > 0; i_s += inc_s, i_d += inc_d) {
  430           d[i_d][0] = ((long *)s)[i_s];
  431           d[i_d][1] = 0.0;
  432         })
  433     break;
  434     case tc7_VfloR32:
  435       IVDEP(src != dst,
  436         for (; n-- > 0; i_s += inc_s, i_d += inc_d) {
  437           d[i_d][0] = ((float *)s)[i_s];
  438           d[i_d][1] = 0.0;
  439         })
  440     break;
  441     case tc7_VfloR64:
  442       IVDEP(src != dst,
  443         for (; n-- > 0; i_s += inc_s, i_d += inc_d) {
  444           d[i_d][0] = ((double *)s)[i_s];
  445           d[i_d][1] = 0.0;
  446         })
  447     break;
  448     case tc7_VfloC32:
  449       IVDEP(src != dst,
  450         for (; n-- > 0; i_s += inc_s, i_d += inc_d) {
  451           d[i_d][0] = ((float (*)[2])s)[i_s][0];
  452           d[i_d][1] = ((float (*)[2])s)[i_s][1];
  453         })
  454     break;
  455     case tc7_VfloC64:
  456       IVDEP(src != dst,
  457         for (; n-- > 0; i_s += inc_s, i_d += inc_d) {
  458           d[i_d][0] = s[i_s][0];
  459           d[i_d][1] = s[i_s][1];
  460         })
  461     break;
  462     }
  463   }
  464 # endif /* FLOATS */
  465   }
  466   return 1;
  467 }
  468 SCM array_copy(dst, src)
  469      SCM dst;
  470      SCM src;
  471 {
  472 #ifndef RECKLESS
  473   if (INUM0==array_rank(dst))
  474     ASRTER(NIMP(dst) && ARRAYP(dst) && INUM0==array_rank(src),
  475        dst, ARG2, s_array_copy);
  476 #endif
  477   ramapc(racp, UNDEFINED, src, cons(dst, EOL), s_array_copy);
  478   return UNSPECIFIED;
  479 }
  480 
  481 SCM ra2contig(ra, copy)
  482      SCM ra;
  483      int copy;
  484 {
  485   SCM ret;
  486   long inc = 1;
  487   sizet k, len = 1;
  488   for (k = ARRAY_NDIM(ra); k--;)
  489     len *= ARRAY_DIMS(ra)[k].ubnd - ARRAY_DIMS(ra)[k].lbnd + 1;
  490   k = ARRAY_NDIM(ra);
  491   if (ARRAY_CONTP(ra) && ((0==k) || (1==ARRAY_DIMS(ra)[k-1].inc))) {
  492     if (tc7_Vbool != TYP7(ARRAY_V(ra)))
  493       return ra;
  494     if ((len==LENGTH(ARRAY_V(ra)) &&
  495      0==ARRAY_BASE(ra) % LONG_BIT &&
  496      0==len % LONG_BIT))
  497       return ra;
  498   }
  499   ret = make_ra(k);
  500   ARRAY_BASE(ret) = 0;
  501   while (k--) {
  502     ARRAY_DIMS(ret)[k].lbnd = ARRAY_DIMS(ra)[k].lbnd;
  503     ARRAY_DIMS(ret)[k].ubnd = ARRAY_DIMS(ra)[k].ubnd;
  504     ARRAY_DIMS(ret)[k].inc = inc;
  505     inc *= ARRAY_DIMS(ra)[k].ubnd - ARRAY_DIMS(ra)[k].lbnd + 1;
  506   }
  507   CAR(ret) |= ARRAY_CONTIGUOUS;
  508   ARRAY_V(ret) = make_uve(inc+0L, array_prot(ra));
  509   if (copy) array_copy(ret, ra);
  510   return ret;
  511 }
  512 
  513 static char s_ura_rd[] = "uniform-array-read!";
  514 SCM ura_read(ra, port)
  515      SCM ra, port;
  516 {
  517   SCM ret, cra;
  518   if (NIMP(ra) && ARRAYP(ra)) {
  519     cra = ra2contig(ra, 0);
  520     ret = uve_read(cra, port);
  521     if (cra != ra) array_copy(ra, cra);
  522     return ret;
  523   }
  524   else return uve_read(ra, port);
  525 }
  526 
  527 static char s_ura_wr[] = "uniform-array-write";
  528 SCM ura_write(ra, port)
  529      SCM ra, port;
  530 {
  531   if (NIMP(ra) && ARRAYP(ra))
  532     return uve_write(ra2contig(ra, 1), port);
  533   else
  534     return uve_write(ra, port);
  535 }
  536 
  537 static char s_sc2array[] = "scalar->array";
  538 SCM sc2array(s, ra, prot)
  539      SCM s, ra, prot;
  540 {
  541   SCM res;
  542   ASRTER(NIMP(ra), ra, ARG2, s_sc2array);
  543   if (ARRAYP(ra)) {
  544     int k = ARRAY_NDIM(ra);
  545     res = make_ra(k);
  546     while (k--) {
  547       ARRAY_DIMS(res)[k].ubnd = ARRAY_DIMS(ra)[k].ubnd;
  548       ARRAY_DIMS(res)[k].lbnd = ARRAY_DIMS(ra)[k].lbnd;
  549       ARRAY_DIMS(res)[k].inc = 0;
  550     }
  551     ra = ARRAY_V(ra);
  552   }
  553   else {
  554     ASRTER(BOOL_T==arrayp(ra, UNDEFINED), ra, ARG2, s_sc2array);
  555     res = make_ra(1);
  556     ARRAY_DIMS(res)->ubnd = LENGTH(ra) - 1;
  557     ARRAY_DIMS(res)->lbnd = 0;
  558     ARRAY_DIMS(res)->inc = 0;
  559   }
  560   if (NIMP(s) && ARRAYP(s) && 0==ARRAY_NDIM(s)) {
  561     ARRAY_BASE(res) = ARRAY_BASE(s);
  562     ARRAY_V(res) = ARRAY_V(s);
  563     return res;
  564   }
  565   ARRAY_BASE(res) = 0;
  566   ARRAY_V(res) = make_uve(1L, NULLP(prot) ? array_prot(ra) : CAR(prot));
  567   switch TYP7(ARRAY_V(res)) {
  568   case tc7_vector:
  569     break;
  570   case tc7_Vbool:
  571     if (BOOL_T==s || BOOL_F==s) break;
  572     goto mismatch;
  573   case tc7_string:
  574     if (ICHRP(s)) break;
  575     goto mismatch;
  576   case tc7_VfixN32:
  577     if (INUMP(s) && INUM(s)>=0) break;
  578 #ifdef BIGDIG
  579     if (NIMP(s) && tc16_bigpos==TYP16(s) && NUMDIGS(s)<=DIGSPERLONG) break;
  580 #endif
  581     goto mismatch;
  582   case tc7_VfixZ32:
  583     if (INUMP(s)) break;
  584 #ifdef BIGDIG
  585     if (NIMP(s) && BIGP(s) && NUMDIGS(s)<=DIGSPERLONG) break;
  586 #endif
  587     goto mismatch;
  588 #ifdef FLOATS
  589   case tc7_VfloR32:
  590   case tc7_VfloR64:
  591     if (NUMBERP(s) && !(NIMP(s) && CPLXP(s))) break;
  592     goto mismatch;
  593   case tc7_VfloC32:
  594   case tc7_VfloC64:
  595     if (NUMBERP(s)) break;
  596     goto mismatch;
  597 #endif
  598   mismatch: ARRAY_V(res) = make_vector(MAKINUM(1L), s);
  599     return res;
  600   }
  601   aset(ARRAY_V(res), s, INUM0);
  602   return res;
  603 }
  604 
  605 /* Functions callable by ARRAY-MAP! */
  606 int ra_eqp(ra0, ras)
  607      SCM ra0, ras;
  608 {
  609   SCM ra1 = CAR(ras), ra2 = CAR(CDR(ras));
  610   long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1;
  611   sizet i0 = ARRAY_BASE(ra0), i1 = ARRAY_BASE(ra1), i2 = ARRAY_BASE(ra2);
  612   long inc0 = ARRAY_DIMS(ra0)->inc;
  613   long inc1 = ARRAY_DIMS(ra1)->inc;
  614   long inc2 = ARRAY_DIMS(ra2)->inc;
  615   ra0 = ARRAY_V(ra0);
  616   ra1 = ARRAY_V(ra1);
  617   ra2 = ARRAY_V(ra2);
  618   switch (TYP7(ra1)==TYP7(ra2) ? TYP7(ra1) : 0) {
  619   default: {
  620     SCM e1 = UNDEFINED, e2 = UNDEFINED;
  621     for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
  622       if (BVE_REF(ra0, i0))
  623     if (FALSEP(eqp(RVREF(ra1, i1, e1), RVREF(ra2, i2, e2))))
  624       BVE_CLR(ra0, i0);
  625     break;
  626   }
  627   case tc7_VfixN32:
  628   case tc7_VfixZ32:
  629     for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
  630       if (BVE_REF(ra0, i0))
  631     if (VELTS(ra1)[i1] != VELTS(ra2)[i2]) BVE_CLR(ra0, i0);
  632     break;
  633 # ifdef FLOATS
  634   case tc7_VfloR32:
  635     for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
  636       if (BVE_REF(ra0, i0))
  637     if (((float *)VELTS(ra1))[i1] != ((float *)VELTS(ra2))[i2])
  638       BVE_CLR(ra0, i0);
  639     break;
  640   case tc7_VfloR64:
  641     for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
  642       if (BVE_REF(ra0, i0))
  643     if (((double *)VELTS(ra1))[i1] != ((double *)VELTS(ra2))[i2])
  644       BVE_CLR(ra0, i0);
  645     break;
  646   case tc7_VfloC32:
  647     for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
  648       if (BVE_REF(ra0, i0))
  649     if (((float *)VELTS(ra1))[2*i1] != ((float *)VELTS(ra2))[2*i2] ||
  650         ((float *)VELTS(ra1))[2*i1+1] != ((float *)VELTS(ra2))[2*i2+1])
  651       BVE_CLR(ra0, i0);
  652     break;
  653   case tc7_VfloC64:
  654     for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
  655       if (BVE_REF(ra0, i0))
  656     if (((double *)VELTS(ra1))[2*i1] != ((double *)VELTS(ra2))[2*i2] ||
  657         ((double *)VELTS(ra1))[2*i1+1] != ((double *)VELTS(ra2))[2*i2+1])
  658       BVE_CLR(ra0, i0);
  659     break;
  660 # endif /*FLOATS*/
  661   }
  662   return 1;
  663 }
  664 /* opt 0 means <, nonzero means >= */
  665 static int ra_compare(ra0, ra1, ra2, opt)
  666      SCM ra0, ra1, ra2;
  667      int opt;
  668 {
  669   long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1;
  670   sizet i0 = ARRAY_BASE(ra0), i1 = ARRAY_BASE(ra1), i2 = ARRAY_BASE(ra2);
  671   long inc0 = ARRAY_DIMS(ra0)->inc;
  672   long inc1 = ARRAY_DIMS(ra1)->inc;
  673   long inc2 = ARRAY_DIMS(ra2)->inc;
  674   ra0 = ARRAY_V(ra0);
  675   ra1 = ARRAY_V(ra1);
  676   ra2 = ARRAY_V(ra2);
  677   switch (TYP7(ra1)==TYP7(ra2) ? TYP7(ra1) : 0) {
  678   default: {
  679     SCM e1 = UNDEFINED, e2 = UNDEFINED;
  680     for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
  681       if (BVE_REF(ra0, i0))
  682     if (opt ?
  683         NFALSEP(lessp(RVREF(ra1, i1, e1), RVREF(ra2, i2, e2))) :
  684         FALSEP(lessp(RVREF(ra1, i1, e1), RVREF(ra2, i2, e2))) )
  685       BVE_CLR(ra0, i0);
  686     break;
  687   }
  688   case tc7_VfixN32:
  689     for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) {
  690       if (BVE_REF(ra0, i0))
  691     if (opt ?
  692         ((unsigned long *)VELTS(ra1))[i1] < ((unsigned long *)VELTS(ra2))[i2] :
  693         ((unsigned long *)VELTS(ra1))[i1] >= ((unsigned long *)VELTS(ra2))[i2])
  694       BVE_CLR(ra0, i0);
  695     }
  696     break;
  697   case tc7_VfixZ32:
  698     for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) {
  699       if (BVE_REF(ra0, i0))
  700     if (opt ?
  701         VELTS(ra1)[i1] < VELTS(ra2)[i2] :
  702         VELTS(ra1)[i1] >= VELTS(ra2)[i2])
  703       BVE_CLR(ra0, i0);
  704     }
  705     break;
  706 # ifdef FLOATS
  707   case tc7_VfloR32:
  708     for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
  709       if (BVE_REF(ra0, i0))
  710     if (opt ?
  711         ((float *)VELTS(ra1))[i1] < ((float *)VELTS(ra2))[i2] :
  712         ((float *)VELTS(ra1))[i1] >= ((float *)VELTS(ra2))[i2])
  713       BVE_CLR(ra0, i0);
  714     break;
  715   case tc7_VfloR64:
  716     for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
  717       if (BVE_REF(ra0, i0))
  718     if (opt ?
  719         ((double *)VELTS(ra1))[i1] < ((double *)VELTS(ra2))[i2] :
  720         ((double *)VELTS(ra1))[i1] >= ((double *)VELTS(ra2))[i2])
  721       BVE_CLR(ra0, i0);
  722     break;
  723 # endif /*FLOATS*/
  724   }
  725   return 1;
  726 }
  727 int ra_lessp(ra0, ras)
  728      SCM ra0, ras;
  729 {
  730  return ra_compare(ra0, CAR(ras), CAR(CDR(ras)), 0);
  731 }
  732 int ra_leqp(ra0, ras)
  733      SCM ra0, ras;
  734 {
  735   return ra_compare(ra0, CAR(CDR(ras)), CAR(ras), 1);
  736 }
  737 int ra_grp(ra0, ras)
  738      SCM ra0, ras;
  739 {
  740   return ra_compare(ra0, CAR(CDR(ras)), CAR(ras), 0);
  741 }
  742 int ra_greqp(ra0, ras)
  743      SCM ra0, ras;
  744 {
  745   return ra_compare(ra0, CAR(ras), CAR(CDR(ras)), 1);
  746 }
  747 
  748 int ra_sum(ra0, ras)
  749      SCM ra0, ras;
  750 {
  751   long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1;
  752   sizet i0 = ARRAY_BASE(ra0);
  753   long inc0 = ARRAY_DIMS(ra0)->inc;
  754   ra0 = ARRAY_V(ra0);
  755   if (NNULLP(ras)) {
  756     SCM ra1 = CAR(ras);
  757     sizet i1 = ARRAY_BASE(ra1);
  758     long inc1 = ARRAY_DIMS(ra1)->inc;
  759     ra1 = ARRAY_V(ra1);
  760     switch (TYP7(ra0)==TYP7(ra1) ? TYP7(ra0) : 0) {
  761     ovflow: wta(ra0, (char *)OVFLOW, "+");
  762     default: {
  763       SCM e0 = UNDEFINED, e1 = UNDEFINED;
  764       for (; n-- > 0; i0 += inc0, i1 += inc1)
  765     aset(ra0, sum(RVREF(ra0, i0, e0), RVREF(ra1, i1, e1)),
  766          MAKINUM(i0));
  767       break;
  768     }
  769     case tc7_VfixN32: {
  770       unsigned long r;
  771       unsigned long *v0 = (unsigned long *)VELTS(ra0);
  772       unsigned long *v1 = (unsigned long *)VELTS(ra1);
  773       IVDEP(ra0 != ra1,
  774         for (; n-- > 0; i0 += inc0, i1 += inc1) {
  775           r = v0[i0] + v1[i1];
  776           ASRTGO(r >= v0[i0], ovflow); /* Will prevent vectorization */
  777           v0[i0] = r;
  778         } );
  779       break;
  780     }
  781     case tc7_VfixZ32: {
  782       long r, *v0 = (long *)VELTS(ra0), *v1 = (long *)VELTS(ra1);
  783       IVDEP(ra0 != ra1,
  784         for (; n-- > 0; i0 += inc0, i1 += inc1) {
  785           r = v0[i0] + v1[i1];
  786           ASRTGO((v0[i0]>0 ? r>=0 || v1[i1]<0 : r<=0 || v1[i1]>0), ovflow);
  787           v0[i0] = r;
  788         } );
  789       break;
  790     }
  791 # ifdef FLOATS
  792     case tc7_VfloR32: {
  793       float *v0 = (float *)VELTS(ra0);
  794       float *v1 = (float *)VELTS(ra1);
  795       IVDEP(ra0 != ra1,
  796         for (; n-- > 0; i0 += inc0, i1 += inc1)
  797           v0[i0] += v1[i1]);
  798       break;
  799     }
  800     case tc7_VfloR64: {
  801       double *v0 = (double *)VELTS(ra0);
  802       double *v1 = (double *)VELTS(ra1);
  803       IVDEP(ra0 != ra1,
  804         for (; n-- > 0; i0 += inc0, i1 += inc1)
  805           v0[i0] += v1[i1]);
  806       break;
  807     }
  808     case tc7_VfloC32: {
  809       float (*v0)[2] = (float (*)[2])VELTS(ra0);
  810       float (*v1)[2] = (float (*)[2])VELTS(ra1);
  811       IVDEP(ra0 != ra1,
  812         for (; n-- > 0; i0 += inc0, i1 += inc1) {
  813           v0[i0][0] += v1[i1][0];
  814           v0[i0][1] += v1[i1][1];
  815         });
  816       break;
  817     }
  818     case tc7_VfloC64: {
  819       double (*v0)[2] = (double (*)[2])VELTS(ra0);
  820       double (*v1)[2] = (double (*)[2])VELTS(ra1);
  821       IVDEP(ra0 != ra1,
  822         for (; n-- > 0; i0 += inc0, i1 += inc1) {
  823           v0[i0][0] += v1[i1][0];
  824           v0[i0][1] += v1[i1][1];
  825         });
  826       break;
  827     }
  828 # endif /* FLOATS */
  829     }
  830   }
  831   return 1;
  832 }
  833 
  834 int ra_difference(ra0, ras)
  835      SCM ra0, ras;
  836 {
  837   long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1;
  838   sizet i0 = ARRAY_BASE(ra0);
  839   long inc0 = ARRAY_DIMS(ra0)->inc;
  840   ra0 = ARRAY_V(ra0);
  841   if (NULLP(ras)) {
  842     switch TYP7(ra0) {
  843     default: {
  844       SCM e0 = UNDEFINED;
  845       for (; n-- > 0; i0 += inc0)
  846     aset(ra0, difference(RVREF(ra0, i0, e0), UNDEFINED), MAKINUM(i0));
  847       break;
  848     }
  849     case tc7_VfixZ32: {
  850       long *v0 = VELTS(ra0);
  851       for (; n-- > 0; i0 += inc0)
  852     v0[i0] = -v0[i0];
  853       break;
  854     }
  855 # ifdef FLOATS
  856     case tc7_VfloR32: {
  857       float *v0 = (float *)VELTS(ra0);
  858       for (; n-- > 0; i0 += inc0)
  859     v0[i0] = -v0[i0];
  860       break;
  861     }
  862     case tc7_VfloR64: {
  863       double *v0 = (double *)VELTS(ra0);
  864       for (; n-- > 0; i0 += inc0)
  865     v0[i0] = -v0[i0];
  866       break;
  867     }
  868     case tc7_VfloC32: {
  869       float (*v0)[2] = (float (*)[2])VELTS(ra0);
  870       for (; n-- > 0; i0 += inc0) {
  871     v0[i0][0] = -v0[i0][0];
  872     v0[i0][1] = -v0[i0][1];
  873       }
  874       break;
  875     }
  876     case tc7_VfloC64: {
  877       double (*v0)[2] = (double (*)[2])VELTS(ra0);
  878       for (; n-- > 0; i0 += inc0) {
  879     v0[i0][0] = -v0[i0][0];
  880     v0[i0][1] = -v0[i0][1];
  881       }
  882       break;
  883     }
  884 # endif /* FLOATS */
  885     }
  886   }
  887   else {
  888     SCM ra1 = CAR(ras);
  889     sizet i1 = ARRAY_BASE(ra1);
  890     long inc1 = ARRAY_DIMS(ra1)->inc;
  891     ra1 = ARRAY_V(ra1);
  892     switch (TYP7(ra0)==TYP7(ra1) ? TYP7(ra0) : 0) {
  893     ovflow: wta(ra0, (char *)OVFLOW, "-");
  894     default: {
  895       SCM e0 = UNDEFINED, e1 = UNDEFINED;
  896       for (; n-- > 0; i0 += inc0, i1 += inc1)
  897     aset(ra0, difference(RVREF(ra0, i0, e0), RVREF(ra1, i1, e1)), MAKINUM(i0));
  898       break;
  899     }
  900     case tc7_VfixN32: {
  901       unsigned long r;
  902       unsigned long *v0 = (unsigned long *)VELTS(ra0);
  903       unsigned long *v1 = (unsigned long *)VELTS(ra1);
  904       IVDEP(ra0 != ra1,
  905         for (; n-- > 0; i0 += inc0, i1 += inc1) {
  906           r = v0[i0] - v1[i1];
  907           ASRTGO(r <= v0[i0], ovflow);
  908           v0[i0] = r;
  909         } );
  910       break;
  911     }
  912     case tc7_VfixZ32: {
  913       long r, *v0 = VELTS(ra0), *v1 = VELTS(ra1);
  914       IVDEP(ra0 != ra1,
  915         for (; n-- > 0; i0 += inc0, i1 += inc1) {
  916           r = v0[i0] - v1[i1];
  917           ASRTGO((v0[i0]>0 ? r>=0 || v1[i1]>0 : r<=0 || v1[i1]<0), ovflow);
  918           v0[i0] = r;
  919         } );
  920       break;
  921     }
  922 # ifdef FLOATS
  923     case tc7_VfloR32: {
  924       float *v0 = (float *)VELTS(ra0);
  925       float *v1 = (float *)VELTS(ra1);
  926       IVDEP(ra0 != ra1,
  927         for (; n-- > 0; i0 += inc0, i1 += inc1)
  928           v0[i0] -= v1[i1]);
  929       break;
  930     }
  931     case tc7_VfloR64: {
  932       double *v0 = (double *)VELTS(ra0);
  933       double *v1 = (double *)VELTS(ra1);
  934       IVDEP(ra0 != ra1,
  935         for (; n-- > 0; i0 += inc0, i1 += inc1)
  936           v0[i0] -= v1[i1]);
  937       break;
  938     }
  939     case tc7_VfloC32: {
  940       float (*v0)[2] = (float (*)[2])VELTS(ra0);
  941       float (*v1)[2] = (float (*)[2])VELTS(ra1);
  942       IVDEP(ra0 != ra1,
  943         for (; n-- > 0; i0 += inc0, i1 += inc1) {
  944           v0[i0][0] -= v1[i1][0];
  945           v0[i0][1] -= v1[i1][1];
  946         })
  947       break;
  948     }
  949     case tc7_VfloC64: {
  950       double (*v0)[2] = (double (*)[2])VELTS(ra0);
  951       double (*v1)[2] = (double (*)[2])VELTS(ra1);
  952       IVDEP(ra0 != ra1,
  953         for (; n-- > 0; i0 += inc0, i1 += inc1) {
  954           v0[i0][0] -= v1[i1][0];
  955           v0[i0][1] -= v1[i1][1];
  956         })
  957       break;
  958     }
  959 # endif /* FLOATS */
  960     }
  961   }
  962   return 1;
  963 }
  964 
  965 int ra_product(ra0, ras)
  966      SCM ra0, ras;
  967 {
  968   long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1;
  969   sizet i0 = ARRAY_BASE(ra0);
  970   long inc0 = ARRAY_DIMS(ra0)->inc;
  971   ra0 = ARRAY_V(ra0);
  972   if (NNULLP(ras)) {
  973     SCM ra1 = CAR(ras);
  974     sizet i1 = ARRAY_BASE(ra1);
  975     long inc1 = ARRAY_DIMS(ra1)->inc;
  976     ra1 = ARRAY_V(ra1);
  977     switch (TYP7(ra0)==TYP7(ra1) ? TYP7(ra0) : 0) {
  978     ovflow: wta(ra0, (char *)OVFLOW, "*");
  979     default: {
  980       SCM e0 = UNDEFINED, e1 = UNDEFINED;
  981       for (; n-- > 0; i0 += inc0, i1 += inc1)
  982     aset(ra0, product(RVREF(ra0, i0, e0), RVREF(ra1, i1, e1)),
  983          MAKINUM(i0));
  984       break;
  985     }
  986     case tc7_VfixN32: {
  987       unsigned long r;
  988       unsigned long *v0 = (unsigned long *)VELTS(ra0);
  989       unsigned long *v1 = (unsigned long *)VELTS(ra1);
  990       IVDEP(ra0 != ra1,
  991         for (; n-- > 0; i0 += inc0, i1 += inc1) {
  992           r = v0[i0] * v1[i1];
  993           ASRTGO(0==v0[i0] || v1[i1]==r/v0[i0], ovflow);
  994           v0[i0] = r;
  995         } );
  996       break;
  997     }
  998     case tc7_VfixZ32: {
  999       long r, *v0 = VELTS(ra0), *v1 =VELTS(ra1);
 1000       IVDEP(ra0 != ra1,
 1001         for (; n-- > 0; i0 += inc0, i1 += inc1) {
 1002           r = v0[i0] * v1[i1];
 1003           ASRTGO(0==v0[i0] || v1[i1]==r/v0[i0], ovflow);
 1004           v0[i0] = r;
 1005         } );
 1006       break;
 1007     }
 1008 # ifdef FLOATS
 1009     case tc7_VfloR32: {
 1010       float *v0 = (float *)VELTS(ra0);
 1011       float *v1 = (float *)VELTS(ra1);
 1012       IVDEP(ra0 != ra1,
 1013         for (; n-- > 0; i0 += inc0, i1 += inc1)
 1014           v0[i0] *= v1[i1]);
 1015       break;
 1016     }
 1017     case tc7_VfloR64: {
 1018       double *v0 = (double *)VELTS(ra0);
 1019       double *v1 = (double *)VELTS(ra1);
 1020       IVDEP(ra0 != ra1,
 1021         for (; n-- > 0; i0 += inc0, i1 += inc1)
 1022           v0[i0] *= v1[i1]);
 1023       break;
 1024     }
 1025     case tc7_VfloC32: {
 1026       float (*v0)[2] = (float (*)[2])VELTS(ra0);
 1027       register double r;
 1028       float (*v1)[2] = (float (*)[2])VELTS(ra1);
 1029       IVDEP(ra0 != ra1,
 1030         for (; n-- > 0; i0 += inc0, i1 += inc1) {
 1031           r = v0[i0][0]*v1[i1][0] - v0[i0][1]*v1[i1][1];
 1032           v0[i0][1] = v0[i0][0]*v1[i1][1] + v0[i0][1]*v1[i1][0];
 1033           v0[i0][0] = r;
 1034         });
 1035       break;
 1036     }
 1037     case tc7_VfloC64: {
 1038       double (*v0)[2] = (double (*)[2])VELTS(ra0);
 1039       register double r;
 1040       double (*v1)[2] = (double (*)[2])VELTS(ra1);
 1041       IVDEP(ra0 != ra1,
 1042         for (; n-- > 0; i0 += inc0, i1 += inc1) {
 1043           r = v0[i0][0]*v1[i1][0] - v0[i0][1]*v1[i1][1];
 1044           v0[i0][1] = v0[i0][0]*v1[i1][1] + v0[i0][1]*v1[i1][0];
 1045           v0[i0][0] = r;
 1046         });
 1047       break;
 1048     }
 1049 # endif /* FLOATS */
 1050     }
 1051   }
 1052   return 1;
 1053 }
 1054 int ra_divide(ra0, ras)
 1055      SCM ra0, ras;
 1056 {
 1057   long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1;
 1058   sizet i0 = ARRAY_BASE(ra0);
 1059   long inc0 = ARRAY_DIMS(ra0)->inc;
 1060   ra0 = ARRAY_V(ra0);
 1061   if (NULLP(ras)) {
 1062     switch TYP7(ra0) {
 1063     default: {
 1064       SCM e0 = UNDEFINED;
 1065       for (; n-- > 0; i0 += inc0)
 1066     aset(ra0, divide(RVREF(ra0, i0, e0), UNDEFINED), MAKINUM(i0));
 1067       break;
 1068     }
 1069 # ifdef FLOATS
 1070     case tc7_VfloR32: {
 1071       float *v0 = (float *)VELTS(ra0);
 1072       for (; n-- > 0; i0 += inc0)
 1073     v0[i0] = 1.0/v0[i0];
 1074       break;
 1075     }
 1076     case tc7_VfloR64: {
 1077       double *v0 = (double *)VELTS(ra0);
 1078       for (; n-- > 0; i0 += inc0)
 1079     v0[i0] = 1.0/v0[i0];
 1080       break;
 1081     }
 1082     case tc7_VfloC32: {
 1083       register double d;
 1084       float (*v0)[2] = (float (*)[2])VELTS(ra0);
 1085       for (; n-- > 0; i0 += inc0) {
 1086     d = v0[i0][0]*v0[i0][0] + v0[i0][1]*v0[i0][1];
 1087     v0[i0][0] /= d;
 1088     v0[i0][1] /= -d;
 1089       }
 1090       break;
 1091     }
 1092     case tc7_VfloC64: {
 1093       register double d;
 1094       double (*v0)[2] = (double (*)[2])VELTS(ra0);
 1095       for (; n-- > 0; i0 += inc0) {
 1096     d = v0[i0][0]*v0[i0][0] + v0[i0][1]*v0[i0][1];
 1097     v0[i0][0] /= d;
 1098     v0[i0][1] /= -d;
 1099       }
 1100       break;
 1101     }
 1102 # endif /* FLOATS */
 1103     }
 1104   }
 1105   else {
 1106     SCM ra1 = CAR(ras);
 1107     sizet i1 = ARRAY_BASE(ra1);
 1108     long inc1 = ARRAY_DIMS(ra1)->inc;
 1109     ra1 = ARRAY_V(ra1);
 1110     switch (TYP7(ra0)==TYP7(ra1) ? TYP7(ra0) : 0) {
 1111     default: {
 1112       SCM e0 = UNDEFINED, e1 = UNDEFINED;
 1113       for (; n-- > 0; i0 += inc0, i1 += inc1)
 1114     aset(ra0, divide(RVREF(ra0, i0, e0), RVREF(ra1, i1, e1)), MAKINUM(i0));
 1115       break;
 1116     }
 1117 # ifdef FLOATS
 1118     case tc7_VfloR32: {
 1119       float *v0 = (float *)VELTS(ra0);
 1120       float *v1 = (float *)VELTS(ra1);
 1121       IVDEP(ra0 != ra1,
 1122         for (; n-- > 0; i0 += inc0, i1 += inc1)
 1123           v0[i0] /= v1[i1]);
 1124       break;
 1125     }
 1126     case tc7_VfloR64: {
 1127       double *v0 = (double *)VELTS(ra0);
 1128       double *v1 = (double *)VELTS(ra1);
 1129       IVDEP(ra0 != ra1,
 1130         for (; n-- > 0; i0 += inc0, i1 += inc1)
 1131           v0[i0] /= v1[i1]);
 1132       break;
 1133     }
 1134     case tc7_VfloC32: {
 1135       register double d, r;
 1136       float (*v0)[2] = (float (*)[2])VELTS(ra0);
 1137       float (*v1)[2] = (float (*)[2])VELTS(ra1);
 1138       IVDEP(ra0 != ra1,
 1139         for (; n-- > 0; i0 += inc0, i1 += inc1) {
 1140           d = v1[i1][0]*v1[i1][0] + v1[i1][1]*v1[i1][1];
 1141           r = (v0[i0][0]*v1[i1][0] + v0[i0][1]*v1[i1][1])/d;
 1142           v0[i0][1] = (v0[i0][1]*v1[i1][0] - v0[i0][0]*v1[i1][1])/d;
 1143           v0[i0][0] = r;
 1144         })
 1145       break;
 1146     }
 1147     case tc7_VfloC64: {
 1148       register double d, r;
 1149       double (*v0)[2] = (double (*)[2])VELTS(ra0);
 1150       double (*v1)[2] = (double (*)[2])VELTS(ra1);
 1151       IVDEP(ra0 != ra1,
 1152         for (; n-- > 0; i0 += inc0, i1 += inc1) {
 1153           d = v1[i1][0]*v1[i1][0] + v1[i1][1]*v1[i1][1];
 1154           r = (v0[i0][0]*v1[i1][0] + v0[i0][1]*v1[i1][1])/d;
 1155           v0[i0][1] = (v0[i0][1]*v1[i1][0] - v0[i0][0]*v1[i1][1])/d;
 1156           v0[i0][0] = r;
 1157         })
 1158       break;
 1159     }
 1160 # endif /* FLOATS */
 1161     }
 1162   }
 1163   return 1;
 1164 }
 1165 static int ra_identity(dst, src)
 1166      SCM src, dst;
 1167 {
 1168   return racp(CAR(src), cons(dst, EOL));
 1169 }
 1170 
 1171 static int ramap(ra0, proc, ras)
 1172      SCM ra0, proc, ras;
 1173 {
 1174   SCM heap_ve, auto_rav[5], auto_argv[5];
 1175   SCM *rav = &auto_rav[0], *argv = &auto_argv[0];
 1176   long argc = ilength(ras);
 1177   long i, k, inc, n, base;
 1178   scm_protect_temp(&heap_ve);
 1179   if (argc >= 5) {
 1180     heap_ve = make_vector(MAKINUM(2*argc), BOOL_F);
 1181     rav = VELTS(heap_ve);
 1182     argv = &(rav[argc]);
 1183   }
 1184   for (k = 0; k < argc; k++) {
 1185     rav[k] = CAR(ras);
 1186     ras = CDR(ras);
 1187   }
 1188   i = ARRAY_DIMS(ra0)->lbnd;
 1189   inc = ARRAY_DIMS(ra0)->inc;
 1190   n = ARRAY_DIMS(ra0)->ubnd;
 1191   base = ARRAY_BASE(ra0) - i*inc;
 1192   ra0 = ARRAY_V(ra0);
 1193   for (; i <= n; i++) {
 1194     for (k = 0; k < argc; k++)
 1195       argv[k] = aref(rav[k], MAKINUM(i));
 1196     aset(ra0, scm_cvapply(proc, argc, argv), MAKINUM(i*inc + base));
 1197   }
 1198   return 1;
 1199 }
 1200 static int ramap_cxr(ra0, proc, ras)
 1201      SCM ra0, proc, ras;
 1202 {
 1203   SCM ra1 = CAR(ras);
 1204   SCM e1 = UNDEFINED;
 1205   sizet i0 = ARRAY_BASE(ra0), i1 = ARRAY_BASE(ra1);
 1206   long inc0 = ARRAY_DIMS(ra0)->inc, inc1 = ARRAY_DIMS(ra1)->inc;
 1207   long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra1)->lbnd + 1;
 1208   ra0 = ARRAY_V(ra0);
 1209   ra1 = ARRAY_V(ra1);
 1210   switch TYP7(ra0) {
 1211   default: gencase:
 1212     for (; n-- > 0; i0 += inc0, i1 += inc1) {
 1213       e1 = cvref(ra1, i1, e1);
 1214       aset(ra0, scm_cvapply(proc, 1L, &e1), MAKINUM(i0));
 1215     }
 1216     break;
 1217 # ifdef FLOATS
 1218   case tc7_VfloR32: {
 1219     float *dst = (float *)VELTS(ra0);
 1220     switch TYP7(ra1) {
 1221     default: goto gencase;
 1222     case tc7_VfloR32:
 1223       for (; n-- > 0; i0 += inc0, i1 += inc1)
 1224     dst[i0] = DSUBRF(proc)((double)((float *)VELTS(ra1))[i1]);
 1225       break;
 1226     case tc7_VfixN32:
 1227     case tc7_VfixZ32:
 1228       for (; n-- > 0; i0 += inc0, i1 += inc1)
 1229     dst[i0] = DSUBRF(proc)((double)VELTS(ra1)[i1]);
 1230       break;
 1231     }
 1232     break;
 1233   }
 1234   case tc7_VfloR64: {
 1235     double *dst = (double *)VELTS(ra0);
 1236     switch TYP7(ra1) {
 1237     default: goto gencase;
 1238     case tc7_VfloR64:
 1239       for (; n-- > 0; i0 += inc0, i1 += inc1)
 1240     dst[i0] = DSUBRF(proc)(((double *)VELTS(ra1))[i1]);
 1241       break;
 1242     case tc7_VfixN32:
 1243     case tc7_VfixZ32:
 1244       for (; n-- > 0; i0 += inc0, i1 += inc1)
 1245     dst[i0] = DSUBRF(proc)((double)VELTS(ra1)[i1]);
 1246       break;
 1247     }
 1248     break;
 1249   }
 1250 # endif /* FLOATS */
 1251   }
 1252   return 1;
 1253 }
 1254 static int ramap_rp(ra0, proc, ras)
 1255      SCM ra0, proc, ras;
 1256 {
 1257   SCM ra1 = CAR(ras), ra2 = CAR(CDR(ras));
 1258   SCM e1 = UNDEFINED, e2 = UNDEFINED;
 1259   long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1;
 1260   sizet i0 = ARRAY_BASE(ra0), i1 = ARRAY_BASE(ra1), i2 = ARRAY_BASE(ra2);
 1261   long inc0 = ARRAY_DIMS(ra0)->inc;
 1262   long inc1 = ARRAY_DIMS(ra1)->inc;
 1263   long inc2 = ARRAY_DIMS(ra2)->inc;
 1264   ra0 = ARRAY_V(ra0);
 1265   ra1 = ARRAY_V(ra1);
 1266   ra2 = ARRAY_V(ra2);
 1267   for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
 1268     if (BVE_REF(ra0, i0))
 1269       if (FALSEP(SUBRF(proc)(RVREF(ra1, i1, e1), RVREF(ra2, i2, e2))))
 1270     BVE_CLR(ra0, i0);
 1271   return 1;
 1272 }
 1273 static int ramap_1(ra0, proc, ras)
 1274      SCM ra0, proc, ras;
 1275 {
 1276   SCM ra1 = CAR(ras);
 1277   SCM e1 = UNDEFINED;
 1278   long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1;
 1279   sizet i0 = ARRAY_BASE(ra0), i1 = ARRAY_BASE(ra1);
 1280   long inc0 = ARRAY_DIMS(ra0)->inc, inc1 = ARRAY_DIMS(ra1)->inc;
 1281   ra0 = ARRAY_V(ra0);
 1282   ra1 = ARRAY_V(ra1);
 1283   if (tc7_vector==TYP7(ra0))
 1284     for (; n-- > 0; i0 += inc0, i1 += inc1)
 1285       VELTS(ra0)[i0] = SUBRF(proc)(cvref(ra1, i1, UNDEFINED));
 1286   else
 1287     for (; n-- > 0; i0 += inc0, i1 += inc1)
 1288       aset(ra0, SUBRF(proc)(RVREF(ra1, i1, e1)), MAKINUM(i0));
 1289   return 1;
 1290 }
 1291 static int ramap_2o(ra0, proc, ras)
 1292      SCM ra0, proc, ras;
 1293 {
 1294   SCM ra1 = CAR(ras);
 1295   SCM e1 = UNDEFINED;
 1296   long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1;
 1297   sizet i0 = ARRAY_BASE(ra0), i1 = ARRAY_BASE(ra1);
 1298   long inc0 = ARRAY_DIMS(ra0)->inc, inc1 = ARRAY_DIMS(ra1)->inc;
 1299   ra0 = ARRAY_V(ra0);
 1300   ra1 = ARRAY_V(ra1);
 1301   ras = CDR(ras);
 1302   if (NULLP(ras)) {
 1303     if (tc7_vector==TYP7(ra0))
 1304       for (; n-- > 0; i0 += inc0, i1 += inc1)
 1305     VELTS(ra0)[i0] = SUBRF(proc)(cvref(ra1, i1, UNDEFINED), UNDEFINED);
 1306     else
 1307       for (; n-- > 0; i0 += inc0, i1 += inc1)
 1308     aset(ra0, SUBRF(proc)(RVREF(ra1, i1, e1), UNDEFINED),
 1309          MAKINUM(i0));
 1310   }
 1311   else {
 1312     SCM ra2 = CAR(ras);
 1313     SCM e2 = UNDEFINED;
 1314     sizet i2 = ARRAY_BASE(ra2);
 1315     long inc2 = ARRAY_DIMS(ra2)->inc;
 1316     ra2 = ARRAY_V(ra2);
 1317     if (tc7_vector==TYP7(ra0))
 1318       for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
 1319     VELTS(ra0)[i0] =
 1320       SUBRF(proc)(cvref(ra1, i1, UNDEFINED), cvref(ra2, i2, UNDEFINED));
 1321     else
 1322       for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
 1323     aset(ra0,
 1324          SUBRF(proc)(RVREF(ra1, i1, e1), RVREF(ra2, i2, e2)),
 1325          MAKINUM(i0));
 1326   }
 1327   return 1;
 1328 }
 1329 static int ramap_a(ra0, proc, ras)
 1330      SCM ra0, proc, ras;
 1331 {
 1332   SCM e0 = UNDEFINED, e1 = UNDEFINED;
 1333   long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1;
 1334   sizet i0 = ARRAY_BASE(ra0);
 1335   long inc0 = ARRAY_DIMS(ra0)->inc;
 1336   ra0 = ARRAY_V(ra0);
 1337   if (NULLP(ras))
 1338     for (; n-- > 0; i0 += inc0)
 1339       aset(ra0, SUBRF(proc)(RVREF(ra0, i0, e0), UNDEFINED), MAKINUM(i0));
 1340   else {
 1341     SCM ra1 = CAR(ras);
 1342     sizet i1 = ARRAY_BASE(ra1);
 1343     long inc1 = ARRAY_DIMS(ra1)->inc;
 1344     ra1 = ARRAY_V(ra1);
 1345     for (; n-- > 0; i0 += inc0, i1 += inc1)
 1346       aset(ra0, SUBRF(proc)(RVREF(ra0, i0, e0), RVREF(ra1, i1, e1)),
 1347        MAKINUM(i0));
 1348   }
 1349   return 1;
 1350 }
 1351 
 1352 /* These tables are a kluge that will not scale well when more
 1353  vectorized subrs are added.  It is tempting to steal some bits from
 1354  the CAR of all subrs (like those selected by SMOBNUM) to hold an
 1355  offset into a table of vectorized subrs.  */
 1356 
 1357 static ra_iproc ra_rpsubrs[] = {
 1358   {"=", UNDEFINED, ra_eqp},
 1359   {"<", UNDEFINED, ra_lessp},
 1360   {"<=", UNDEFINED, ra_leqp},
 1361   {">", UNDEFINED, ra_grp},
 1362   {">=", UNDEFINED, ra_greqp},
 1363   {0, 0, 0}};
 1364 static ra_iproc ra_asubrs[] = {
 1365   {"+", UNDEFINED, ra_sum},
 1366   {"-", UNDEFINED, ra_difference},
 1367   {"*", UNDEFINED, ra_product},
 1368   {"/", UNDEFINED, ra_divide},
 1369   {0, 0, 0}};
 1370 
 1371 static char s_sarray_map[] = "serial-array-map!";
 1372 # define s_array_map  (s_sarray_map + 7)
 1373 SCM array_map(ra0, proc, lra)
 1374      SCM ra0, proc, lra;
 1375 {
 1376   long narg = ilength(lra);
 1377  tail:
 1378 #ifndef RECKLESS
 1379     scm_arity_check(proc, narg, s_array_map);
 1380 #endif
 1381   switch TYP7(proc) {
 1382   default: gencase:
 1383     ramapc(ramap, proc, ra0, lra, s_array_map);
 1384     return UNSPECIFIED;
 1385   case tc7_subr_1:
 1386     ramapc(ramap_1, proc, ra0, lra, s_array_map);
 1387     return UNSPECIFIED;
 1388   case tc7_subr_2:
 1389   case tc7_subr_2o:
 1390     ramapc(ramap_2o, proc, ra0, lra, s_array_map);
 1391     return UNSPECIFIED;
 1392   case tc7_cxr: if (! SUBRF(proc)) goto gencase;
 1393     ramapc(ramap_cxr, proc, ra0, lra, s_array_map);
 1394     return UNSPECIFIED;
 1395   case tc7_rpsubr: {
 1396     ra_iproc *p;
 1397     if (FALSEP(arrayp(ra0, BOOL_T))) goto gencase;
 1398     array_fill(ra0, BOOL_T);
 1399     for (p = ra_rpsubrs; p->name; p++)
 1400       if (proc==p->sproc) {
 1401     while (NNULLP(lra) && NNULLP(CDR(lra))) {
 1402       ramapc(p->vproc, UNDEFINED, ra0, lra, s_array_map);
 1403       lra = CDR(lra);
 1404     }
 1405     return UNSPECIFIED;
 1406       }
 1407     while (NNULLP(lra) && NNULLP(CDR(lra))) {
 1408       ramapc(ramap_rp, proc, ra0, lra, s_array_map);
 1409       lra = CDR(lra);
 1410     }
 1411     return UNSPECIFIED;
 1412   }
 1413   case tc7_asubr:
 1414     if (NULLP(lra)) {
 1415       SCM prot, fill = SUBRF(proc)(UNDEFINED, UNDEFINED);
 1416       if (INUMP(fill)) {
 1417     prot = array_prot(ra0);
 1418 # ifdef FLOATS
 1419     if (NIMP(prot) && INEXP(prot))
 1420       fill = makdbl((double)INUM(fill), 0.0);
 1421 # endif
 1422       }
 1423       array_fill(ra0, fill);
 1424     }
 1425     else {
 1426       SCM tail, ra1 = CAR(lra);
 1427       SCM v0 = (NIMP(ra0) && ARRAYP(ra0) ? ARRAY_V(ra0) : ra0);
 1428       ra_iproc *p;
 1429       /* Check to see if order might matter.
 1430      This might be an argument for a separate
 1431      SERIAL-ARRAY-MAP! */
 1432       if (v0==ra1 || (NIMP(ra1) && ARRAYP(ra1) && v0==ARRAY_V(ra1)))
 1433     if (ra0 != ra1 || (ARRAYP(ra0) && !ARRAY_CONTP(ra0)))
 1434       goto gencase;
 1435       for (tail = CDR(lra); NNULLP(tail); tail = CDR(tail)) {
 1436     ra1 = CAR(tail);
 1437     if (v0==ra1 || (NIMP(ra1) && ARRAYP(ra1) && v0==ARRAY_V(ra1)))
 1438       goto gencase;
 1439       }
 1440       for (p = ra_asubrs; p->name; p++)
 1441     if (proc==p->sproc) {
 1442       if (ra0 != CAR(lra))
 1443         ramapc(ra_identity, UNDEFINED, ra0, cons(CAR(lra), EOL), s_array_map);
 1444       lra = CDR(lra);
 1445       while (1) {
 1446         ramapc(p->vproc, UNDEFINED, ra0, lra, s_array_map);
 1447         if (IMP(lra) || IMP(CDR(lra))) return UNSPECIFIED;
 1448         lra = CDR(lra);
 1449       }
 1450     }
 1451       ramapc(ramap_2o, proc, ra0, lra, s_array_map);
 1452       lra = CDR(lra);
 1453       if (NIMP(lra))
 1454     for (lra = CDR(lra); NIMP(lra); lra = CDR(lra))
 1455       ramapc(ramap_a, proc, ra0, lra, s_array_map);
 1456     }
 1457     return UNSPECIFIED;
 1458 #if 1 /* def CCLO */
 1459   case tc7_specfun:
 1460     if (tc16_cclo==TYP16(proc)) {
 1461       lra = cons(sc2array(proc, ra0, EOL), lra);
 1462       proc = CCLO_SUBR(proc);
 1463       narg++;
 1464       goto tail;
 1465     }
 1466     goto gencase;
 1467 #endif
 1468   }
 1469 }
 1470 
 1471 static int rafe(ra0, proc, ras)
 1472      SCM ra0, proc, ras;
 1473 {
 1474   SCM heap_ve, auto_rav[5], auto_argv[5];
 1475   SCM *rav = &auto_rav[0], *argv = &auto_argv[0];
 1476   long argc = ilength(ras) + 1;
 1477   long i, k, n;
 1478   scm_protect_temp(&heap_ve);
 1479   if (argc >= 5) {
 1480     heap_ve = make_vector(MAKINUM(2*argc), BOOL_F);
 1481     rav = VELTS(heap_ve);
 1482     argv = &(rav[argc]);
 1483   }
 1484   rav[0] = ra0;
 1485   for (k = 1; k < argc; k++) {
 1486     rav[k] = CAR(ras);
 1487     ras = CDR(ras);
 1488   }
 1489   i = ARRAY_DIMS(ra0)->lbnd;
 1490   n = ARRAY_DIMS(ra0)->ubnd;
 1491   for (; i <= n; i++) {
 1492     for (k = 0; k < argc; k++)
 1493       argv[k] = aref(rav[k], MAKINUM(i));
 1494     scm_cvapply(proc, argc, argv);
 1495   }
 1496   return 1;
 1497 }
 1498 static char s_array_for_each[] = "array-for-each";
 1499 SCM array_for_each(proc, ra0, lra)
 1500      SCM proc, ra0, lra;
 1501 {
 1502   long narg = ilength(lra) + 1;
 1503  tail:
 1504 #ifndef RECKLESS
 1505   scm_arity_check(proc, narg, s_array_for_each);
 1506 #endif
 1507   switch TYP7(proc) {
 1508   default: gencase:
 1509     ramapc(rafe, proc, ra0, lra, s_array_for_each);
 1510     return UNSPECIFIED;
 1511 #if 1 /* def CCLO */
 1512   case tc7_specfun:
 1513     if (tc16_cclo==TYP16(proc)) {
 1514       lra = cons(ra0, lra);
 1515       ra0 = sc2array(proc, ra0, EOL);
 1516       proc = CCLO_SUBR(proc);
 1517       narg++;
 1518       goto tail;
 1519     }
 1520     goto gencase;
 1521 #endif
 1522   }
 1523 }
 1524 
 1525 static char s_array_index_for_each[] = "array-index-for-each";
 1526 SCM scm_array_index_for_each(ra, proc)
 1527      SCM ra, proc;
 1528 {
 1529   SCM hp_av, hp_indv, auto_av[5];
 1530   SCM *av = &auto_av[0];
 1531   long auto_indv[5];
 1532   long *indv = &auto_indv[0];
 1533   sizet i;
 1534   ASRTER(NIMP(ra), ra, ARG1, s_array_index_for_each);
 1535   i = INUM(array_rank(ra));
 1536 #ifndef RECKLESS
 1537     scm_arity_check(proc, i+0L, s_array_index_for_each);
 1538 #endif
 1539   if (i >= 5) {
 1540     scm_protect_temp(&hp_av);
 1541     scm_protect_temp(&hp_indv);
 1542     hp_av = make_vector(MAKINUM(i), BOOL_F);
 1543     av = VELTS(hp_av);
 1544     hp_indv = make_uve(i+0L, MAKINUM(-32L));
 1545     indv = (long *)VELTS(hp_indv);
 1546   }
 1547   switch TYP7(ra) {
 1548   default: badarg: wta(ra, (char *)ARG1, s_array_index_for_each);
 1549   case tc7_vector: {
 1550     for (i = 0; i < LENGTH(ra); i++) {
 1551       av[0] = MAKINUM(i);
 1552       scm_cvapply(proc, 1L, av);
 1553     }
 1554     return UNSPECIFIED;
 1555   }
 1556   case tcs_uves:
 1557     for (i = 0; i < LENGTH(ra); i++) {
 1558       av[0] = MAKINUM(i);
 1559       scm_cvapply(proc, 1L, auto_av);
 1560     }
 1561     return UNSPECIFIED;
 1562   case tc7_smob: ASRTGO(ARRAYP(ra), badarg);
 1563     {
 1564       int j, k, kmax = ARRAY_NDIM(ra) - 1;
 1565       if (kmax < 0)
 1566     return apply(proc, EOL, EOL);
 1567       for (k = 0; k <= kmax; k++)
 1568     indv[k] = ARRAY_DIMS(ra)[k].lbnd;
 1569       k = kmax;
 1570       do {
 1571     if (k==kmax) {
 1572       indv[k] = ARRAY_DIMS(ra)[k].lbnd;
 1573       i = cind(ra, indv);
 1574       for (; indv[k] <= ARRAY_DIMS(ra)[k].ubnd; indv[k]++) {
 1575         for (j = kmax+1; j--;)
 1576           av[j] = MAKINUM(indv[j]);
 1577         scm_cvapply(proc, kmax+1L, av);
 1578         i += ARRAY_DIMS(ra)[k].inc;
 1579       }
 1580       k--;
 1581       continue;
 1582     }
 1583     if (indv[k] < ARRAY_DIMS(ra)[k].ubnd) {
 1584       indv[k]++;
 1585       k++;
 1586       continue;
 1587     }
 1588     indv[k] = ARRAY_DIMS(ra)[k].lbnd - 1;
 1589     k--;
 1590       } while (k >= 0);
 1591       return UNSPECIFIED;
 1592     }
 1593   }
 1594 }
 1595 
 1596 static char s_array_imap[] = "array-index-map!";
 1597 SCM array_imap(ra, proc)
 1598      SCM ra, proc;
 1599 {
 1600   SCM hp_av, hp_indv, auto_av[5];
 1601   SCM *av = &auto_av[0];
 1602   long auto_indv[5];
 1603   long *indv = &auto_indv[0];
 1604   sizet i;
 1605   ASRTER(NIMP(ra), ra, ARG1, s_array_imap);
 1606   i = INUM(array_rank(ra));
 1607 #ifndef RECKLESS
 1608     scm_arity_check(proc, i+0L, s_array_imap);
 1609 #endif
 1610   if (i >= 5) {
 1611     scm_protect_temp(&hp_av);
 1612     scm_protect_temp(&hp_indv);
 1613     hp_av = make_vector(MAKINUM(i), BOOL_F);
 1614     av = VELTS(hp_av);
 1615     hp_indv = make_uve(i+0L, MAKINUM(-32L));
 1616     indv = (long *)VELTS(hp_indv);
 1617   }
 1618   switch TYP7(ra) {
 1619   default: badarg: wta(ra, (char *)ARG1, s_array_imap);
 1620   case tc7_vector: {
 1621     SCM *ve = VELTS(ra);
 1622     for (i = 0; i < LENGTH(ra); i++) {
 1623       av[0] = MAKINUM(i);
 1624       ve[i] = scm_cvapply(proc, 1L, av);
 1625     }
 1626     return UNSPECIFIED;
 1627   }
 1628   case tcs_uves:
 1629     for (i = 0; i < LENGTH(ra); i++) {
 1630       av[0] = MAKINUM(i);
 1631       aset(ra, scm_cvapply(proc, 1L, auto_av), MAKINUM(i));
 1632     }
 1633     return UNSPECIFIED;
 1634   case tc7_smob: ASRTGO(ARRAYP(ra), badarg);
 1635     {
 1636       int j, k, kmax = ARRAY_NDIM(ra) - 1;
 1637       if (kmax < 0)
 1638     return aset(ra, apply(proc, EOL, EOL), EOL);
 1639       for (k = 0; k <= kmax; k++)
 1640     indv[k] = ARRAY_DIMS(ra)[k].lbnd;
 1641       k = kmax;
 1642       do {
 1643     if (k==kmax) {
 1644       indv[k] = ARRAY_DIMS(ra)[k].lbnd;
 1645       i = cind(ra, indv);
 1646       for (; indv[k] <= ARRAY_DIMS(ra)[k].ubnd; indv[k]++) {
 1647         for (j = kmax+1; j--;)
 1648           av[j] = MAKINUM(indv[j]);
 1649         aset(ARRAY_V(ra), scm_cvapply(proc, kmax+1L, av), MAKINUM(i));
 1650         i += ARRAY_DIMS(ra)[k].inc;
 1651       }
 1652       k--;
 1653       continue;
 1654     }
 1655     if (indv[k] < ARRAY_DIMS(ra)[k].ubnd) {
 1656       indv[k]++;
 1657       k++;
 1658       continue;
 1659     }
 1660     indv[k] = ARRAY_DIMS(ra)[k].lbnd - 1;
 1661     k--;
 1662       } while (k >= 0);
 1663       return UNSPECIFIED;
 1664     }
 1665   }
 1666 }
 1667 
 1668 SCM array_equal P((SCM ra0, SCM ra1));
 1669 static int raeql_1(ra0, as_equal, ra1)
 1670      SCM ra0, as_equal, ra1;
 1671 {
 1672   SCM e0 = UNDEFINED, e1 = UNDEFINED;
 1673   sizet i0 = 0, i1 = 0;
 1674   long inc0 = 1, inc1 = 1;
 1675   sizet n = LENGTH(ra0);
 1676   ra1 = CAR(ra1);
 1677   if (ARRAYP(ra0)) {
 1678     n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1;
 1679     i0 = ARRAY_BASE(ra0);
 1680     inc0 = ARRAY_DIMS(ra0)->inc;
 1681     ra0 = ARRAY_V(ra0);
 1682   }
 1683   if (ARRAYP(ra1)) {
 1684     i1 = ARRAY_BASE(ra1);
 1685     inc1 = ARRAY_DIMS(ra1)->inc;
 1686     ra1 = ARRAY_V(ra1);
 1687   }
 1688   switch TYP7(ra0) {
 1689   case tc7_vector: default:
 1690     for (; n--; i0+=inc0, i1+=inc1) {
 1691       if (FALSEP(as_equal)) {
 1692     if (FALSEP(array_equal(RVREF(ra0, i0, e0), RVREF(ra1, i1, e1))))
 1693       return 0;
 1694       }
 1695       else
 1696     if (FALSEP(equal(RVREF(ra0, i0, e0), RVREF(ra1, i1, e1))))
 1697       return 0;
 1698     }
 1699     return 1;
 1700   case tc7_string: {
 1701     char *v0 = CHARS(ra0) + i0;
 1702     char *v1 = CHARS(ra1) + i1;
 1703     for (; n--; v0 += inc0, v1 += inc1)
 1704       if (*v0 != *v1) return 0;
 1705     return 1;
 1706   }
 1707   case tc7_Vbool:
 1708     for (; n--; i0 += inc0, i1 += inc1)
 1709       if (BVE_REF(ra0, i0) != BVE_REF(ra1, i1)) return 0;
 1710     return 1;
 1711   case tc7_VfixN32: case tc7_VfixZ32: {
 1712     long *v0 = (long *)VELTS(ra0) + i0;
 1713     long *v1 = (long *)VELTS(ra1) + i1;
 1714     for (; n--; v0 += inc0, v1 += inc1)
 1715       if (*v0 != *v1) return 0;
 1716     return 1;
 1717   }
 1718 # ifdef FLOATS
 1719   case tc7_VfloR32: {
 1720     float *v0 = (float *)VELTS(ra0) + i0;
 1721     float *v1 = (float *)VELTS(ra1) + i1;
 1722     for (; n--; v0 += inc0, v1 += inc1)
 1723       if (*v0 != *v1) return 0;
 1724     return 1;
 1725   }
 1726   case tc7_VfloR64: {
 1727     double *v0 = (double *)VELTS(ra0) + i0;
 1728     double *v1 = (double *)VELTS(ra1) + i1;
 1729     for (; n--; v0 += inc0, v1 += inc1)
 1730       if (*v0 != *v1) return 0;
 1731     return 1;
 1732   }
 1733   case tc7_VfloC32: {
 1734     float (*v0)[2]= (float (*)[2])VELTS(ra0) + i0;
 1735     float (*v1)[2] = (float (*)[2])VELTS(ra1) + i1;
 1736     for (; n--; v0 += inc0, v1 += inc1) {
 1737       if ((*v0)[0] != (*v1)[0]) return 0;
 1738       if ((*v0)[1] != (*v1)[1]) return 0;
 1739     }
 1740     return 1;
 1741   }
 1742   case tc7_VfloC64: {
 1743     double (*v0)[2]= (double (*)[2])VELTS(ra0) + i0;
 1744     double (*v1)[2] = (double (*)[2])VELTS(ra1) + i1;
 1745     for (; n--; v0 += inc0, v1 += inc1) {
 1746       if ((*v0)[0] != (*v1)[0]) return 0;
 1747       if ((*v0)[1] != (*v1)[1]) return 0;
 1748     }
 1749     return 1;
 1750   }
 1751 # endif /* FLOATS */
 1752   }
 1753 }
 1754 static int raeql(ra0, as_equal, ra1)
 1755      SCM ra0, as_equal, ra1;
 1756 {
 1757   SCM v0 = ra0, v1 = ra1;
 1758   array_dim dim0, dim1;
 1759   array_dim *s0 = &dim0, *s1 = &dim1;
 1760   sizet bas0 = 0, bas1 = 0;
 1761   int k, unroll = 1, ndim = 1;
 1762   if (ARRAYP(ra0)) {
 1763     ndim = ARRAY_NDIM(ra0);
 1764     s0 = ARRAY_DIMS(ra0);
 1765     bas0 = ARRAY_BASE(ra0);
 1766     v0 = ARRAY_V(ra0);
 1767   }
 1768   else {
 1769     s0->inc = 1; s0->lbnd = 0; s0->ubnd = LENGTH(v0) - 1;
 1770   }
 1771   if (ARRAYP(ra1)) {
 1772     if (ndim != ARRAY_NDIM(ra1)) return 0;
 1773     s1 = ARRAY_DIMS(ra1);
 1774     bas1 = ARRAY_BASE(ra1);
 1775     v1 = ARRAY_V(ra1);
 1776   }
 1777   else {
 1778     if (1 != ndim) return BOOL_F;
 1779     s1->inc = 1; s1->lbnd = 0; s1->ubnd = LENGTH(v1) - 1;
 1780   }
 1781   if (TYP7(v0) != TYP7(v1)) return 0;
 1782   unroll = (bas0==bas1);
 1783   for (k = ndim; k--;) {
 1784     if (s0[k].lbnd != s1[k].lbnd || s0[k].ubnd != s1[k].ubnd) return 0;
 1785     if (unroll) unroll = (s0[k].inc==s1[k].inc);
 1786   }
 1787   if (unroll && v0==v1) return BOOL_T;
 1788   return ramapc(raeql_1, as_equal, ra0, cons(ra1, EOL), "");
 1789 }
 1790 
 1791 SCM raequal(ra0, ra1)
 1792      SCM ra0, ra1;
 1793 {
 1794   return (raeql(ra0, BOOL_T, ra1) ? BOOL_T : BOOL_F);
 1795 }
 1796 static char s_array_equalp[] = "array-equal?";
 1797 SCM array_equal(ra0, ra1)
 1798      SCM ra0, ra1;
 1799 {
 1800   if (IMP(ra0) || IMP(ra1))
 1801   callequal: return equal(ra0, ra1);
 1802   switch TYP7(ra0) {
 1803   default: goto callequal;
 1804   case tc7_vector:
 1805   case tcs_uves: break;
 1806   case tc7_smob: if (!ARRAYP(ra0)) goto callequal;
 1807   }
 1808   switch TYP7(ra1) {
 1809   default: goto callequal;
 1810   case tc7_vector:
 1811   case tcs_uves: break;
 1812   case tc7_smob: if (!ARRAYP(ra1)) goto callequal;
 1813   }
 1814   return (raeql(ra0, BOOL_F, ra1) ? BOOL_T : BOOL_F);
 1815 }
 1816 
 1817 static iproc subr2os[] = {
 1818   {s_ura_rd, ura_read},
 1819   {s_ura_wr, ura_write},
 1820   {0, 0}};
 1821 
 1822 /* MinGW complains during a dll build that the string members are not
 1823    constants, since they are defined in another dll.  These functions
 1824    individually initialized below.
 1825 static iproc subr2s[] = {
 1826     {s_array_fill, array_fill},
 1827     {s_array_copy, array_copy},
 1828     {s_sarray_copy, array_copy},
 1829     {0, 0}};
 1830 */
 1831 
 1832 static iproc lsubr2s[] = {
 1833   {s_sc2array, sc2array},
 1834   {s_array_map, array_map},
 1835   {s_sarray_map, array_map},
 1836   {s_array_for_each, array_for_each},
 1837   {s_array_imap, array_imap},
 1838   {s_array_index_for_each, scm_array_index_for_each},
 1839   {0, 0}};
 1840 
 1841 static void init_raprocs(subra)
 1842      ra_iproc *subra;
 1843 {
 1844   for (; subra->name; subra++)
 1845     subra->sproc = CDR(sysintern(subra->name, UNDEFINED));
 1846 }
 1847 
 1848 SCM_DLL_EXPORT void init_ramap P((void));
 1849 
 1850 void init_ramap()
 1851 {
 1852   init_raprocs(ra_rpsubrs);
 1853   init_raprocs(ra_asubrs);
 1854   init_iprocs(subr2os, tc7_subr_2o);
 1855   /*  init_iprocs(subr2s, tc7_subr_2); */
 1856   init_iprocs(lsubr2s, tc7_lsubr_2);
 1857   make_subr(s_array_fill, tc7_subr_2, array_fill);
 1858   make_subr(s_array_copy, tc7_subr_2, array_copy);
 1859   make_subr(s_sarray_copy, tc7_subr_2, array_copy);
 1860   make_subr(s_array_equalp, tc7_rpsubr, array_equal);
 1861   smobs[0x0ff & (tc16_array>>8)].equalp = raequal;
 1862   add_feature(s_array_for_each);
 1863 scm_ldstr("\n\
 1864 (define (array-indexes ra)\n\
 1865   (let ((ra0 (apply make-array '#() (array-shape ra))))\n\
 1866     (array-index-map! ra0 list)\n\
 1867     ra0))\n\
 1868 (define (array-map prototype proc ra1 . ras)\n\
 1869   (define nra (apply make-array prototype (array-shape ra1)))\n\
 1870   (apply array-map! nra proc ra1 ras)\n\
 1871   nra)\n\
 1872 ");
 1873 }