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         {
  58           if ((data = (CTYPE *) malloc (n * sizeof (CTYPE))) == NULL)
  59             return NULL;
  60         }
  61
  62       /* traverse the list once more and convert each member */
  63       list = obj;
  64       for (i = 0; SCM_NFALSEP (scm_pair_p (list)); list = SCM_CDR (list), i++)
  65         {
  66           val = SCM_CAR (list);
  67           if (SCM_INUMP (val))
  68             data[i] = (CTYPE) SCM_INUM (val);
  69           else if (SCM_BIGP (val))
  70             data[i] = (CTYPE) scm_num2long (val, SCM_ARG1, FUNC_NAME);
  71 #if defined (FLOATTYPE)
  72           else
  73             data[i] = (CTYPE) SCM_REAL_VALUE (val);
  74 #endif
  75         }
  76       return data;
  77     }
  78
  79   /* other conversions */
  80   switch (SCM_TYP7 (obj))
  81     {
  82       /* vectors and weak vectors */
  83     case scm_tc7_vector:
  84     case scm_tc7_wvect:
  85       n = SCM_VECTOR_LENGTH (obj);
  86       /* traverse the given vector and validate each member */
  87       for (i = 0; i < n; i++)
  88         {
  89           val = SCM_VELTS (obj)[i];
  90 #if SIZEOF_CTYPE && SIZEOF_CTYPE < SIZEOF_SCM_T_BITS
  91           /* check integer ranges */
  92           if (SCM_INUMP (val))
  93             {
  94               scm_t_signed_bits v = SCM_INUM (val);
  95               CTYPE c = (CTYPE) v;
  96               SCM_ASSERT_RANGE (SCM_ARG1, val, v != (scm_t_signed_bits) c);
  97             }
  98           /* check big number ranges */
  99           else if (SCM_BIGP (val))
 100             {
 101               scm_t_signed_bits v = scm_num2long (val, SCM_ARG1, FUNC_NAME);
 102               CTYPE c = (CTYPE) v;
 103               SCM_ASSERT_RANGE (SCM_ARG1, val, v != (scm_t_signed_bits) c);
 104             }
 105           else
 106           /* check float types */
 107 #elif defined (FLOATTYPE)
 108           /* real values, big numbers and immediate values are valid
 109              for float conversions */
 110           if (!SCM_REALP (val) && !SCM_BIGP (val) && !SCM_INUMP (val))
 111 #else
 112           if (!SCM_BIGP (val) && !SCM_INUMP (val))
 113 #endif /* FLOATTYPE */
 114             SCM_WRONG_TYPE_ARG (SCM_ARG1, val);
 115         }
 116
 117       /* allocate new memory if necessary */
 118       if (data == NULL)
 119         {
 120           if ((data = (CTYPE *) malloc (n * sizeof (CTYPE))) == NULL)
 121             return NULL;
 122         }
 123
 124       /* traverse the vector once more and convert each member */
 125       for (i = 0; i < n; i++)
 126         {
 127           val = SCM_VELTS (obj)[i];
 128           if (SCM_INUMP (val))
 129             data[i] = (CTYPE) SCM_INUM (val);
 130           else if (SCM_BIGP (val))
 131             data[i] = (CTYPE) scm_num2long (val, SCM_ARG1, FUNC_NAME);
 132 #if defined (FLOATTYPE)
 133           else
 134             data[i] = (CTYPE) SCM_REAL_VALUE (val);
 135 #endif
 136         }
 137       break;
 138
 139 #ifdef HAVE_ARRAYS
 140       /* array conversions (uniform vectors) */
 141     case ARRAYTYPE:
 142 #ifdef ARRAYTYPE_OPTIONAL
 143     case ARRAYTYPE_OPTIONAL:
 144 #endif
 145       n = SCM_UVECTOR_LENGTH (obj);
 146
 147       /* allocate new memory if necessary */
 148       if (data == NULL)
 149         {
 150           if ((data = (CTYPE *) malloc (n * sizeof (CTYPE))) == NULL)
 151             return NULL;
 152         }
 153
 154 #ifdef FLOATTYPE_OPTIONAL
 155       /* float <-> double conversions */
 156       if (SCM_TYP7 (obj) == ARRAYTYPE_OPTIONAL)
 157         {
 158           for (i = 0; i < n; i++)
 159             data[i] = ((FLOATTYPE_OPTIONAL *) SCM_UVECTOR_BASE (obj))[i];
 160         }
 161       else
 162 #endif
 163       /* copy whole array */
 164       memcpy (data, (CTYPE *) SCM_UVECTOR_BASE (obj), n * sizeof (CTYPE));
 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   char *v;
 195
 196   SCM_ASSERT_RANGE (SCM_ARG2, scm_long2num (n),
 197                     n > 0 && n <= SCM_UVECTOR_MAX_LENGTH);
 198   v = scm_gc_malloc (n * sizeof (CTYPE), "uvect");
 199   memcpy (v, data, n * sizeof (CTYPE));
 200   return scm_alloc_cell (SCM_MAKE_UVECTOR_TAG (n, UVECTTYPE), (scm_t_bits) v);
 201 }
 202 #undef FUNC_NAME
 203
 204 #ifdef UVECTTYPE_OPTIONAL
 205 #define FUNC_NAME CTYPES2UVECT_FN_OPTIONAL
 206 SCM
 207 CTYPES2UVECT_OPTIONAL (const unsigned CTYPE *data, long n)
 208 {
 209   char *v;
 210
 211   SCM_ASSERT_RANGE (SCM_ARG2, scm_long2num (n),
 212                     n > 0 && n <= SCM_UVECTOR_MAX_LENGTH);
 213   v = scm_gc_malloc (n * sizeof (unsigned CTYPE) * n, "uvect");
 214   memcpy (v, data, n * sizeof (unsigned CTYPE));
 215   return scm_alloc_cell (SCM_MAKE_UVECTOR_TAG (n, UVECTTYPE_OPTIONAL),
 216                          (scm_t_bits) v);
 217 }
 218 #undef FUNC_NAME
 219 #endif /* UVECTTYPE_OPTIONAL */
 220
 221 #endif /* HAVE_ARRAYS */
 222
 223
 224 /* Converts a C array into a vector. */
 225 #define FUNC_NAME CTYPES2SCM_FN
 226 SCM
 227 CTYPES2SCM (const CTYPE *data, long n)
 228 {
 229   long i;
 230   SCM v, *velts;
 231
 232   SCM_ASSERT_RANGE (SCM_ARG2, scm_long2num (n),
 233                     n > 0 && n <= SCM_VECTOR_MAX_LENGTH);
 234   v = scm_c_make_vector (n, SCM_UNSPECIFIED);
 235   velts = SCM_VELTS (v);
 236   for (i = 0; i < n; i++)
 237 #ifdef FLOATTYPE
 238     velts[i] = scm_make_real ((double) data[i]);
 239 #else
 240     velts[i] = SCM_MAKINUM (data[i]);
 241 #endif
 242   return v;
 243 }
 244 #undef FUNC_NAME
 245
 246 /* cleanup of conditionals */
 247 #undef SCM2CTYPES
 248 #undef SCM2CTYPES_FN
 249 #undef CTYPES2SCM
 250 #undef CTYPES2SCM_FN
 251 #undef CTYPE
 252 #undef CTYPES2UVECT
 253 #undef CTYPES2UVECT_FN
 254 #undef UVECTTYPE
 255 #ifdef UVECTTYPE_OPTIONAL
 256 #undef CTYPES2UVECT_OPTIONAL
 257 #undef CTYPES2UVECT_FN_OPTIONAL
 258 #undef UVECTTYPE_OPTIONAL
 259 #endif
 260 #undef SIZEOF_CTYPE
 261 #undef ARRAYTYPE
 262 #ifdef ARRAYTYPE_OPTIONAL
 263 #undef ARRAYTYPE_OPTIONAL
 264 #endif
 265 #ifdef FLOATTYPE
 266 #undef FLOATTYPE
 267 #endif
 268 #ifdef FLOATTYPE_OPTIONAL
 269 #undef FLOATTYPE_OPTIONAL
 270 #endif
 271
 272 /*
 273   Local Variables:
 274   c-file-style: "gnu"
 275   End:
 276 */