2002-01-31 Stefan Jahn <stefan@lkcc.org>

* convert.c, convert.h, convert.i.c: New files containing C
        array to Scheme conversion helpers meant to be replacement
        functions for the deprecated gh interface.

        * Makefile.am: Setup rules for new `convert.*' files.

2002-01-31  Stefan Jahn  <stefan@lkcc.org>

        * configure.in: Add -DLIBLTDL_DLL_IMPORT to INCLTDL when using
        `libltdl.dll'.

ChangeLog

@@ -1,3 +1,8 @@
+2002-01-31  Stefan Jahn  <stefan@lkcc.org>
+
+	* configure.in: Add -DLIBLTDL_DLL_IMPORT to INCLTDL when using
+	`libltdl.dll'.
+
 2002-01-28  Stefan Jahn  <stefan@lkcc.org>
 
 	* configure.in (guile_cv_have_uint32_t): Look also in 

configure.in

@@ -251,6 +251,9 @@ if test "$MINGW32" = "yes" ; then
       AC_DEFINE(USE_DLL_IMPORT, 1,
         [Define if you need additional CPP macros on Win32 platforms.])
     fi
+    if test x"$enable_ltdl_install" = x"yes" ; then
+      INCLTDL="-DLIBLTDL_DLL_IMPORT $INCLTDL"
+    fi
 fi
 AC_SUBST(EXTRA_DEFS)
 
@@ -273,6 +276,7 @@ if test "$use_modules" != no; then
     done
   fi
 fi
+
 AC_SUBST(INCLTDL)
 AC_SUBST(LIBLTDL)
 AC_SUBST(DLPREOPEN)

libguile/ChangeLog

@@ -1,3 +1,11 @@
+2002-01-31  Stefan Jahn  <stefan@lkcc.org>
+
+	* convert.c, convert.h, convert.i.c: New files containing C
+	array to Scheme conversion helpers meant to be replacement 
+	functions for the deprecated gh interface.
+
+	* Makefile.am: Setup rules for new `convert.*' files.
+
 2002-01-28  Stefan Jahn  <stefan@lkcc.org>
 
 	* symbols.c (scm_c_symbol2str): New function, replacement for

libguile/Makefile.am

@@ -41,8 +41,8 @@ guile_LDFLAGS = @DLPREOPEN@
 guile_filter_doc_snarfage_SOURCES = c-tokenize.c
 
 libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c	    \
-    chars.c continuations.c debug.c deprecation.c dynl.c dynwind.c	    \
+    chars.c continuations.c convert.c debug.c deprecation.c dynl.c 	    \
-    environments.c eq.c error.c eval.c evalext.c extensions.c		    \
+    dynwind.c environments.c eq.c error.c eval.c evalext.c extensions.c     \
     feature.c fluids.c fports.c						    \
     gc.c gc_os_dep.c gdbint.c gh_data.c gh_eval.c gh_funcs.c gh_init.c	    \
     gh_io.c gh_list.c gh_predicates.c goops.c gsubr.c guardians.c hash.c    \
@@ -117,7 +117,7 @@ install-exec-hook:
 ## Perhaps we can deal with them normally once the merge seems to be
 ## working.
 noinst_HEADERS = coop-threads.c coop-threads.h coop.c \
-    num2integral.i.c num2float.i.c                    \
+    num2integral.i.c num2float.i.c convert.i.c        \
     win32-uname.h win32-dirent.h win32-socket.h
 
 libguile_la_DEPENDENCIES = @LIBLOBJS@
@@ -130,9 +130,9 @@ pkginclude_HEADERS = gh.h
 # These are headers visible as <libguile/mumble.h>.
 modincludedir = $(includedir)/libguile
 modinclude_HEADERS = __scm.h alist.h arbiters.h async.h backtrace.h boolean.h \
