libguile/convert.i.c

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