\f
#include <stdio.h>
-#include "_scm.h"
-#include "unif.h"
-#include "smob.h"
-#include "chars.h"
-#include "eq.h"
-#include "eval.h"
-#include "feature.h"
-#include "root.h"
-#include "vectors.h"
-
-#include "validate.h"
-#include "ramap.h"
+#include "libguile/_scm.h"
+#include "libguile/strings.h"
+#include "libguile/unif.h"
+#include "libguile/smob.h"
+#include "libguile/chars.h"
+#include "libguile/eq.h"
+#include "libguile/eval.h"
+#include "libguile/feature.h"
+#include "libguile/root.h"
+#include "libguile/vectors.h"
+
+#include "libguile/validate.h"
+#include "libguile/ramap.h"
\f
typedef struct
case scm_tc7_cvect:
s0->lbnd = 0;
s0->inc = 1;
- s0->ubnd = (long) SCM_LENGTH (ra0) - 1;
+ s0->ubnd = SCM_INUM (scm_uniform_vector_length (ra0)) - 1;
break;
case scm_tc7_smob:
if (!SCM_ARRAYP (ra0))
case scm_tc7_fvect:
case scm_tc7_dvect:
case scm_tc7_cvect:
- if (1 != ndim)
- return 0;
- switch (exact)
- {
- case 4:
- if (0 != bas0)
- exact = 3;
- case 3:
- if (1 != s0->inc)
- exact = 2;
- case 2:
- if ((0 == s0->lbnd) && (s0->ubnd == SCM_LENGTH (ra1) - 1))
- break;
- exact = 1;
- case 1:
- if (s0->lbnd < 0 || s0->ubnd >= SCM_LENGTH (ra1))
- return 0;
- }
- break;
+ {
+ unsigned long int length;
+
+ if (1 != ndim)
+ return 0;
+
+ length = SCM_INUM (scm_uniform_vector_length (ra1));
+
+ switch (exact)
+ {
+ case 4:
+ if (0 != bas0)
+ exact = 3;
+ case 3:
+ if (1 != s0->inc)
+ exact = 2;
+ case 2:
+ if ((0 == s0->lbnd) && (s0->ubnd == length - 1))
+ break;
+ exact = 1;
+ case 1:
+ if (s0->lbnd < 0 || s0->ubnd >= length)
+ return 0;
+ }
+ break;
+ }
case scm_tc7_smob:
if (!SCM_ARRAYP (ra1) || ndim != SCM_ARRAY_NDIM (ra1))
return 0;
{
default:
case 0:
- scm_wta (ra0, "array shape mismatch", what);
+ scm_misc_error (what, "array shape mismatch: ~S", ra0);
case 2:
case 3:
case 4: /* Try unrolling arrays */
if (SCM_IMP (vra0)) goto gencase;
if (!SCM_ARRAYP (vra0))
{
+ unsigned long int length = SCM_INUM (scm_uniform_vector_length (vra0));
vra1 = scm_make_ra (1);
SCM_ARRAY_BASE (vra1) = 0;
SCM_ARRAY_DIMS (vra1)->lbnd = 0;
- SCM_ARRAY_DIMS (vra1)->ubnd = SCM_LENGTH (vra0) - 1;
+ SCM_ARRAY_DIMS (vra1)->ubnd = length - 1;
SCM_ARRAY_DIMS (vra1)->inc = 1;
SCM_ARRAY_V (vra1) = vra0;
vra0 = vra1;
}
else
{
+ unsigned long int length = SCM_INUM (scm_uniform_vector_length (ra0));
kmax = 0;
SCM_ARRAY_DIMS (vra0)->lbnd = 0;
- SCM_ARRAY_DIMS (vra0)->ubnd = SCM_LENGTH (ra0) - 1;
+ SCM_ARRAY_DIMS (vra0)->ubnd = length - 1;
SCM_ARRAY_DIMS (vra0)->inc = 1;
SCM_ARRAY_BASE (vra0) = 0;
SCM_ARRAY_V (vra0) = ra0;
case scm_tc7_string:
SCM_ASRTGO (SCM_CHARP (fill), badarg2);
for (i = base; n--; i += inc)
- SCM_CHARS (ra)[i] = SCM_CHAR (fill);
+ SCM_STRING_CHARS (ra)[i] = SCM_CHAR (fill);
break;
case scm_tc7_byvect:
if (SCM_CHARP (fill))
&& -128 <= SCM_INUM (fill) && SCM_INUM (fill) < 128,
badarg2);
for (i = base; n--; i += inc)
- SCM_CHARS (ra)[i] = SCM_INUM (fill);
+ ((char *) SCM_UVECTOR_BASE (ra))[i] = SCM_INUM (fill);
break;
case scm_tc7_bvect:
{ /* scope */
long *ve = (long *) SCM_VELTS (ra);
- if (1 == inc && (n >= SCM_LONG_BIT || n == SCM_LENGTH (ra)))
+ if (1 == inc && (n >= SCM_LONG_BIT || n == SCM_BITVECTOR_LENGTH (ra)))
{
i = base / SCM_LONG_BIT;
- if (SCM_BOOL_F == fill)
+ if (SCM_FALSEP (fill))
{
if (base % SCM_LONG_BIT) /* leading partial word */
ve[i++] &= ~(~0L << (base % SCM_LONG_BIT));
if ((base + n) % SCM_LONG_BIT) /* trailing partial word */
ve[i] &= (~0L << ((base + n) % SCM_LONG_BIT));
}
- else if (SCM_BOOL_T == fill)
+ else if (SCM_EQ_P (fill, SCM_BOOL_T))
{
if (base % SCM_LONG_BIT)
ve[i++] |= ~0L << (base % SCM_LONG_BIT);
}
else
{
- if (SCM_BOOL_F == fill)
+ if (SCM_FALSEP (fill))
for (i = base; n--; i += inc)
ve[i / SCM_LONG_BIT] &= ~(1L << (i % SCM_LONG_BIT));
- else if (SCM_BOOL_T == fill)
+ else if (SCM_EQ_P (fill, SCM_BOOL_T))
for (i = base; n--; i += inc)
ve[i / SCM_LONG_BIT] |= (1L << (i % SCM_LONG_BIT));
else
case scm_tc7_uvect:
{ /* scope */
unsigned long f = SCM_NUM2ULONG (2,fill);
- unsigned long *ve = (long *) SCM_VELTS (ra);
+ unsigned long *ve = (unsigned long *) SCM_VELTS (ra);
for (i = base; n--; i += inc)
ve[i] = f;
{ /* scope */
float f, *ve = (float *) SCM_VELTS (ra);
SCM_ASRTGO (SCM_REALP (fill), badarg2);
- f = SCM_REALPART (fill);
+ f = SCM_REAL_VALUE (fill);
for (i = base; n--; i += inc)
ve[i] = f;
break;
{ /* scope */
double f, *ve = (double *) SCM_VELTS (ra);
SCM_ASRTGO (SCM_REALP (fill), badarg2);
- f = SCM_REALPART (fill);
+ f = SCM_REAL_VALUE (fill);
for (i = base; n--; i += inc)
ve[i] = f;
break;
{ /* scope */
double fr, fi;
double (*ve)[2] = (double (*)[2]) SCM_VELTS (ra);
- SCM_ASRTGO (SCM_INEXP (fill), badarg2);
- fr = SCM_REALPART (fill);
- fi = (SCM_CPLXP (fill) ? SCM_IMAG (fill) : 0.0);
+ SCM_ASRTGO (SCM_INEXACTP (fill), badarg2);
+ if (SCM_REALP (fill)) {
+ fr = SCM_REAL_VALUE (fill);
+ fi = 0.0;
+ } else {
+ fr = SCM_COMPLEX_REAL (fill);
+ fi = SCM_COMPLEX_IMAG (fill);
+ }
for (i = base; n--; i += inc)
{
ve[i][0] = fr;
ugly UNICOS macros (IVDEP) to go .
*/
- if (src == dst)
+ if (SCM_EQ_P (src, dst))
return 1 ;
- switch SCM_TYP7
- (dst)
+ switch SCM_TYP7 (dst)
{
default:
gencase:
scm_array_set_x (dst, scm_cvref (src, i_s, SCM_UNDEFINED), SCM_MAKINUM (i_d));
break;
case scm_tc7_string:
+ if (SCM_TYP7 (src) != scm_tc7_string)
+ goto gencase;
+ for (; n-- > 0; i_s += inc_s, i_d += inc_d)
+ SCM_STRING_CHARS (dst)[i_d] = SCM_STRING_CHARS (src)[i_s];
+ break;
case scm_tc7_byvect:
- if (scm_tc7_string != SCM_TYP7 (dst))
+ if (SCM_TYP7 (src) != scm_tc7_byvect)
goto gencase;
for (; n-- > 0; i_s += inc_s, i_d += inc_d)
- SCM_CHARS (dst)[i_d] = SCM_CHARS (src)[i_s];
+ ((char *) SCM_UVECTOR_BASE (dst))[i_d] = ((char *) SCM_UVECTOR_BASE (src))[i_s];
break;
case scm_tc7_bvect:
- if (scm_tc7_bvect != SCM_TYP7 (dst))
+ if (SCM_TYP7 (src) != scm_tc7_bvect)
goto gencase;
if (1 == inc_d && 1 == inc_s && i_s % SCM_LONG_BIT == i_d % SCM_LONG_BIT && n >= SCM_LONG_BIT)
{
}
-/* This name is obsolete. Will go away in release 1.5. */
-SCM_REGISTER_PROC(s_serial_array_copy_x, "serial-array-copy!", 2, 0, 0, scm_array_copy_x);
SCM_REGISTER_PROC(s_array_copy_in_order_x, "array-copy-in-order!", 2, 0, 0, scm_array_copy_x);
SCM_DEFINE (scm_array_copy_x, "array-copy!", 2, 0, 0,
(SCM src, SCM dst),
+ "@deffnx primitive array-copy-in-order! src dst\n"
"Copies every element from vector or array @var{source} to the\n"
"corresponding element of @var{destination}. @var{destination} must have\n"
"the same rank as @var{source}, and be at least as large in each\n"
break;
}
case scm_tc7_uvect:
+ for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
+ if (SCM_BITVEC_REF (ra0, i0))
+ if (((unsigned long *) SCM_VELTS (ra1))[i1] != ((unsigned long *) SCM_VELTS (ra2))[i2])
+ SCM_BITVEC_CLR (ra0, i0);
+ break;
case scm_tc7_ivect:
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
if (SCM_BITVEC_REF (ra0, i0))
- if (SCM_VELTS (ra1)[i1] != SCM_VELTS (ra2)[i2])
+ if (((signed long *) SCM_VELTS (ra1))[i1] != ((signed long *) SCM_VELTS (ra2))[i2])
SCM_BITVEC_CLR (ra0, i0);
break;
case scm_tc7_fvect:
break;
}
case scm_tc7_uvect:
+ for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
+ {
+ if (SCM_BITVEC_REF (ra0, i0))
+ if (opt ?
+ ((unsigned long *) SCM_VELTS (ra1))[i1] < ((unsigned long *) SCM_VELTS (ra2))[i2] :
+ ((unsigned long *) SCM_VELTS (ra1))[i1] >= ((unsigned long *) SCM_VELTS (ra2))[i2])
+ SCM_BITVEC_CLR (ra0, i0);
+ }
+ break;
case scm_tc7_ivect:
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
{
if (SCM_BITVEC_REF (ra0, i0))
if (opt ?
- SCM_VELTS (ra1)[i1] < SCM_VELTS (ra2)[i2] :
- SCM_VELTS (ra1)[i1] >= SCM_VELTS (ra2)[i2])
+ ((signed long *) SCM_VELTS (ra1))[i1] < ((signed long *) SCM_VELTS (ra2))[i2] :
+ ((signed long *) SCM_VELTS (ra1))[i1] >= ((signed long *) SCM_VELTS (ra2))[i2])
SCM_BITVEC_CLR (ra0, i0);
}
break;
for (; i <= n; i++, i1 += inc1)
{
args = SCM_EOL;
- for (k = SCM_LENGTH (ras); k--;)
+ for (k = SCM_INUM (scm_uniform_vector_length (ras)); k--;)
args = scm_cons (scm_uniform_vector_ref (ve[k], SCM_MAKINUM (i)), args);
args = scm_cons (scm_cvref (ra1, i1, SCM_UNDEFINED), args);
scm_array_set_x (ra0, scm_apply (proc, args, SCM_EOL), SCM_MAKINUM (i * inc + base));
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
if (SCM_BITVEC_REF (ra0, i0))
{
- if (SCM_FALSEP (SCM_SUBRF (proc) (SCM_MAKINUM (SCM_VELTS (ra1)[i1]),
- SCM_MAKINUM (SCM_VELTS (ra2)[i2]))))
+ /* DIRK:FIXME:: There should be a way to access the elements
+ of a cell as raw data. Further: How can we be sure that
+ the values fit into an inum?
+ */
+ SCM n1 = SCM_MAKINUM (((long *) SCM_UNPACK (SCM_CDR (ra1)))[i1]);
+ SCM n2 = SCM_MAKINUM (((long *) SCM_UNPACK (SCM_CDR (ra2)))[i2]);
+ if (SCM_FALSEP (SCM_SUBRF (proc) (n1, n2)));
SCM_BITVEC_CLR (ra0, i0);
}
break;
}
case scm_tc7_dvect:
{
- SCM a1 = scm_makdbl (1.0 / 3.0, 0.0), a2 = scm_makdbl (1.0 / 3.0, 0.0);
+ SCM a1 = scm_make_real (1.0 / 3.0);
+ SCM a2 = scm_make_real (1.0 / 3.0);
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
if (SCM_BITVEC_REF (ra0, i0))
{
- SCM_REAL (a1) = ((double *) SCM_VELTS (ra1))[i1];
- SCM_REAL (a2) = ((double *) SCM_VELTS (ra2))[i2];
+ SCM_REAL_VALUE (a1) = ((double *) SCM_VELTS (ra1))[i1];
+ SCM_REAL_VALUE (a2) = ((double *) SCM_VELTS (ra2))[i2];
if (SCM_FALSEP (SCM_SUBRF (proc) (a1, a2)))
SCM_BITVEC_CLR (ra0, i0);
}
}
case scm_tc7_cvect:
{
- SCM a1 = scm_makdbl (1.0, 1.0), a2 = scm_makdbl (1.0, 1.0);
+ SCM a1 = scm_make_complex (1.0, 1.0);
+ SCM a2 = scm_make_complex (1.0, 1.0);
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
if (SCM_BITVEC_REF (ra0, i0))
{
return 1;
}
-/* This name is obsolete. Will go away in release 1.5. */
-SCM_REGISTER_PROC(s_serial_array_map_x, "serial-array-map!", 2, 0, 1, scm_array_map_x);
+
SCM_REGISTER_PROC(s_array_map_in_order_x, "array-map-in-order!", 2, 0, 1, scm_array_map_x);
SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1,
(SCM ra0, SCM proc, SCM lra),
+ "@deffnx primitive array-map-in-order! ra0 proc . lra\n"
"@var{array1}, @dots{} must have the same number of dimensions as\n"
"@var{array0} and have a range for each index which includes the range\n"
"for the corresponding index in @var{array0}. @var{proc} is applied to\n"
#define FUNC_NAME s_scm_array_map_x
{
SCM_VALIDATE_PROC (2,proc);
+ SCM_VALIDATE_REST_ARGUMENT (lra);
switch (SCM_TYP7 (proc))
{
default:
goto gencase;
scm_array_fill_x (ra0, SCM_BOOL_T);
for (p = ra_rpsubrs; p->name; p++)
- if (proc == p->sproc)
+ if (SCM_EQ_P (proc, p->sproc))
{
while (SCM_NNULLP (lra) && SCM_NNULLP (SCM_CDR (lra)))
{
if (SCM_INUMP(fill))
{
prot = scm_array_prototype (ra0);
- if (SCM_INEXP (prot))
- fill = scm_makdbl ((double) SCM_INUM (fill), 0.0);
+ if (SCM_INEXACTP (prot))
+ fill = scm_make_real ((double) SCM_INUM (fill));
}
scm_array_fill_x (ra0, fill);
/* Check to see if order might matter.
This might be an argument for a separate
SERIAL-ARRAY-MAP! */
- if (v0 == ra1 || (SCM_ARRAYP (ra1) && v0 == SCM_ARRAY_V (ra1)))
- if (ra0 != ra1 || (SCM_ARRAYP(ra0) && !SCM_ARRAY_CONTP(ra0)))
+ if (SCM_EQ_P (v0, ra1)
+ || (SCM_ARRAYP (ra1) && SCM_EQ_P (v0, SCM_ARRAY_V (ra1))))
+ if (!SCM_EQ_P (ra0, ra1)
+ || (SCM_ARRAYP(ra0) && !SCM_ARRAY_CONTP(ra0)))
goto gencase;
for (tail = SCM_CDR (lra); SCM_NNULLP (tail); tail = SCM_CDR (tail))
{
ra1 = SCM_CAR (tail);
- if (v0 == ra1 || (SCM_ARRAYP (ra1) && v0 == SCM_ARRAY_V (ra1)))
+ if (SCM_EQ_P (v0, ra1)
+ || (SCM_ARRAYP (ra1) && SCM_EQ_P (v0, SCM_ARRAY_V (ra1))))
goto gencase;
}
for (p = ra_asubrs; p->name; p++)
- if (proc == p->sproc)
+ if (SCM_EQ_P (proc, p->sproc))
{
- if (ra0 != SCM_CAR (lra))
+ if (!SCM_EQ_P (ra0, SCM_CAR (lra)))
scm_ramapc (scm_array_identity, SCM_UNDEFINED, ra0, scm_cons (SCM_CAR (lra), SCM_EOL), FUNC_NAME);
lra = SCM_CDR (lra);
while (1)
for (; i <= n; i++, i0 += inc0, i1 += inc1)
{
args = SCM_EOL;
- for (k = SCM_LENGTH (ras); k--;)
+ for (k = SCM_INUM (scm_uniform_vector_length (ras)); k--;)
args = scm_cons (scm_uniform_vector_ref (ve[k], SCM_MAKINUM (i)), args);
args = scm_cons2 (scm_cvref (ra0, i0, SCM_UNDEFINED), scm_cvref (ra1, i1, SCM_UNDEFINED), args);
scm_apply (proc, args, SCM_EOL);
#define FUNC_NAME s_scm_array_for_each
{
SCM_VALIDATE_PROC (1,proc);
+ SCM_VALIDATE_REST_ARGUMENT (lra);
scm_ramapc (rafe, proc, ra0, lra, FUNC_NAME);
return SCM_UNSPECIFIED;
}
case scm_tc7_wvect:
{
SCM *ve = SCM_VELTS (ra);
- for (i = 0; i < SCM_LENGTH (ra); i++)
+ for (i = 0; i < SCM_VECTOR_LENGTH (ra); i++)
ve[i] = scm_apply (proc, SCM_MAKINUM (i), scm_listofnull);
return SCM_UNSPECIFIED;
}
case scm_tc7_fvect:
case scm_tc7_dvect:
case scm_tc7_cvect:
- for (i = 0; i < SCM_LENGTH (ra); i++)
- scm_array_set_x (ra, scm_apply (proc, SCM_MAKINUM (i), scm_listofnull),
- SCM_MAKINUM (i));
- return SCM_UNSPECIFIED;
+ {
+ unsigned long int length = SCM_INUM (scm_uniform_vector_length (ra));
+ for (i = 0; i < length; i++)
+ scm_array_set_x (ra, scm_apply (proc, SCM_MAKINUM (i), scm_listofnull),
+ SCM_MAKINUM (i));
+ return SCM_UNSPECIFIED;
+ }
case scm_tc7_smob:
SCM_ASRTGO (SCM_ARRAYP (ra), badarg);
{
SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED;
scm_sizet i0 = 0, i1 = 0;
long inc0 = 1, inc1 = 1;
- scm_sizet n = SCM_LENGTH (ra0);
+ scm_sizet n = SCM_INUM (scm_uniform_vector_length (ra0));
ra1 = SCM_CAR (ra1);
if (SCM_ARRAYP(ra0))
{
}
return 1;
case scm_tc7_string:
+ {
+ char *v0 = SCM_STRING_CHARS (ra0) + i0;
+ char *v1 = SCM_STRING_CHARS (ra1) + i1;
+ for (; n--; v0 += inc0, v1 += inc1)
+ if (*v0 != *v1)
+ return 0;
+ return 1;
+ }
case scm_tc7_byvect:
{
- char *v0 = SCM_CHARS (ra0) + i0;
- char *v1 = SCM_CHARS (ra1) + i1;
+ char *v0 = ((char *) SCM_UVECTOR_BASE (ra0)) + i0;
+ char *v1 = ((char *) SCM_UVECTOR_BASE (ra1)) + i1;
for (; n--; v0 += inc0, v1 += inc1)
if (*v0 != *v1)
return 0;
{
s0->inc = 1;
s0->lbnd = 0;
- s0->ubnd = SCM_LENGTH (v0) - 1;
+ s0->ubnd = SCM_INUM (scm_uniform_vector_length (v0)) - 1;
unroll = 0;
}
if (SCM_ARRAYP (ra1))
return 0;
s1->inc = 1;
s1->lbnd = 0;
- s1->ubnd = SCM_LENGTH (v1) - 1;
+ s1->ubnd = SCM_INUM (scm_uniform_vector_length (v1)) - 1;
unroll = 0;
}
if (SCM_TYP7 (v0) != SCM_TYP7 (v1))
vlen *= s0[k].ubnd - s1[k].lbnd + 1;
}
}
- if (unroll && bas0 == bas1 && v0 == v1)
+ if (unroll && bas0 == bas1 && SCM_EQ_P (v0, v1))
return 1;
return scm_ramapc (raeql_1, as_equal, ra0, scm_cons (ra1, SCM_EOL), "");
}
init_raprocs (ra_iproc *subra)
{
for (; subra->name; subra++)
- subra->sproc = SCM_CDR (scm_intern (subra->name, strlen (subra->name)));
+ subra->sproc = scm_symbol_binding (SCM_BOOL_F, scm_str2symbol (subra->name));
}
init_raprocs (ra_asubrs);
scm_make_subr (s_array_equal_p, scm_tc7_rpsubr, scm_array_equal_p);
scm_smobs[0x0ff & (scm_tc16_array >> 8)].equalp = scm_raequal;
-#include "ramap.x"
+#ifndef SCM_MAGIC_SNARFER
+#include "libguile/ramap.x"
+#endif
scm_add_feature (s_scm_array_for_each);
}
HCoop / bpt / guile.git / blobdiff