mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-06 23:50:18 +02:00
4c9419ac31
non-zero is returned from a port or smob free function. (scm_malloc, scm_realloc, scm_strndup, scm_strdup, scm_gc_register_collectable_memory, scm_gc_unregister_collectable_memory, scm_gc_malloc, scm_gc_realloc, scm_gc_free, scm_gc_strndup, scm_gc_strdup): New. * backtrace.c, continuations.c, convert.i.c, coop-threads.c, debug-malloc.c, dynl.c, environments.c, environments.h, extensions.c, filesys.c, fports.c, gc.c, gc.h, gh_data.c, goops.c, guardians.c, hooks.c, init.c, keywords.c, load.c, numbers.c, ports.c, posix.c, procs.c, rdelim.c, regex-posix.c, root.c, smob.c, stime.c, strings.c, struct.c, struct.h, symbols.c, unif.c, vectors.c, weaks.c: Use scm_gc_malloc/scm_malloc and scm_gc_free/free instead of scm_must_malloc and scm_must_free, as appropriate. Return zero from smob and port free functions. * debug-malloc.c (scm_malloc_reregister): Handle "old == NULL". * fports.c (scm_setvbuf): Reset read buffer to saved values when it is pointing to the putback buffer.
245 lines
5.9 KiB
C
245 lines
5.9 KiB
C
/* this file is #include'd (x times) by convert.c */
|
|
|
|
/* FIXME: Should we use exported wrappers for malloc (and free), which
|
|
* allow windows DLLs to call the correct freeing function? */
|
|
|
|
|
|
/* Convert a vector, weak vector, (if possible string, substring), list
|
|
or uniform vector into an C array. If result array in argument 2 is
|
|
NULL, malloc() a new one. If out of memory, return NULL. */
|
|
#define FUNC_NAME SCM2CTYPES_FN
|
|
CTYPE *
|
|
SCM2CTYPES (SCM obj, CTYPE *data)
|
|
{
|
|
long i, n;
|
|
SCM val;
|
|
|
|
SCM_ASSERT (SCM_NIMP (obj) || SCM_NFALSEP (scm_list_p (obj)),
|
|
obj, SCM_ARG1, FUNC_NAME);
|
|
|
|
if (SCM_NFALSEP (scm_list_p (obj)))
|
|
{
|
|
SCM list = obj;
|
|
for (n = 0; SCM_NFALSEP (scm_pair_p (list)); list = SCM_CDR (list), n++)
|
|
{
|
|
val = SCM_CAR (list);
|
|
#if defined (CTYPEMIN) && defined (CTYPEMAX)
|
|
if (SCM_INUMP (val))
|
|
{
|
|
long v = SCM_INUM (val);
|
|
SCM_ASSERT_RANGE (SCM_ARG1, obj, v >= CTYPEMIN && v <= CTYPEMAX);
|
|
}
|
|
else
|
|
#elif defined (FLOATTYPE1)
|
|
if (!SCM_INUMP (val) && !(SCM_BIGP (val) || SCM_REALP (val)))
|
|
#else
|
|
if (!SCM_INUMP (val) && !SCM_BIGP (val))
|
|
#endif
|
|
SCM_WRONG_TYPE_ARG (SCM_ARG1, obj);
|
|
}
|
|
if (data == NULL)
|
|
data = (CTYPE *) malloc (n * sizeof (CTYPE));
|
|
if (data == NULL)
|
|
return NULL;
|
|
|
|
list = obj;
|
|
for (i = 0; SCM_NFALSEP (scm_pair_p (list)); list = SCM_CDR (list), i++)
|
|
{
|
|
val = SCM_CAR (list);
|
|
if (SCM_INUMP (val))
|
|
data[i] = SCM_INUM (val);
|
|
else if (SCM_BIGP (val))
|
|
data[i] = (CTYPE) scm_num2long (val, SCM_ARG1, FUNC_NAME);
|
|
#ifdef FLOATTYPE1
|
|
else
|
|
data[i] = (CTYPE) SCM_REAL_VALUE (val);
|
|
#endif
|
|
}
|
|
return data;
|
|
}
|
|
|
|
switch (SCM_TYP7 (obj))
|
|
{
|
|
case scm_tc7_vector:
|
|
case scm_tc7_wvect:
|
|
n = SCM_VECTOR_LENGTH (obj);
|
|
for (i = 0; i < n; i++)
|
|
{
|
|
val = SCM_VELTS (obj)[i];
|
|
|
|
#if defined (CTYPEMIN) && defined (CTYPEMAX)
|
|
if (SCM_INUMP (val))
|
|
{
|
|
long v = SCM_INUM (val);
|
|
SCM_ASSERT_RANGE (SCM_ARG1, obj, v >= CTYPEMIN && v <= CTYPEMAX);
|
|
}
|
|
else
|
|
#elif defined (FLOATTYPE1)
|
|
if (!SCM_INUMP (val) && !(SCM_BIGP (val) || SCM_REALP (val)))
|
|
#else
|
|
if (!SCM_INUMP (val) && !SCM_BIGP (val))
|
|
#endif
|
|
SCM_WRONG_TYPE_ARG (SCM_ARG1, obj);
|
|
}
|
|
if (data == NULL)
|
|
data = (CTYPE *) malloc (n * sizeof (CTYPE));
|
|
if (data == NULL)
|
|
return NULL;
|
|
for (i = 0; i < n; i++)
|
|
{
|
|
val = SCM_VELTS (obj)[i];
|
|
if (SCM_INUMP (val))
|
|
data[i] = (CTYPE) SCM_INUM (val);
|
|
else if (SCM_BIGP (val))
|
|
data[i] = (CTYPE) scm_num2long (val, SCM_ARG1, FUNC_NAME);
|
|
#ifdef FLOATTYPE1
|
|
else
|
|
data[i] = (CTYPE) SCM_REAL_VALUE (val);
|
|
#endif
|
|
}
|
|
break;
|
|
|
|
#ifdef HAVE_ARRAYS
|
|
case ARRAYTYPE1:
|
|
#ifdef ARRAYTYPE2
|
|
case ARRAYTYPE2:
|
|
#endif
|
|
n = SCM_UVECTOR_LENGTH (obj);
|
|
if (data == NULL)
|
|
data = (CTYPE *) malloc (n * sizeof (CTYPE));
|
|
if (data == NULL)
|
|
return NULL;
|
|
#ifdef FLOATTYPE2
|
|
if (SCM_TYP7 (obj) == ARRAYTYPE2)
|
|
{
|
|
for (i = 0; i < n; i++)
|
|
data[i] = ((FLOATTYPE2 *) SCM_UVECTOR_BASE (obj))[i];
|
|
}
|
|
else
|
|
#endif
|
|
memcpy (data, (CTYPE *) SCM_UVECTOR_BASE (obj), n * sizeof (CTYPE));
|
|
break;
|
|
#endif /* HAVE_ARRAYS */
|
|
|
|
#ifdef STRINGTYPE
|
|
case scm_tc7_string:
|
|
n = SCM_STRING_LENGTH (obj);
|
|
if (data == NULL)
|
|
data = (CTYPE *) malloc (n * sizeof (CTYPE));
|
|
if (data == NULL)
|
|
return NULL;
|
|
memcpy (data, SCM_STRING_CHARS (obj), n * sizeof (CTYPE));
|
|
break;
|
|
#endif /* STRINGTYPE */
|
|
|
|
default:
|
|
SCM_WRONG_TYPE_ARG (SCM_ARG1, obj);
|
|
}
|
|
return data;
|
|
}
|
|
#undef FUNC_NAME
|
|
|
|
|
|
#if HAVE_ARRAYS
|
|
|
|
/* Converts a C array into a uniform vector, returns SCM_UNDEFINED if out
|
|
of memory. */
|
|
#define FUNC_NAME CTYPES2UVECT_FN
|
|
SCM
|
|
CTYPES2UVECT (const CTYPE *data, long n)
|
|
{
|
|
char *v;
|
|
|
|
SCM_ASSERT_RANGE (SCM_ARG2, scm_long2num (n),
|
|
n > 0 && n <= SCM_UVECTOR_MAX_LENGTH);
|
|
v = scm_gc_malloc (sizeof (CTYPE) * n, "vector");
|
|
memcpy (v, data, n * sizeof (CTYPE));
|
|
return scm_alloc_cell (SCM_MAKE_UVECTOR_TAG (n, UVECTTYPE), (scm_t_bits) v);
|
|
}
|
|
#undef FUNC_NAME
|
|
|
|
#ifdef UVECTTYPE2
|
|
#define FUNC_NAME CTYPES2UVECT_FN2
|
|
SCM
|
|
CTYPES2UVECT2 (const unsigned CTYPE *data, long n)
|
|
{
|
|
char *v;
|
|
|
|
SCM_ASSERT_RANGE (SCM_ARG2, scm_long2num (n),
|
|
n > 0 && n <= SCM_UVECTOR_MAX_LENGTH);
|
|
v = scm_gc_malloc (sizeof (unsigned CTYPE) * n, "vector");
|
|
memcpy (v, data, n * sizeof (unsigned CTYPE));
|
|
return scm_alloc_cell (SCM_MAKE_UVECTOR_TAG (n, UVECTTYPE2), (scm_t_bits) v);
|
|
}
|
|
#undef FUNC_NAME
|
|
#endif /* UVECTTYPE2 */
|
|
|
|
#endif /* HAVE_ARRAYS */
|
|
|
|
/* Converts a C array into a vector. */
|
|
#define FUNC_NAME CTYPES2SCM_FN
|
|
SCM
|
|
CTYPES2SCM (const CTYPE *data, long n)
|
|
{
|
|
long i;
|
|
SCM v, *velts;
|
|
|
|
SCM_ASSERT_RANGE (SCM_ARG2, scm_long2num (n),
|
|
n > 0 && n <= SCM_VECTOR_MAX_LENGTH);
|
|
v = scm_c_make_vector (n, SCM_UNSPECIFIED);
|
|
velts = SCM_VELTS (v);
|
|
for (i = 0; i < n; i++)
|
|
#ifdef FLOATTYPE1
|
|
velts[i] = scm_make_real ((double) data[i]);
|
|
#elif defined (CTYPEFIXABLE)
|
|
velts[i] = SCM_MAKINUM (data[i]);
|
|
#else
|
|
velts[i] = (SCM_FIXABLE (data[i]) ? SCM_MAKINUM (data[i]) :
|
|
scm_i_long2big (data[i]));
|
|
#endif
|
|
return v;
|
|
}
|
|
#undef FUNC_NAME
|
|
|
|
/* cleanup of conditionals */
|
|
#undef SCM2CTYPES
|
|
#undef SCM2CTYPES_FN
|
|
#undef CTYPES2SCM
|
|
#undef CTYPES2SCM_FN
|
|
#undef CTYPE
|
|
#undef CTYPES2UVECT
|
|
#undef CTYPES2UVECT_FN
|
|
#ifdef CTYPEFIXABLE
|
|
#undef CTYPEFIXABLE
|
|
#endif
|
|
#undef UVECTTYPE
|
|
#ifdef UVECTTYPE2
|
|
#undef CTYPES2UVECT2
|
|
#undef CTYPES2UVECT_FN2
|
|
#undef UVECTTYPE2
|
|
#endif
|
|
#ifdef CTYPEMIN
|
|
#undef CTYPEMIN
|
|
#endif
|
|
#ifdef CTYPEMAX
|
|
#undef CTYPEMAX
|
|
#endif
|
|
#undef ARRAYTYPE1
|
|
#ifdef ARRAYTYPE2
|
|
#undef ARRAYTYPE2
|
|
#endif
|
|
#ifdef FLOATTYPE1
|
|
#undef FLOATTYPE1
|
|
#endif
|
|
#ifdef FLOATTYPE2
|
|
#undef FLOATTYPE2
|
|
#endif
|
|
#ifdef STRINGTYPE
|
|
#undef STRINGTYPE
|
|
#endif
|
|
|
|
/*
|
|
Local Variables:
|
|
c-file-style: "gnu"
|
|
End:
|
|
*/
|