Use the new generalized vector functions to handle all

vector like things.

libguile/ramap.c

@@ -171,53 +171,34 @@ scm_ra_matchp (SCM ra0, SCM ras)
   unsigned long bas0 = 0;
   int i, ndim = 1;
   int exact = 2	  /* 4 */ ;  /* Don't care about values >2 (yet?) */
-  if (SCM_IMP (ra0)) return 0;
+
-  if (scm_is_uniform_vector (ra0))
+  if (scm_is_generalized_vector (ra0))
-    goto uniform_vector_0;
-  switch (SCM_TYP7 (ra0))
     {
-    default:
-      return 0;
-    case scm_tc7_vector:
-    case scm_tc7_wvect:
-    case scm_tc7_string:
-    case scm_tc7_bvect:
-    uniform_vector_0:
       s0->lbnd = 0;
       s0->inc = 1;
-      s0->ubnd = scm_to_long (scm_uniform_vector_length (ra0)) - 1;
+      s0->ubnd = scm_c_generalized_vector_length (ra0) - 1;
-      break;
+    }
-    case scm_tc7_smob:
+  else if (SCM_ARRAYP (ra0))
-      if (!SCM_ARRAYP (ra0))
+    {
-	return 0;
       ndim = SCM_ARRAY_NDIM (ra0);
       s0 = SCM_ARRAY_DIMS (ra0);
       bas0 = SCM_ARRAY_BASE (ra0);
-      break;
     }
+  else
+    return 0;
+
   while (SCM_NIMP (ras))
     {
       ra1 = SCM_CAR (ras);
-      if (SCM_IMP (ra1))
+      
-	return 0;
+      if (scm_is_generalized_vector (ra1))
-      if (scm_is_uniform_vector (ra1))
-	goto uniform_vector_1;
-      switch (SCM_TYP7 (ra1))
 	{
-	default:
+	  size_t length;
-	  return 0;
-	case scm_tc7_vector:
-	case scm_tc7_wvect:
-	case scm_tc7_string:
-	case scm_tc7_bvect:
-	uniform_vector_1:
-	  {
-	    unsigned long int length;
 	  
 	  if (1 != ndim)
 	    return 0;
 	  
-	    length = scm_to_ulong (scm_uniform_vector_length (ra1));
+	  length = scm_c_generalized_vector_length (ra1);
 	  
 	  switch (exact)
 	    {
@@ -235,11 +216,9 @@ scm_ra_matchp (SCM ra0, SCM ras)
 	      if (s0->lbnd < 0 || s0->ubnd >= length)
 		return 0;
 	    }
-	    break;
 	}
-	case scm_tc7_smob:
+      else if (SCM_ARRAYP (ra1) && ndim == SCM_ARRAY_NDIM (ra1))
-	  if (!SCM_ARRAYP (ra1) || ndim != SCM_ARRAY_NDIM (ra1))
+	{
-	    return 0;
 	  s1 = SCM_ARRAY_DIMS (ra1);
 	  if (bas0 != SCM_ARRAY_BASE (ra1))
 	    exact = 3;
@@ -258,10 +237,13 @@ scm_ra_matchp (SCM ra0, SCM ras)
 		if (s0[i].lbnd < s1[i].lbnd || s0[i].ubnd > s1[i].ubnd)
 		  return (s0[i].lbnd <= s0[i].ubnd ? 0 : 1);
 	      }
-	  break;
 	}
+      else
+	return 0;
+
       ras = SCM_CDR (ras);
     }
+
   return exact;
 }
 
