/[guile]/guile/guile-core/libguile/convert.i.c
ViewVC logotype

Diff of /guile/guile-core/libguile/convert.i.c

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.2 by mvo, Mon Feb 11 18:06:50 2002 UTC revision 1.3 by ela, Wed Feb 27 15:41:01 2002 UTC
# Line 5  Line 5 
5    
6    
7  /* Convert a vector, weak vector, (if possible string, substring), list  /* 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     or uniform vector into an C array.  If the result array in argument 2
9     NULL, malloc() a new one.  If out of memory, return NULL.  */     is NULL, malloc() a new one.  If out of memory, return NULL.  */
10  #define FUNC_NAME SCM2CTYPES_FN  #define FUNC_NAME SCM2CTYPES_FN
11  CTYPE *  CTYPE *
12  SCM2CTYPES (SCM obj, CTYPE *data)  SCM2CTYPES (SCM obj, CTYPE *data)
# Line 17  SCM2CTYPES (SCM obj, CTYPE *data) Line 17  SCM2CTYPES (SCM obj, CTYPE *data)
17    SCM_ASSERT (SCM_NIMP (obj) || SCM_NFALSEP (scm_list_p (obj)),    SCM_ASSERT (SCM_NIMP (obj) || SCM_NFALSEP (scm_list_p (obj)),
18                obj, SCM_ARG1, FUNC_NAME);                obj, SCM_ARG1, FUNC_NAME);
19    
20      /* list conversion */
21    if (SCM_NFALSEP (scm_list_p (obj)))    if (SCM_NFALSEP (scm_list_p (obj)))
22      {      {
23          /* traverse the given list and validate the range of each member */
24        SCM list = obj;        SCM list = obj;
25        for (n = 0; SCM_NFALSEP (scm_pair_p (list)); list = SCM_CDR (list), n++)        for (n = 0; SCM_NFALSEP (scm_pair_p (list)); list = SCM_CDR (list), n++)
26          {          {
27            val = SCM_CAR (list);            val = SCM_CAR (list);
28  #if defined (CTYPEMIN) && defined (CTYPEMAX)  #if SIZEOF_CTYPE && SIZEOF_CTYPE < SIZEOF_SCM_T_BITS
29              /* check integer ranges */
30            if (SCM_INUMP (val))            if (SCM_INUMP (val))
31              {              {
32                long v = SCM_INUM (val);                scm_t_signed_bits v = SCM_INUM (val);
33                SCM_ASSERT_RANGE (SCM_ARG1, obj, v >= CTYPEMIN && v <= CTYPEMAX);                CTYPE c = (CTYPE) v;
34                  SCM_ASSERT_RANGE (SCM_ARG1, val, v != (scm_t_signed_bits) c);
35              }              }
36            else            /* check big number ranges */
37  #elif defined (FLOATTYPE1)            else if (SCM_BIGP (val))
38            if (!SCM_INUMP (val) && !(SCM_BIGP (val) || SCM_REALP (val)))              {
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  #else
50            if (!SCM_INUMP (val) && !SCM_BIGP (val))            if (!SCM_BIGP (val) && !SCM_INUMP (val))
51  #endif  #endif /* FLOATTYPE */
52              SCM_WRONG_TYPE_ARG (SCM_ARG1, obj);              SCM_WRONG_TYPE_ARG (SCM_ARG1, val);
53          }          }
54    
55          /* allocate new memory if necessary */
56        if (data == NULL)        if (data == NULL)
57          data = (CTYPE *) malloc (n * sizeof (CTYPE));          {
58        if (data == NULL)            if ((data = (CTYPE *) malloc (n * sizeof (CTYPE))) == NULL)
59          return NULL;              return NULL;
60            }
61    
62          /* traverse the list once more and convert each member */
63        list = obj;        list = obj;
64        for (i = 0; SCM_NFALSEP (scm_pair_p (list)); list = SCM_CDR (list), i++)        for (i = 0; SCM_NFALSEP (scm_pair_p (list)); list = SCM_CDR (list), i++)
65          {          {
66            val = SCM_CAR (list);            val = SCM_CAR (list);
67            if (SCM_INUMP (val))            if (SCM_INUMP (val))
68              data[i] = SCM_INUM (val);              data[i] = (CTYPE) SCM_INUM (val);
69            else if (SCM_BIGP (val))            else if (SCM_BIGP (val))
70              data[i] = (CTYPE) scm_num2long (val, SCM_ARG1, FUNC_NAME);              data[i] = (CTYPE) scm_num2long (val, SCM_ARG1, FUNC_NAME);
71  #ifdef FLOATTYPE1  #if defined (FLOATTYPE)
72            else            else
73              data[i] = (CTYPE) SCM_REAL_VALUE (val);              data[i] = (CTYPE) SCM_REAL_VALUE (val);
74  #endif  #endif
# Line 58  SCM2CTYPES (SCM obj, CTYPE *data) Line 76  SCM2CTYPES (SCM obj, CTYPE *data)
76        return data;        return data;
77      }      }
78    
79      /* other conversions */
80    switch (SCM_TYP7 (obj))    switch (SCM_TYP7 (obj))
81      {      {
82          /* vectors and weak vectors */
83      case scm_tc7_vector:      case scm_tc7_vector:
84      case scm_tc7_wvect:      case scm_tc7_wvect:
85        n = SCM_VECTOR_LENGTH (obj);        n = SCM_VECTOR_LENGTH (obj);
86          /* traverse the given vector and validate each member */
87        for (i = 0; i < n; i++)        for (i = 0; i < n; i++)
88          {          {
89            val = SCM_VELTS (obj)[i];            val = SCM_VELTS (obj)[i];
90    #if SIZEOF_CTYPE && SIZEOF_CTYPE < SIZEOF_SCM_T_BITS
91  #if defined (CTYPEMIN) && defined (CTYPEMAX)            /* check integer ranges */
92            if (SCM_INUMP (val))            if (SCM_INUMP (val))
93              {              {
94                long v = SCM_INUM (val);                scm_t_signed_bits v = SCM_INUM (val);
95                SCM_ASSERT_RANGE (SCM_ARG1, obj, v >= CTYPEMIN && v <= CTYPEMAX);                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            else
106  #elif defined (FLOATTYPE1)            /* check float types */
107            if (!SCM_INUMP (val) && !(SCM_BIGP (val) || SCM_REALP (val)))  #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  #else
112            if (!SCM_INUMP (val) && !SCM_BIGP (val))            if (!SCM_BIGP (val) && !SCM_INUMP (val))
113  #endif  #endif /* FLOATTYPE */
114              SCM_WRONG_TYPE_ARG (SCM_ARG1, obj);              SCM_WRONG_TYPE_ARG (SCM_ARG1, val);
115          }          }
116    
117          /* allocate new memory if necessary */
118        if (data == NULL)        if (data == NULL)
119          data = (CTYPE *) malloc (n * sizeof (CTYPE));          {
120        if (data == NULL)            if ((data = (CTYPE *) malloc (n * sizeof (CTYPE))) == NULL)
121          return NULL;              return NULL;
122            }
123    
124          /* traverse the vector once more and convert each member */
125        for (i = 0; i < n; i++)        for (i = 0; i < n; i++)
126          {          {
127            val = SCM_VELTS (obj)[i];            val = SCM_VELTS (obj)[i];
# Line 92  SCM2CTYPES (SCM obj, CTYPE *data) Line 129  SCM2CTYPES (SCM obj, CTYPE *data)
129              data[i] = (CTYPE) SCM_INUM (val);              data[i] = (CTYPE) SCM_INUM (val);
130            else if (SCM_BIGP (val))            else if (SCM_BIGP (val))
131              data[i] = (CTYPE) scm_num2long (val, SCM_ARG1, FUNC_NAME);              data[i] = (CTYPE) scm_num2long (val, SCM_ARG1, FUNC_NAME);
132  #ifdef FLOATTYPE1  #if defined (FLOATTYPE)
133            else            else
134              data[i] = (CTYPE) SCM_REAL_VALUE (val);              data[i] = (CTYPE) SCM_REAL_VALUE (val);
135  #endif  #endif
# Line 100  SCM2CTYPES (SCM obj, CTYPE *data) Line 137  SCM2CTYPES (SCM obj, CTYPE *data)
137        break;        break;
138    
139  #ifdef HAVE_ARRAYS  #ifdef HAVE_ARRAYS
140      case ARRAYTYPE1:        /* array conversions (uniform vectors) */
141  #ifdef ARRAYTYPE2      case ARRAYTYPE:
142      case ARRAYTYPE2:  #ifdef ARRAYTYPE_OPTIONAL
143        case ARRAYTYPE_OPTIONAL:
144  #endif  #endif
145        n = SCM_UVECTOR_LENGTH (obj);        n = SCM_UVECTOR_LENGTH (obj);
146    
147          /* allocate new memory if necessary */
148        if (data == NULL)        if (data == NULL)
149          data = (CTYPE *) malloc (n * sizeof (CTYPE));          {
150        if (data == NULL)            if ((data = (CTYPE *) malloc (n * sizeof (CTYPE))) == NULL)
151          return NULL;              return NULL;
152  #ifdef FLOATTYPE2          }
153        if (SCM_TYP7 (obj) == ARRAYTYPE2)  
154    #ifdef FLOATTYPE_OPTIONAL
155          /* float <-> double conversions */
156          if (SCM_TYP7 (obj) == ARRAYTYPE_OPTIONAL)
157          {          {
158            for (i = 0; i < n; i++)            for (i = 0; i < n; i++)
159              data[i] = ((FLOATTYPE2 *) SCM_UVECTOR_BASE (obj))[i];              data[i] = ((FLOATTYPE_OPTIONAL *) SCM_UVECTOR_BASE (obj))[i];
160          }          }
161        else        else
162  #endif  #endif
163          /* copy whole array */
164        memcpy (data, (CTYPE *) SCM_UVECTOR_BASE (obj), n * sizeof (CTYPE));        memcpy (data, (CTYPE *) SCM_UVECTOR_BASE (obj), n * sizeof (CTYPE));
165        break;        break;
166  #endif /* HAVE_ARRAYS */  #endif /* HAVE_ARRAYS */
167    
168  #ifdef STRINGTYPE  #if SIZEOF_CTYPE == 1
169      case scm_tc7_string:      case scm_tc7_string:
170        n = SCM_STRING_LENGTH (obj);        n = SCM_STRING_LENGTH (obj);
171        if (data == NULL)        if (data == NULL)
172          data = (CTYPE *) malloc (n * sizeof (CTYPE));          if ((data = (CTYPE *) malloc (n * sizeof (CTYPE))) == NULL)
173        if (data == NULL)            return NULL;
         return NULL;  
174        memcpy (data, SCM_STRING_CHARS (obj), n * sizeof (CTYPE));        memcpy (data, SCM_STRING_CHARS (obj), n * sizeof (CTYPE));
175        break;        break;
176  #endif /* STRINGTYPE */  #endif
177    
178      default:      default:
179        SCM_WRONG_TYPE_ARG (SCM_ARG1, obj);        SCM_WRONG_TYPE_ARG (SCM_ARG1, obj);
# Line 150  CTYPES2UVECT (const CTYPE *data, long n) Line 193  CTYPES2UVECT (const CTYPE *data, long n)
193  {  {
194    char *v;    char *v;
195    
196    SCM_ASSERT_RANGE (SCM_ARG2, scm_long2num (n),    SCM_ASSERT_RANGE (SCM_ARG2, scm_long2num (n),
197                      n > 0 && n <= SCM_UVECTOR_MAX_LENGTH);                      n > 0 && n <= SCM_UVECTOR_MAX_LENGTH);
198    v = scm_gc_malloc (sizeof (CTYPE) * n, "vector");    v = scm_gc_malloc (n * sizeof (CTYPE), "uvect");
199    memcpy (v, data, n * sizeof (CTYPE));    memcpy (v, data, n * sizeof (CTYPE));
200    return scm_alloc_cell (SCM_MAKE_UVECTOR_TAG (n, UVECTTYPE), (scm_t_bits) v);    return scm_alloc_cell (SCM_MAKE_UVECTOR_TAG (n, UVECTTYPE), (scm_t_bits) v);
201  }  }
202  #undef FUNC_NAME  #undef FUNC_NAME
203    
204  #ifdef UVECTTYPE2  #ifdef UVECTTYPE_OPTIONAL
205  #define FUNC_NAME CTYPES2UVECT_FN2  #define FUNC_NAME CTYPES2UVECT_FN_OPTIONAL
206  SCM  SCM
207  CTYPES2UVECT2 (const unsigned CTYPE *data, long n)  CTYPES2UVECT_OPTIONAL (const unsigned CTYPE *data, long n)
208  {  {
209    char *v;    char *v;
210    
211    SCM_ASSERT_RANGE (SCM_ARG2, scm_long2num (n),    SCM_ASSERT_RANGE (SCM_ARG2, scm_long2num (n),
212                      n > 0 && n <= SCM_UVECTOR_MAX_LENGTH);                      n > 0 && n <= SCM_UVECTOR_MAX_LENGTH);
213    v = scm_gc_malloc (sizeof (unsigned CTYPE) * n, "vector");    v = scm_gc_malloc (n * sizeof (unsigned CTYPE) * n, "uvect");
214    memcpy (v, data, n * sizeof (unsigned CTYPE));    memcpy (v, data, n * sizeof (unsigned CTYPE));
215    return scm_alloc_cell (SCM_MAKE_UVECTOR_TAG (n, UVECTTYPE2), (scm_t_bits) v);    return scm_alloc_cell (SCM_MAKE_UVECTOR_TAG (n, UVECTTYPE_OPTIONAL),
216                             (scm_t_bits) v);
217  }  }
218  #undef FUNC_NAME  #undef FUNC_NAME
219  #endif /* UVECTTYPE2 */  #endif /* UVECTTYPE_OPTIONAL */
220    
221  #endif /* HAVE_ARRAYS */  #endif /* HAVE_ARRAYS */
222    
223    
224  /* Converts a C array into a vector. */  /* Converts a C array into a vector. */
225  #define FUNC_NAME CTYPES2SCM_FN  #define FUNC_NAME CTYPES2SCM_FN
226  SCM  SCM
# Line 189  CTYPES2SCM (const CTYPE *data, long n) Line 234  CTYPES2SCM (const CTYPE *data, long n)
234    v = scm_c_make_vector (n, SCM_UNSPECIFIED);    v = scm_c_make_vector (n, SCM_UNSPECIFIED);
235    velts = SCM_VELTS (v);    velts = SCM_VELTS (v);
236    for (i = 0; i < n; i++)    for (i = 0; i < n; i++)
237  #ifdef FLOATTYPE1  #ifdef FLOATTYPE
238      velts[i] = scm_make_real ((double) data[i]);      velts[i] = scm_make_real ((double) data[i]);
 #elif defined (CTYPEFIXABLE)  
     velts[i] = SCM_MAKINUM (data[i]);  
239  #else  #else
240      velts[i] = (SCM_FIXABLE (data[i]) ? SCM_MAKINUM (data[i]) :      velts[i] = SCM_MAKINUM (data[i]);
                 scm_i_long2big (data[i]));  
241  #endif  #endif
242    return v;    return v;
243  }  }
# Line 209  CTYPES2SCM (const CTYPE *data, long n) Line 251  CTYPES2SCM (const CTYPE *data, long n)
251  #undef CTYPE  #undef CTYPE
252  #undef CTYPES2UVECT  #undef CTYPES2UVECT
253  #undef CTYPES2UVECT_FN  #undef CTYPES2UVECT_FN
 #ifdef CTYPEFIXABLE  
 #undef CTYPEFIXABLE  
 #endif  
254  #undef UVECTTYPE  #undef UVECTTYPE
255  #ifdef UVECTTYPE2  #ifdef UVECTTYPE_OPTIONAL
256  #undef CTYPES2UVECT2  #undef CTYPES2UVECT_OPTIONAL
257  #undef CTYPES2UVECT_FN2  #undef CTYPES2UVECT_FN_OPTIONAL
258  #undef UVECTTYPE2  #undef UVECTTYPE_OPTIONAL
259  #endif  #endif
260  #ifdef CTYPEMIN  #undef SIZEOF_CTYPE
261  #undef CTYPEMIN  #undef ARRAYTYPE
262  #endif  #ifdef ARRAYTYPE_OPTIONAL
263  #ifdef CTYPEMAX  #undef ARRAYTYPE_OPTIONAL
 #undef CTYPEMAX  
 #endif  
 #undef ARRAYTYPE1  
 #ifdef ARRAYTYPE2  
 #undef ARRAYTYPE2  
 #endif  
 #ifdef FLOATTYPE1  
 #undef FLOATTYPE1  
264  #endif  #endif
265  #ifdef FLOATTYPE2  #ifdef FLOATTYPE
266  #undef FLOATTYPE2  #undef FLOATTYPE
267  #endif  #endif
268  #ifdef STRINGTYPE  #ifdef FLOATTYPE_OPTIONAL
269  #undef STRINGTYPE  #undef FLOATTYPE_OPTIONAL
270  #endif  #endif
271    
272  /*  /*

Legend:
Removed from v.1.2  
changed lines
  Added in v.1.3

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26