-    chars.h continuations.h coop-defs.h debug.h debug-malloc.h deprecation.h  \
+    chars.h continuations.h convert.h coop-defs.h debug.h debug-malloc.h      \
-    dynl.h dynwind.h environments.h eq.h error.h eval.h evalext.h	      \
+    deprecation.h dynl.h dynwind.h environments.h eq.h error.h eval.h         \
-    extensions.h feature.h filesys.h fluids.h fports.h gc.h		      \
+    evalext.h extensions.h feature.h filesys.h fluids.h fports.h gc.h	      \
     gdb_interface.h gdbint.h						      \
     goops.h gsubr.h guardians.h hash.h hashtab.h hooks.h init.h		      \
     inline.h ioext.h							      \

libguile/convert.c

@@ -0,0 +1,146 @@
+/* Copyright (C) 2002 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ * 
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ * 
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING.  If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE.  If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way.  To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.  */
+
+
+
+#include "libguile/_scm.h"
+#include "libguile/validate.h"
+#include "libguile/strings.h"
+#include "libguile/vectors.h"
+#include "libguile/pairs.h"
+#if HAVE_ARRAYS
+# include "libguile/unif.h"
+#endif
+
+#include "libguile/convert.h"
+
+#define CTYPE char
+#define SCM2CTYPES_FN "scm_c_scm2chars"
+#define SCM2CTYPES scm_c_scm2chars
+#define CTYPES2SCM_FN "scm_c_chars2scm"
+#define CTYPES2SCM scm_c_chars2scm
+#define CTYPEFIXABLE
+#define CTYPES2UVECT_FN "scm_c_chars2byvect"
+#define CTYPES2UVECT scm_c_chars2byvect
+#define UVECTTYPE scm_tc7_byvect
+#define CTYPEMIN -128
+#define CTYPEMAX +255
+#define ARRAYTYPE1 scm_tc7_byvect
+#define STRINGTYPE
+#include "convert.i.c"
+
+#define CTYPE short
+#define SCM2CTYPES_FN "scm_c_scm2shorts"
+#define SCM2CTYPES scm_c_scm2shorts
+#define CTYPES2SCM_FN "scm_c_shorts2scm"
+#define CTYPES2SCM scm_c_shorts2scm
+#define CTYPEFIXABLE
+#define CTYPES2UVECT_FN "scm_c_shorts2svect"
+#define CTYPES2UVECT scm_c_shorts2svect
+#define UVECTTYPE scm_tc7_svect
+#define CTYPEMIN -32768
+#define CTYPEMAX +65535
+#define ARRAYTYPE1 scm_tc7_svect
+#include "convert.i.c"
+
+#define CTYPE int
+#define SCM2CTYPES_FN "scm_c_scm2ints"
+#define SCM2CTYPES scm_c_scm2ints
+#define CTYPES2SCM_FN "scm_c_ints2scm"
+#define CTYPES2SCM scm_c_ints2scm
+#define CTYPES2UVECT_FN "scm_c_ints2ivect"
+#define CTYPES2UVECT scm_c_ints2ivect
+#define UVECTTYPE scm_tc7_ivect
+#define CTYPES2UVECT_FN2 "scm_c_uints2uvect"
+#define CTYPES2UVECT2 scm_c_uints2uvect
+#define UVECTTYPE2 scm_tc7_uvect
+#define ARRAYTYPE1 scm_tc7_ivect
+#define ARRAYTYPE2 scm_tc7_uvect
+#include "convert.i.c"
+
+#define CTYPE long
+#define SCM2CTYPES_FN "scm_c_scm2longs"
+#define SCM2CTYPES scm_c_scm2longs
+#define CTYPES2SCM_FN "scm_c_longs2scm"
+#define CTYPES2SCM scm_c_longs2scm
+#define CTYPES2UVECT_FN "scm_c_longs2ivect"
+#define CTYPES2UVECT scm_c_longs2ivect
+#define UVECTTYPE scm_tc7_ivect
+#define CTYPES2UVECT_FN2 "scm_c_ulongs2uvect"
+#define CTYPES2UVECT2 scm_c_ulongs2uvect
+#define UVECTTYPE2 scm_tc7_uvect
+#define ARRAYTYPE1 scm_tc7_ivect
+#define ARRAYTYPE2 scm_tc7_uvect
+#include "convert.i.c"
+
+#define CTYPE float
+#define SCM2CTYPES_FN "scm_c_scm2floats"
+#define SCM2CTYPES scm_c_scm2floats
+#define CTYPES2SCM_FN "scm_c_floats2scm"
+#define CTYPES2SCM scm_c_floats2scm
+#define CTYPES2UVECT_FN "scm_c_floats2fvect"
+#define CTYPES2UVECT scm_c_floats2fvect
+#define UVECTTYPE scm_tc7_fvect
+#define ARRAYTYPE1 scm_tc7_fvect
+#define ARRAYTYPE2 scm_tc7_dvect
+#define FLOATTYPE1 float
+#define FLOATTYPE2 double
+#include "convert.i.c"
+
+#define CTYPE double
+#define SCM2CTYPES_FN "scm_c_scm2doubles"
+#define SCM2CTYPES scm_c_scm2doubles
+#define CTYPES2SCM_FN "scm_c_doubles2scm"
+#define CTYPES2SCM scm_c_doubles2scm
+#define CTYPES2UVECT_FN "scm_c_doubles2dvect"
+#define CTYPES2UVECT scm_c_doubles2dvect
+#define UVECTTYPE scm_tc7_dvect
+#define ARRAYTYPE1 scm_tc7_dvect
+#define ARRAYTYPE2 scm_tc7_fvect
+#define FLOATTYPE1 double
+#define FLOATTYPE2 float
+#include "convert.i.c"
+
+/*
+  Local Variables:
+  c-file-style: "gnu"
+  End:
+*/