@@ -296,7 +278,7 @@ scm_ramapc (int (*cproc)(), SCM data, SCM ra0, SCM lra, const char *what)
       if (SCM_IMP (vra0)) goto gencase;
       if (!SCM_ARRAYP (vra0))
 	{
-	  unsigned long int length = scm_to_ulong (scm_uniform_vector_length (vra0));
+	  size_t length = scm_c_generalized_vector_length (vra0);
 	  vra1 = scm_make_ra (1);
 	  SCM_ARRAY_BASE (vra1) = 0;
 	  SCM_ARRAY_DIMS (vra1)->lbnd = 0;
@@ -442,73 +424,15 @@ scm_array_fill_int (SCM ra, SCM fill, SCM ignore SCM_UNUSED)
 
   ra = SCM_ARRAY_V (ra);
 
-  if (scm_is_uniform_vector (ra))
+  if (scm_is_generalized_vector (ra))
     {
       for (i = base; n--; i += inc)
-	scm_uniform_vector_set_x (ra, scm_from_ulong (i), fill);
+	scm_c_generalized_vector_set_x (ra, i, fill);
-      return 1;
     }
-
+  else
-  switch SCM_TYP7 (ra)
     {
-    default:
       for (i = base; n--; i += inc)
 	scm_array_set_x (ra, fill, scm_from_ulong (i));
-      break;
-    case scm_tc7_vector:
-    case scm_tc7_wvect:
-      for (i = base; n--; i += inc)
-	SCM_VECTOR_SET (ra, i, fill);
-      break;
-    case scm_tc7_string:
-      SCM_ASRTGO (SCM_CHARP (fill), badarg2);
-      {
-	char *data = scm_i_string_writable_chars (ra);
-	for (i = base; n--; i += inc)
-	  data[i] = SCM_CHAR (fill);
-	scm_i_string_stop_writing ();
-      }
-      break;
-    case scm_tc7_bvect:
-      { /* scope */
-	long *ve = (long *) SCM_VELTS (ra);
-	if (1 == inc && (n >= SCM_LONG_BIT || n == SCM_BITVECTOR_LENGTH (ra)))
-	  {
-	    i = base / SCM_LONG_BIT;
-	    if (scm_is_false (fill))
-	      {
-		if (base % SCM_LONG_BIT) /* leading partial word */
-		  ve[i++] &= ~(~0L << (base % SCM_LONG_BIT));
-		for (; i < (base + n) / SCM_LONG_BIT; i++)
-		  ve[i] = 0L;
-		if ((base + n) % SCM_LONG_BIT) /* trailing partial word */
-		  ve[i] &= (~0L << ((base + n) % SCM_LONG_BIT));
-	      }
-	    else if (scm_is_eq (fill, SCM_BOOL_T))
-	      {
-		if (base % SCM_LONG_BIT)
-		  ve[i++] |= ~0L << (base % SCM_LONG_BIT);
-		for (; i < (base + n) / SCM_LONG_BIT; i++)
-		  ve[i] = ~0L;
-		if ((base + n) % SCM_LONG_BIT)
-		  ve[i] |= ~(~0L << ((base + n) % SCM_LONG_BIT));
-	      }
-	    else
-	      badarg2:SCM_WRONG_TYPE_ARG (2, fill);
-	  }
-	else
-	  {
-	    if (scm_is_false (fill))
-	      for (i = base; n--; i += inc)
-		ve[i / SCM_LONG_BIT] &= ~(1L << (i % SCM_LONG_BIT));
-	    else if (scm_is_eq (fill, SCM_BOOL_T))
-	      for (i = base; n--; i += inc)
-		ve[i / SCM_LONG_BIT] |= (1L << (i % SCM_LONG_BIT));
-	    else
-	      goto badarg2;
-	  }
-	break;
-      }
     }
   return 1;
 }
@@ -528,68 +452,12 @@ racp (SCM src, SCM dst)
   src = SCM_ARRAY_V (src);
   dst = SCM_ARRAY_V (dst);
 
-  if (scm_is_uniform_vector (src) || scm_is_uniform_vector (dst))
-    goto gencase;
-
-  switch SCM_TYP7 (dst)
-    {
-    default:
-    gencase:
-    case scm_tc7_vector:
-    case scm_tc7_wvect:
-
   for (; n-- > 0; i_s += inc_s, i_d += inc_d)
-	scm_array_set_x (dst,
+    scm_array_set_x (dst, scm_cvref (src, i_s, SCM_UNDEFINED),
-			 scm_cvref (src, i_s, SCM_UNDEFINED),
 		     scm_from_ulong (i_d));
-      break;
-    case scm_tc7_string:
-      if (SCM_TYP7 (src) != scm_tc7_string)
-	goto gencase;
-      {
-	char *dst_data = scm_i_string_writable_chars (dst);
-	const char *src_data = scm_i_string_chars (src);
-	for (; n-- > 0; i_s += inc_s, i_d += inc_d)
-	  dst_data[i_d] = src_data[i_s];
-	scm_i_string_stop_writing ();
-      }
-      break;
-    case scm_tc7_bvect:
-      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)
-	{
-	  long *sv = (long *) SCM_VELTS (src);
-	  long *dv = (long *) SCM_VELTS (dst);
-	  sv += i_s / SCM_LONG_BIT;
-	  dv += i_d / SCM_LONG_BIT;
-	  if (i_s % SCM_LONG_BIT)
-	    {			/* leading partial word */
-	      *dv = (*dv & ~(~0L << (i_s % SCM_LONG_BIT))) | (*sv & (~0L << (i_s % SCM_LONG_BIT)));
-	      dv++;
-	      sv++;
-	      n -= SCM_LONG_BIT - (i_s % SCM_LONG_BIT);
-	    }
-	  IVDEP (src != dst,
-		 for (; n >= SCM_LONG_BIT; n -= SCM_LONG_BIT, sv++, dv++)
-		 *dv = *sv;)
-	    if (n)		/* trailing partial word */
-	      *dv = (*dv & (~0L << n)) | (*sv & ~(~0L << n));
-	}
-      else
-	{
-	  for (; n-- > 0; i_s += inc_s, i_d += inc_d)
-	    if (SCM_BITVEC_REF(src, i_s)) 
-	      SCM_BITVEC_SET(dst, i_d); 
-	    else
-	      SCM_BITVEC_CLR(dst, i_d);
-	}
-      break;
-    }
   return 1;
 }
 
