libguile/convert.i.c

   1 /* this file is #include'd (x times) by convert.c */
   2
   3 /* Convert a vector, weak vector, (if possible string, substring), list
   4    or uniform vector into an C array.  If the result array in argument 2
   5    is NULL, malloc() a new one.  If out of memory, return NULL.  */
   6 #define FUNC_NAME SCM2CTYPES_FN
   7 CTYPE *
   8 SCM2CTYPES (SCM obj, CTYPE *data)
   9 {
  10   long i, n;
  11   SCM val;
  12
  13   SCM_ASSERT (SCM_NIMP (obj) || SCM_NFALSEP (scm_list_p (obj)),
  14               obj, SCM_ARG1, FUNC_NAME);
  15
  16   /* list conversion */
  17   if (SCM_NFALSEP (scm_list_p (obj)))
  18     {
  19       /* traverse the given list and validate the range of each member */
  20       SCM list = obj;
  21       for (n = 0; SCM_NFALSEP (scm_pair_p (list)); list = SCM_CDR (list), n++)
  22         {
  23           val = SCM_CAR (list);
  24 #if SIZEOF_CTYPE && SIZEOF_CTYPE < SIZEOF_SCM_T_BITS
  25           /* check integer ranges */
  26           if (SCM_INUMP (val))
  27             {
  28               scm_t_signed_bits v = SCM_INUM (val);
  29               CTYPE c = (CTYPE) v;
  30               SCM_ASSERT_RANGE (SCM_ARG1, val, v != (scm_t_signed_bits) c);
  31             }
  32           /* check big number ranges */
  33           else if (SCM_BIGP (val))
  34             {
  35               scm_t_signed_bits v = scm_num2long (val, SCM_ARG1, FUNC_NAME);
  36               CTYPE c = (CTYPE) v;
  37               SCM_ASSERT_RANGE (SCM_ARG1, val, v != (scm_t_signed_bits) c);
  38             }
  39           else
  40           /* check float types */
  41 #elif defined (FLOATTYPE)
  42           /* real values, big numbers and immediate values are valid
  43              for float conversions */
  44           if (!SCM_REALP (val) && !SCM_BIGP (val) && !SCM_INUMP (val))
  45 #else
  46           if (!SCM_BIGP (val) && !SCM_INUMP (val))
  47 #endif /* FLOATTYPE */
  48             SCM_WRONG_TYPE_ARG (SCM_ARG1, val);
  49         }
  50
  51       /* allocate new memory if necessary */
  52       if (data == NULL)
  53         if ((data = (CTYPE *) malloc (n * sizeof (CTYPE))) == NULL)
  54           return NULL;
  55
  56       /* traverse the list once more and convert each member */
  57       list = obj;
  58       for (i = 0; SCM_NFALSEP (scm_pair_p (list)); list = SCM_CDR (list), i++)
  59         {
  60           val = SCM_CAR (list);
  61           if (SCM_INUMP (val))
  62             data[i] = (CTYPE) SCM_INUM (val);
  63           else if (SCM_BIGP (val))
  64             data[i] = (CTYPE) scm_num2long (val, SCM_ARG1, FUNC_NAME);
  65 #if defined (FLOATTYPE)
  66           else
  67             data[i] = (CTYPE) SCM_REAL_VALUE (val);
  68 #endif
  69         }
  70       return data;
  71     }
  72
  73   /* other conversions */
  74   switch (SCM_TYP7 (obj))
  75     {
  76       /* vectors and weak vectors */
  77     case scm_tc7_vector:
  78     case scm_tc7_wvect:
  79       n = SCM_VECTOR_LENGTH (obj);
  80       /* traverse the given vector and validate each member */
  81       for (i = 0; i < n; i++)
  82         {
  83           val = SCM_VELTS (obj)[i];
  84 #if SIZEOF_CTYPE && SIZEOF_CTYPE < SIZEOF_SCM_T_BITS
  85           /* check integer ranges */
  86           if (SCM_INUMP (val))
  87             {
  88               scm_t_signed_bits v = SCM_INUM (val);
  89               CTYPE c = (CTYPE) v;
  90               SCM_ASSERT_RANGE (SCM_ARG1, val, v != (scm_t_signed_bits) c);
  91             }
  92           /* check big number ranges */
  93           else if (SCM_BIGP (val))
  94             {
  95               scm_t_signed_bits v = scm_num2long (val, SCM_ARG1, FUNC_NAME);
  96               CTYPE c = (CTYPE) v;
  97               SCM_ASSERT_RANGE (SCM_ARG1, val, v != (scm_t_signed_bits) c);
  98             }
  99           else
 100           /* check float types */
 101 #elif defined (FLOATTYPE)
 102           /* real values, big numbers and immediate values are valid
 103              for float conversions */
 104           if (!SCM_REALP (val) && !SCM_BIGP (val) && !SCM_INUMP (val))
 105 #else
 106           if (!SCM_BIGP (val) && !SCM_INUMP (val))
 107 #endif /* FLOATTYPE */
 108             SCM_WRONG_TYPE_ARG (SCM_ARG1, val);
 109         }
 110
 111       /* allocate new memory if necessary */
 112       if (data == NULL)
 113         if ((data = (CTYPE *) malloc (n * sizeof (CTYPE))) == NULL)
 114           return NULL;
 115
 116       /* traverse the vector once more and convert each member */
 117       for (i = 0; i < n; i++)
 118         {
 119           val = SCM_VELTS (obj)[i];
 120           if (SCM_INUMP (val))
 121             data[i] = (CTYPE) SCM_INUM (val);
 122           else if (SCM_BIGP (val))
 123             data[i] = (CTYPE) scm_num2long (val, SCM_ARG1, FUNC_NAME);
 124 #if defined (FLOATTYPE)
 125           else
 126             data[i] = (CTYPE) SCM_REAL_VALUE (val);
 127 #endif
 128         }
 129       break;
 130
 131 #ifdef HAVE_ARRAYS
 132       /* array conversions (uniform vectors) */
 133     case ARRAYTYPE:
 134 #ifdef ARRAYTYPE_OPTIONAL
 135     case ARRAYTYPE_OPTIONAL:
 136 #endif
 137       n = SCM_UVECTOR_LENGTH (obj);
 138
 139       /* allocate new memory if necessary */
 140       if (data == NULL)
 141         if ((data = (CTYPE *) malloc (n * sizeof (CTYPE))) == NULL)
 142           return NULL;
 143
 144 #ifdef FLOATTYPE_OPTIONAL
 145       /* float <-> double conversions */
 146       if (SCM_TYP7 (obj) == ARRAYTYPE_OPTIONAL)
 147         {
 148           for (i = 0; i < n; i++)
 149             data[i] = ((FLOATTYPE_OPTIONAL *) SCM_UVECTOR_BASE (obj))[i];
 150         }
 151       else
 152 #endif
 153 #if SIZEOF_CTYPE != SIZEOF_ARRAYTYPE
 154       /* copy array element by element */
 155       for (i = 0; i < n; i++)
 156         data[i] = (CTYPE) ((ARRAYCTYPE *) SCM_UVECTOR_BASE (obj))[i];
 157 #else
 158       /* copy whole array */
 159       memcpy (data, (CTYPE *) SCM_UVECTOR_BASE (obj), n * sizeof (CTYPE));
 160 #endif
 161       break;
 162 #endif /* HAVE_ARRAYS */
 163
 164 #if SIZEOF_CTYPE == 1
 165     case scm_tc7_string:
 166       n = SCM_STRING_LENGTH (obj);
 167       if (data == NULL)
 168         if ((data = (CTYPE *) malloc (n * sizeof (CTYPE))) == NULL)
 169           return NULL;
 170       memcpy (data, SCM_STRING_CHARS (obj), n * sizeof (CTYPE));
 171       break;
 172 #endif
 173
 174     default:
 175       SCM_WRONG_TYPE_ARG (SCM_ARG1, obj);
 176     }
 177   return data;
 178 }
 179 #undef FUNC_NAME
 180
 181
 182 #if HAVE_ARRAYS
 183
 184 /* Converts a C array into a uniform vector, returns SCM_UNDEFINED if out
 185    of memory. */
 186 #define FUNC_NAME CTYPES2UVECT_FN
 187 SCM
 188 CTYPES2UVECT (const CTYPE *data, long n)
 189 {
 190 #if SIZEOF_CTYPE != SIZEOF_UVECTTYPE
 191   UVECTCTYPE *v;
 192   long i;
 193 #else
 194   char *v;
 195 #endif
 196
 197   SCM_ASSERT_RANGE (SCM_ARG2, scm_long2num (n),
 198                     n > 0 && n <= SCM_UVECTOR_MAX_LENGTH);
 199 #if SIZEOF_CTYPE != SIZEOF_UVECTTYPE
 200   v = scm_gc_malloc (n * SIZEOF_UVECTTYPE, "uvect");
 201   for (i = 0; i < n; i++)
 202     v[i] = (UVECTCTYPE) data[i];
 203 #else
 204   v = scm_gc_malloc (n * sizeof (CTYPE), "uvect");
 205   memcpy (v, data, n * sizeof (CTYPE));
 206 #endif
 207   return scm_cell (SCM_MAKE_UVECTOR_TAG (n, UVECTTYPE), (scm_t_bits) v);
 208 }
 209 #undef FUNC_NAME
 210
 211 #ifdef UVECTTYPE_OPTIONAL
 212 #define FUNC_NAME CTYPES2UVECT_FN_OPTIONAL
 213 SCM
 214 CTYPES2UVECT_OPTIONAL (const unsigned CTYPE *data, long n)
 215 {
 216 #if SIZEOF_CTYPE != SIZEOF_UVECTTYPE
 217   unsigned UVECTCTYPE *v;
 218   long i;
 219 #else
 220   char *v;
 221 #endif
 222
 223   SCM_ASSERT_RANGE (SCM_ARG2, scm_long2num (n),
 224                     n > 0 && n <= SCM_UVECTOR_MAX_LENGTH);
 225 #if SIZEOF_CTYPE != SIZEOF_UVECTTYPE
 226   v = scm_gc_malloc (n * SIZEOF_UVECTTYPE, "uvect");
 227   for (i = 0; i < n; i++)
 228     v[i] = (unsigned UVECTCTYPE) data[i];
 229 #else
 230   v = scm_gc_malloc (n * sizeof (CTYPE), "uvect");
 231   memcpy (v, data, n * sizeof (CTYPE));
 232 #endif
 233   return scm_cell (SCM_MAKE_UVECTOR_TAG (n, UVECTTYPE_OPTIONAL),
 234                    (scm_t_bits) v);
 235 }
 236 #undef FUNC_NAME
 237 #endif /* UVECTTYPE_OPTIONAL */
 238
 239 #endif /* HAVE_ARRAYS */
 240
 241
 242 /* Converts a C array into a vector. */
 243 #define FUNC_NAME CTYPES2SCM_FN
 244 SCM
 245 CTYPES2SCM (const CTYPE *data, long n)
 246 {
 247   long i;
 248   SCM v;
 249
 250   SCM_ASSERT_RANGE (SCM_ARG2, scm_long2num (n),
 251                     n > 0 && n <= SCM_VECTOR_MAX_LENGTH);
 252   v = scm_c_make_vector (n, SCM_UNSPECIFIED);
 253
 254   for (i = 0; i < n; i++)
 255 #ifdef FLOATTYPE
 256     SCM_VECTOR_SET (v, i, scm_make_real ((double) data[i]));
 257 #else
 258     SCM_VECTOR_SET (v, i,  SCM_MAKINUM (data[i]));
 259 #endif
 260   return v;
 261 }
 262 #undef FUNC_NAME
 263
 264 /* cleanup of conditionals */
 265 #undef SCM2CTYPES
 266 #undef SCM2CTYPES_FN
 267 #undef CTYPES2SCM
 268 #undef CTYPES2SCM_FN
 269 #undef CTYPE
 270 #undef CTYPES2UVECT
 271 #undef CTYPES2UVECT_FN
 272 #undef UVECTTYPE
 273 #ifdef UVECTTYPE_OPTIONAL
 274 #undef CTYPES2UVECT_OPTIONAL
 275 #undef CTYPES2UVECT_FN_OPTIONAL
 276 #undef UVECTTYPE_OPTIONAL
 277 #endif
 278 #undef SIZEOF_CTYPE
 279 #undef SIZEOF_UVECTTYPE
 280 #undef SIZEOF_ARRAYTYPE
 281 #undef ARRAYTYPE
 282 #ifdef ARRAYTYPE_OPTIONAL
 283 #undef ARRAYTYPE_OPTIONAL
 284 #endif
 285 #ifdef FLOATTYPE
 286 #undef FLOATTYPE
 287 #endif
 288 #ifdef FLOATTYPE_OPTIONAL
 289 #undef FLOATTYPE_OPTIONAL
 290 #endif
 291 #ifdef UVECTCTYPE
 292 #undef UVECTCTYPE
 293 #endif
 294 #ifdef ARRAYCTYPE
 295 #undef ARRAYCTYPE
 296 #endif
 297
 298 /*
 299   Local Variables:
 300   c-file-style: "gnu"
 301   End:
 302 */