From f3a2c4cfe6bae23bf43a2d083b65258d2ab3c586 Mon Sep 17 00:00:00 2001
From: Mikael Djurfeldt <djurfeldt@nada.kth.se>
Date: Tue, 20 Jan 1998 17:57:01 +0000
Subject: [PATCH] * gh.h, gh_data.c (gh_doubles2scm, gh_doubles2dvect,
 gh_doubles2scm): New functions.

---
 libguile/ChangeLog |  5 +++
 libguile/gh.h      |  5 +++
 libguile/gh_data.c | 83 ++++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 93 insertions(+)

diff --git a/libguile/ChangeLog b/libguile/ChangeLog
index d5f146209..6ca68288b 100644
--- a/libguile/ChangeLog
+++ b/libguile/ChangeLog
@@ -1,3 +1,8 @@
+1998-01-20  Mikael Djurfeldt  <mdj@mdj.nada.kth.se>
+
+	* gh.h, gh_data.c (gh_doubles2scm, gh_doubles2dvect,
+	gh_doubles2scm): New functions.
+
 1998-01-15  Mark Galassi  <rosalia@nis.lanl.gov>
 
 	* gh_eval.c (gh_eval_str): cleanup -- threw out the old
diff --git a/libguile/gh.h b/libguile/gh.h
index 5a6485f88..d5d3cf9a8 100644
--- a/libguile/gh.h
+++ b/libguile/gh.h
@@ -113,6 +113,10 @@ SCM gh_str2scm(char *s, int len);
 SCM gh_str02scm(char *s);
 void gh_set_substr(char *src, SCM dst, int start, int len);
 SCM gh_symbol2scm(char *symbol_str);
+SCM gh_doubles2scm(double *d, int n);
+#ifdef SCM_FLOATS
+SCM gh_doubles2dvect(double *d, int n);
+#endif
 
 
 /* Scheme to C conversion */
@@ -125,6 +129,7 @@ double gh_scm2double(SCM obj);
 char *gh_scm2newstr(SCM str, int *lenp);
 void gh_get_substr(SCM src, char *dst, int start, int len);
 char *gh_symbol2newstr(SCM sym, int *lenp);
+double *gh_scm2doubles(SCM vector);
 
 /* type predicates: tell you if an SCM object has a given type */
 int gh_boolean_p(SCM val);
diff --git a/libguile/gh_data.c b/libguile/gh_data.c
index b6bf54c9a..f2866e39a 100644
--- a/libguile/gh_data.c
+++ b/libguile/gh_data.c
@@ -122,6 +122,37 @@ gh_symbol2scm (char *symbol_str)
   return SCM_CAR (scm_intern (symbol_str, strlen (symbol_str)));
 }
 
+SCM
+gh_doubles2scm (double *d, int n)
+{
+  SCM ans;
+  SCM *m = (SCM*) scm_must_malloc (n * sizeof (SCM), "vector");
+  int i;
+  for (i = 0; i < n; ++i)
+    m[i] = scm_makdbl (d[i], 0.0);
+  SCM_NEWCELL (ans);
+  SCM_DEFER_INTS;
+  SCM_SETCHARS (ans, m);
+  SCM_SETLENGTH (ans, n, scm_tc7_vector);
+  SCM_ALLOW_INTS;
+  return ans;
+}
+
+#ifdef SCM_FLOATS
+SCM
+gh_doubles2dvect (double *d, int n)
+{
+  SCM ans;
+  char *m = scm_must_malloc (n * sizeof (double), "vector");
+  memcpy (m, d, n * sizeof (double));
+  SCM_NEWCELL (ans);
+  SCM_DEFER_INTS;
+  SCM_SETCHARS (ans, m);
+  SCM_SETLENGTH (ans, n, scm_tc7_dvect);
+  SCM_ALLOW_INTS;
+  return ans;
+}
+#endif
 
 /* data conversion scheme->C */
 int 
@@ -156,6 +187,58 @@ gh_scm2char (SCM obj)
   return SCM_ICHR (obj);
 }
 
+/* Convert a vector, weak vector or uniform vector into a malloced
+   array of doubles. */
+double*
+gh_scm2doubles (SCM obj)
+{
+  int i, n;
+  double *m;
+  SCM val;
+  if (!SCM_NIMP (obj))
+    scm_wrong_type_arg (0, 0, obj);
+  switch (SCM_TYP7 (obj))
+    {
+    case scm_tc7_vector:
+    case scm_tc7_wvect:
+      n = SCM_LENGTH (obj);
+      m = (double*) malloc (n * sizeof (double));
+      for (i = 0; i < n; ++i)
+	{
+	  val = SCM_VELTS (obj)[i];
+	  if (SCM_INUMP (val))
+	    m[i] = SCM_INUM (val);
+	  else if (SCM_NIMP (val) && SCM_REALP (val))
+	    m[i] = SCM_REALPART (val);
+	  else
+	    {
+	      free (m);
+	      scm_wrong_type_arg (0, 0, val);
+	    }
+	}
+      break;
+#ifdef SCM_FLOATS
+#ifdef SCM_SINGLES
+    case scm_tc7_fvect:
+      n = SCM_LENGTH (obj);
+      m = (double*) malloc (n * sizeof (double));
+      for (i = 0; i < n; ++i)
+	m[i] = ((float*) SCM_VELTS (obj))[i];
+      break;
+#endif
+    case scm_tc7_dvect:
+      n = SCM_LENGTH (obj);
+      m = (double*) malloc (n * sizeof (double));
+      for (i = 0; i < n; ++i)
+	m[i] = ((double*) SCM_VELTS (obj))[i];
+      break;
+#endif
+    default:
+      scm_wrong_type_arg (0, 0, obj);
+    }
+  return m;
+}
+
 /* string conversions between C and Scheme */
 
 /* gh_scm2newstr() -- Given a Scheme string STR, return a pointer to a