-
 SCM_REGISTER_PROC(s_array_copy_in_order_x, "array-copy-in-order!", 2, 0, 0, scm_array_copy_x);
 
 
@@ -622,18 +490,15 @@ scm_ra_eqp (SCM ra0, SCM ras)
   ra0 = SCM_ARRAY_V (ra0);
   ra1 = SCM_ARRAY_V (ra1);
   ra2 = SCM_ARRAY_V (ra2);
-  switch (SCM_TYP7 (ra1) == SCM_TYP7 (ra2) ? SCM_TYP7 (ra1) : 0)
+  
-    {
-    default:
   {
     SCM e1 = SCM_UNDEFINED, e2 = SCM_UNDEFINED;
     for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
-	  if (SCM_BITVEC_REF (ra0, i0))
+      if (scm_is_true (scm_c_bitvector_ref (ra0, i0)))
-	    if (scm_is_false(scm_eq_p (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2))))
+	if (!scm_is_eq (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2)))
-	      SCM_BITVEC_CLR (ra0, i0);
+	  scm_c_bitvector_set_x (ra0, i0, SCM_BOOL_F);
-	break;
-      }
   }
+
   return 1;
 }
 
@@ -650,20 +515,17 @@ ra_compare (SCM ra0, SCM ra1, SCM ra2, int opt)
   ra0 = SCM_ARRAY_V (ra0);
   ra1 = SCM_ARRAY_V (ra1);
   ra2 = SCM_ARRAY_V (ra2);
-  switch (SCM_TYP7 (ra1) == SCM_TYP7 (ra2) ? SCM_TYP7 (ra1) : 0)
+
-    {
-    default:
   {
     SCM e1 = SCM_UNDEFINED, e2 = SCM_UNDEFINED;
     for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
-	  if (SCM_BITVEC_REF (ra0, i0))
+      if (scm_is_true (scm_c_bitvector_ref (ra0, i0)))
 	if (opt ?
 	    scm_is_true (scm_less_p (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2))) :
 	    scm_is_false (scm_less_p (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2))))
-	      SCM_BITVEC_CLR (ra0, i0);
+	  scm_c_bitvector_set_x (ra0, i0, SCM_BOOL_F);
-	break;
-      }
   }
+
   return 1;
 }
 
@@ -925,15 +787,12 @@ ramap_rp (SCM ra0, SCM proc, SCM ras)
   ra0 = SCM_ARRAY_V (ra0);
   ra1 = SCM_ARRAY_V (ra1);
   ra2 = SCM_ARRAY_V (ra2);
-  switch (SCM_TYP7 (ra1) == SCM_TYP7 (ra2) ? SCM_TYP7 (ra1) : 0)
+
-    {
-    default:
   for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
-	if (SCM_BITVEC_REF  (ra0, i0))
+    if (scm_is_true (scm_c_bitvector_ref (ra0, i0)))
       if (scm_is_false (SCM_SUBRF (proc) (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2))))
-	    SCM_BITVEC_CLR (ra0, i0);
+	scm_c_bitvector_set_x (ra0, i0, SCM_BOOL_F);
-      break;
+
-    }
   return 1;
 }
 
