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 result array in argument 2 is
   9    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   if (SCM_NFALSEP (scm_list_p (obj)))
  21     {
  22       SCM list = obj;
  23       for (n = 0; SCM_NFALSEP (scm_pair_p (list)); list = SCM_CDR (list), n++)
  24         {
  25           val = SCM_CAR (list);
  26 #if defined (CTYPEMIN) && defined (CTYPEMAX)
  27           if (SCM_INUMP (val))
  28             {
  29               long v = SCM_INUM (val);
  30               SCM_ASSERT_RANGE (SCM_ARG1, obj, v >= CTYPEMIN && v <= CTYPEMAX);
  31             }
  32           else
  33 #elif defined (FLOATTYPE1)
  34           if (!SCM_INUMP (val) && !(SCM_BIGP (val) || SCM_REALP (val)))
  35 #else
  36           if (!SCM_INUMP (val) && !SCM_BIGP (val))
  37 #endif
  38             SCM_WRONG_TYPE_ARG (SCM_ARG1, obj);
  39         }
  40       if (data == NULL)
  41         data = (CTYPE *) malloc (n * sizeof (CTYPE));
  42       if (data == NULL)
  43         return NULL;
  44
  45       list = obj;
  46       for (i = 0; SCM_NFALSEP (scm_pair_p (list)); list = SCM_CDR (list), i++)
  47         {
  48           val = SCM_CAR (list);
  49           if (SCM_INUMP (val))
  50             data[i] = SCM_INUM (val);
  51           else if (SCM_BIGP (val))
  52             data[i] = (CTYPE) scm_num2long (val, SCM_ARG1, FUNC_NAME);
  53 #ifdef FLOATTYPE1
  54           else
  55             data[i] = (CTYPE) SCM_REAL_VALUE (val);
  56 #endif
  57         }
  58       return data;
  59     }
  60
  61   switch (SCM_TYP7 (obj))
  62     {
  63     case scm_tc7_vector:
  64     case scm_tc7_wvect:
  65       n = SCM_VECTOR_LENGTH (obj);
  66       for (i = 0; i < n; i++)
  67         {
  68           val = SCM_VELTS (obj)[i];
  69
  70 #if defined (CTYPEMIN) && defined (CTYPEMAX)
  71           if (SCM_INUMP (val))
  72             {
  73               long v = SCM_INUM (val);
  74               SCM_ASSERT_RANGE (SCM_ARG1, obj, v >= CTYPEMIN && v <= CTYPEMAX);
  75             }
  76           else
  77 #elif defined (FLOATTYPE1)
  78           if (!SCM_INUMP (val) && !(SCM_BIGP (val) || SCM_REALP (val)))
  79 #else
  80           if (!SCM_INUMP (val) && !SCM_BIGP (val))
  81 #endif
  82             SCM_WRONG_TYPE_ARG (SCM_ARG1, obj);
  83         }
  84       if (data == NULL)
  85         data = (CTYPE *) malloc (n * sizeof (CTYPE));
  86       if (data == NULL)
  87         return NULL;
  88       for (i = 0; i < n; i++)
  89         {
  90           val = SCM_VELTS (obj)[i];
  91           if (SCM_INUMP (val))
  92             data[i] = (CTYPE) SCM_INUM (val);
  93           else if (SCM_BIGP (val))
  94             data[i] = (CTYPE) scm_num2long (val, SCM_ARG1, FUNC_NAME);
  95 #ifdef FLOATTYPE1
  96           else
  97             data[i] = (CTYPE) SCM_REAL_VALUE (val);
  98 #endif
  99         }
 100       break;
 101
 102 #ifdef HAVE_ARRAYS
 103     case ARRAYTYPE1:
 104 #ifdef ARRAYTYPE2
 105     case ARRAYTYPE2:
 106 #endif
 107       n = SCM_UVECTOR_LENGTH (obj);
 108       if (data == NULL)
 109         data = (CTYPE *) malloc (n * sizeof (CTYPE));
 110       if (data == NULL)
 111         return NULL;
 112 #ifdef FLOATTYPE2
 113       if (SCM_TYP7 (obj) == ARRAYTYPE2)
 114         {
 115           for (i = 0; i < n; i++)
 116             data[i] = ((FLOATTYPE2 *) SCM_UVECTOR_BASE (obj))[i];
 117         }
 118       else
 119 #endif
 120       memcpy (data, (CTYPE *) SCM_UVECTOR_BASE (obj), n * sizeof (CTYPE));
 121       break;
 122 #endif /* HAVE_ARRAYS */
 123
 124 #ifdef STRINGTYPE
 125     case scm_tc7_string:
 126       n = SCM_STRING_LENGTH (obj);
 127       if (data == NULL)
 128         data = (CTYPE *) malloc (n * sizeof (CTYPE));
 129       if (data == NULL)
 130         return NULL;
 131       memcpy (data, SCM_STRING_CHARS (obj), n * sizeof (CTYPE));
 132       break;
 133 #endif /* STRINGTYPE */
 134
 135     default:
 136       SCM_WRONG_TYPE_ARG (SCM_ARG1, obj);
 137     }
 138   return data;
 139 }
 140 #undef FUNC_NAME
 141
 142
 143 #if HAVE_ARRAYS
 144
 145 /* Converts a C array into a uniform vector, returns SCM_UNDEFINED if out
 146    of memory. */
 147 #define FUNC_NAME CTYPES2UVECT_FN
 148 SCM
 149 CTYPES2UVECT (const CTYPE *data, long n)
 150 {
 151   char *v;
 152
 153   SCM_ASSERT_RANGE (SCM_ARG2, scm_long2num (n),
 154                     n > 0 && n <= SCM_UVECTOR_MAX_LENGTH);
 155   v = scm_gc_malloc (sizeof (CTYPE) * n, "vector");
 156   memcpy (v, data, n * sizeof (CTYPE));
 157   return scm_alloc_cell (SCM_MAKE_UVECTOR_TAG (n, UVECTTYPE), (scm_t_bits) v);
 158 }
 159 #undef FUNC_NAME
 160
 161 #ifdef UVECTTYPE2
 162 #define FUNC_NAME CTYPES2UVECT_FN2
 163 SCM
 164 CTYPES2UVECT2 (const unsigned CTYPE *data, long n)
 165 {
 166   char *v;
 167
 168   SCM_ASSERT_RANGE (SCM_ARG2, scm_long2num (n),
 169                     n > 0 && n <= SCM_UVECTOR_MAX_LENGTH);
 170   v = scm_gc_malloc (sizeof (unsigned CTYPE) * n, "vector");
 171   memcpy (v, data, n * sizeof (unsigned CTYPE));
 172   return scm_alloc_cell (SCM_MAKE_UVECTOR_TAG (n, UVECTTYPE2), (scm_t_bits) v);
 173 }
 174 #undef FUNC_NAME
 175 #endif /* UVECTTYPE2 */
 176
 177 #endif /* HAVE_ARRAYS */
 178
 179 /* Converts a C array into a vector. */
 180 #define FUNC_NAME CTYPES2SCM_FN
 181 SCM
 182 CTYPES2SCM (const CTYPE *data, long n)
 183 {
 184   long i;
 185   SCM v, *velts;
 186
 187   SCM_ASSERT_RANGE (SCM_ARG2, scm_long2num (n),
 188                     n > 0 && n <= SCM_VECTOR_MAX_LENGTH);
 189   v = scm_c_make_vector (n, SCM_UNSPECIFIED);
 190   velts = SCM_VELTS (v);
 191   for (i = 0; i < n; i++)
 192 #ifdef FLOATTYPE1
 193     velts[i] = scm_make_real ((double) data[i]);
 194 #elif defined (CTYPEFIXABLE)
 195     velts[i] = SCM_MAKINUM (data[i]);
 196 #else
 197     velts[i] = (SCM_FIXABLE (data[i]) ? SCM_MAKINUM (data[i]) :
 198                 scm_i_long2big (data[i]));
 199 #endif
 200   return v;
 201 }
 202 #undef FUNC_NAME
 203
 204 /* cleanup of conditionals */
 205 #undef SCM2CTYPES
 206 #undef SCM2CTYPES_FN
 207 #undef CTYPES2SCM
 208 #undef CTYPES2SCM_FN
 209 #undef CTYPE
 210 #undef CTYPES2UVECT
 211 #undef CTYPES2UVECT_FN
 212 #ifdef CTYPEFIXABLE
 213 #undef CTYPEFIXABLE
 214 #endif
 215 #undef UVECTTYPE
 216 #ifdef UVECTTYPE2
 217 #undef CTYPES2UVECT2
 218 #undef CTYPES2UVECT_FN2
 219 #undef UVECTTYPE2
 220 #endif
 221 #ifdef CTYPEMIN
 222 #undef CTYPEMIN
 223 #endif
 224 #ifdef CTYPEMAX
 225 #undef CTYPEMAX
 226 #endif
 227 #undef ARRAYTYPE1
 228 #ifdef ARRAYTYPE2
 229 #undef ARRAYTYPE2
 230 #endif
 231 #ifdef FLOATTYPE1
 232 #undef FLOATTYPE1
 233 #endif
 234 #ifdef FLOATTYPE2
 235 #undef FLOATTYPE2
 236 #endif
 237 #ifdef STRINGTYPE
 238 #undef STRINGTYPE
 239 #endif
 240
 241 /*
 242   Local Variables:
 243   c-file-style: "gnu"
 244   End:
 245 */