libguile/convert.h

@@ -0,0 +1,76 @@
+/* classes: h_files */
+
+#ifndef SCM_CONVERT_H
+#define SCM_CONVERT_H
+
+/* Copyright (C) 2002 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING.  If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE.  If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way.  To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.  */
+
+
+
+#include "libguile/__scm.h"
+
+SCM_API char *scm_c_scm2chars (SCM obj, char *dst);
+SCM_API short *scm_c_scm2shorts (SCM obj, short *dst);
+SCM_API int *scm_c_scm2ints (SCM obj, int *dst);
+SCM_API long *scm_c_scm2longs (SCM obj, long *dst);
+SCM_API float *scm_c_scm2floats (SCM obj, float *dst);
+SCM_API double *scm_c_scm2doubles (SCM obj, double *dst);
+
+SCM_API SCM scm_c_chars2scm (const char *src, long n);
+SCM_API SCM scm_c_shorts2scm (const short *src, long n);
+SCM_API SCM scm_c_ints2scm (const int *src, long n);
+SCM_API SCM scm_c_longs2scm (const long *src, long n);
+SCM_API SCM scm_c_floats2scm (const float *src, long n);
+SCM_API SCM scm_c_doubles2scm (const double *src, long n);
+
+#if HAVE_ARRAYS
+SCM_API SCM scm_c_chars2byvect (const char *src, long n);
+SCM_API SCM scm_c_shorts2svect (const short *src, long n);
+SCM_API SCM scm_c_ints2ivect (const int *src, long n);
+SCM_API SCM scm_c_uints2uvect (const unsigned int *src, long n);
+SCM_API SCM scm_c_longs2ivect (const long *src, long n);
+SCM_API SCM scm_c_ulongs2uvect (const unsigned long *src, long n);
+SCM_API SCM scm_c_floats2fvect (const float *src, long n);
+SCM_API SCM scm_c_doubles2dvect (const double *src, long n);
+#endif
+
+#endif /* SCM_CONVERT_H */

libguile/convert.i.c

@@ -0,0 +1,247 @@
+/* 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);
+  if ((v = (char *) SCM_MUST_MALLOC_TYPE_NUM (CTYPE, n)) == NULL)
+    return SCM_UNDEFINED;
+  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);
+  if ((v = (char *) SCM_MUST_MALLOC_TYPE_NUM (unsigned CTYPE, n)) == NULL)
+    return SCM_UNDEFINED;
+  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:
+*/