@@ -1221,33 +1080,17 @@ SCM_DEFINE (scm_array_index_map_x, "array-index-map!", 2, 0, 0,
 #define FUNC_NAME s_scm_array_index_map_x
 {
   unsigned long i;
-  SCM_VALIDATE_NIM (1, ra);
   SCM_VALIDATE_PROC (2, proc);
-  if (scm_is_uniform_vector (ra))
+
-    goto uniform_vector;
+  if (scm_is_generalized_vector (ra))
-  switch (SCM_TYP7(ra))
     {
-    default:
+      size_t length = scm_c_generalized_vector_length (ra);
-    badarg:SCM_WRONG_TYPE_ARG (1, ra);
-    case scm_tc7_vector:
-    case scm_tc7_wvect:
-      {
-	for (i = 0; i < SCM_VECTOR_LENGTH (ra); i++)
-	  SCM_VECTOR_SET(ra, i, scm_call_1 (proc, scm_from_long (i)));
-	return SCM_UNSPECIFIED;
-      }
-    case scm_tc7_string:
-    case scm_tc7_bvect:
-    uniform_vector:
-      {
-	unsigned long int length = scm_to_ulong (scm_uniform_vector_length (ra));
       for (i = 0; i < length; i++)
-	  scm_array_set_x (ra, scm_call_1 (proc, scm_from_ulong (i)),
+	scm_c_generalized_vector_set_x (ra, i,
-			   scm_from_ulong (i));
+					scm_call_1 (proc, scm_from_ulong (i)));
       return SCM_UNSPECIFIED;
     }
-    case scm_tc7_smob:
+  else if (SCM_ARRAYP (ra))
-      SCM_ASRTGO (SCM_ARRAYP (ra), badarg);
     {
       SCM args = SCM_EOL;
       SCM inds = scm_make_uve (SCM_ARRAY_NDIM (ra), scm_from_int (-1));
@@ -1288,7 +1131,8 @@ SCM_DEFINE (scm_array_index_map_x, "array-index-map!", 2, 0, 0,
       while (k >= 0);
       return SCM_UNSPECIFIED;
     }
-    }
+  else
+    scm_wrong_type_arg_msg (NULL, 0, ra, "array");
 }
 #undef FUNC_NAME
 
@@ -1309,21 +1153,17 @@ raeql_1 (SCM ra0, SCM as_equal, SCM ra1)
       ra0 = SCM_ARRAY_V (ra0);
     }
   else
-    n = scm_to_ulong (scm_uniform_vector_length (ra0));
+    n = scm_c_generalized_vector_length (ra0);
+
   if (SCM_ARRAYP (ra1))
     {
       i1 = SCM_ARRAY_BASE (ra1);
       inc1 = SCM_ARRAY_DIMS (ra1)->inc;
       ra1 = SCM_ARRAY_V (ra1);
     }
-  if (scm_is_uniform_vector (ra0))
+
-    goto uniform_vector;
+  if (scm_is_generalized_vector (ra0))
-  switch (SCM_TYP7 (ra0))
     {
-    case scm_tc7_vector:
-    case scm_tc7_wvect:
-    default:
-    uniform_vector:
       for (; n--; i0 += inc0, i1 += inc1)
 	{
 	  if (scm_is_false (as_equal))
@@ -1335,21 +1175,9 @@ raeql_1 (SCM ra0, SCM as_equal, SCM ra1)
 	    return 0;
 	}
       return 1;
-    case scm_tc7_string:
-      {
-	const char *v0 = scm_i_string_chars (ra0) + i0;
-	const char *v1 = scm_i_string_chars (ra1) + i1;
-	for (; n--; v0 += inc0, v1 += inc1)
-	  if (*v0 != *v1)
-	    return 0;
-	return 1;
     }
-    case scm_tc7_bvect:
+  else
-      for (; n--; i0 += inc0, i1 += inc1)
-	if (SCM_BITVEC_REF (ra0, i0) != SCM_BITVEC_REF (ra1, i1))
     return 0;
-      return 1;
-    }
 }
 
 
@@ -1442,35 +1270,9 @@ static char s_array_equal_p[] = "array-equal?";
 SCM
 scm_array_equal_p (SCM ra0, SCM ra1)
 {
-  if (SCM_IMP (ra0) || SCM_IMP (ra1))
+  if (SCM_ARRAYP (ra0) || SCM_ARRAYP (ra1))
-    callequal:return scm_equal_p (ra0, ra1);
-  switch (SCM_TYP7(ra0))
-    {
-    default:
-      goto callequal;
-    case scm_tc7_bvect:
-    case scm_tc7_string:
-    case scm_tc7_vector:
-    case scm_tc7_wvect:
-      break;
-    case scm_tc7_smob:
-      if (!SCM_ARRAYP (ra0))
-	goto callequal;
-    }
-  switch (SCM_TYP7 (ra1))
-    {
-    default:
-      goto callequal;
-    case scm_tc7_bvect:
-    case scm_tc7_string:
-    case scm_tc7_vector:
-    case scm_tc7_wvect:
-      break;
-    case scm_tc7_smob:
-      if (!SCM_ARRAYP (ra1))
-	goto callequal;
-    }
     return scm_from_bool(raeql (ra0, SCM_BOOL_F, ra1));
+  return scm_equal_p (ra0, ra1);
 }