any->u8vector and family now implemented in Scheme

* module/Makefile.am:
* module/srfi/srfi-4/gnu.scm: New module, for extensions to srfi-4.
  Currently defines the any->FOOvector family.

* libguile/srfi-4.c:
* libguile/srfi-4.i.c: Dispatch scm_any_to_FOOvector calls to the
  scheme-implemented functions in (srfi srfi-4 gnu).

4 files changed, 84 insertions, 34 deletions

diff --git a/libguile/srfi-4.c b/libguile/srfi-4.c
index 117d1e3dd..67894b3e5 100644
--- a/libguile/srfi-4.c
+++ b/libguile/srfi-4.c
@@ -34,6 +34,7 @@
 #include "libguile/generalized-vectors.h"
 #include "libguile/uniform.h"
 #include "libguile/error.h"
+#include "libguile/eval.h"
 #include "libguile/read.h"
 #include "libguile/ports.h"
 #include "libguile/chars.h"
@@ -573,29 +574,6 @@ list_to_uvec (int type, SCM list)
   return uvec;
 }
 
-static SCM
-coerce_to_uvec (int type, SCM obj)
-{
-  if (is_uvec (type, obj))
-    return obj;
-  else if (scm_is_pair (obj))
-    return list_to_uvec (type, obj);
-  else if (scm_is_generalized_vector (obj))
-    {
-      scm_t_array_handle handle;
-      size_t len = scm_c_generalized_vector_length (obj), i;
-      SCM uvec = alloc_uvec (type, len);
-      scm_array_get_handle (uvec, &handle);
-      for (i = 0; i < len; i++)
-	scm_array_handle_set (&handle, i,
-			      scm_c_generalized_vector_ref (obj, i));
-      scm_array_handle_release (&handle);
-      return uvec;
-    }
-  else
-    scm_wrong_type_arg_msg (NULL, 0, obj, "list or generalized vector");
-}
-
 SCM_SYMBOL (scm_sym_a, "a");
 SCM_SYMBOL (scm_sym_b, "b");
 
@@ -851,6 +829,36 @@ SCM_DEFINE (scm_uniform_vector_write, "uniform-vector-write", 1, 3, 0,
 #define CTYPE double
 #include "libguile/srfi-4.i.c"
 
+#define DEFINE_SCHEME_PROXY100(cname, modname, scmname)                 \
+  SCM cname (SCM arg1)                                                  \
+  {                                                                     \
+    static SCM var = SCM_BOOL_F;                                        \
+    if (scm_is_false (var))                                             \
+      var = scm_c_module_lookup (scm_c_resolve_module (modname), scmname); \
+    return scm_call_1 (SCM_VARIABLE_REF (var), arg1);                   \
+  }
+
+#define DEFPROXY100(cname, scmname)               \
+  DEFINE_SCHEME_PROXY100 (cname, MOD, scmname)
+
+#define DEFINE_SRFI_4_GNU_PROXIES(tag)                              \
+  DEFPROXY100 (scm_any_to_##tag##vector, "any->" #tag "vector")
+
+#define MOD "srfi srfi-4 gnu"
+DEFINE_SRFI_4_GNU_PROXIES (u8);
+DEFINE_SRFI_4_GNU_PROXIES (s8);
+DEFINE_SRFI_4_GNU_PROXIES (u16);
+DEFINE_SRFI_4_GNU_PROXIES (s16);
+DEFINE_SRFI_4_GNU_PROXIES (u32);
+DEFINE_SRFI_4_GNU_PROXIES (s32);
+DEFINE_SRFI_4_GNU_PROXIES (u64);
+DEFINE_SRFI_4_GNU_PROXIES (s64);
+DEFINE_SRFI_4_GNU_PROXIES (f32);
+DEFINE_SRFI_4_GNU_PROXIES (f64);
+DEFINE_SRFI_4_GNU_PROXIES (c32);
+DEFINE_SRFI_4_GNU_PROXIES (c64);
+
+
 static scm_i_t_array_ref uvec_reffers[12] = {
   u8ref, s8ref,
   u16ref, s16ref,
diff --git a/libguile/srfi-4.i.c b/libguile/srfi-4.i.c
index 84553c804..cecd6c638 100644
--- a/libguile/srfi-4.i.c
+++ b/libguile/srfi-4.i.c
@@ -121,17 +121,6 @@ SCM_DEFINE (F(scm_list_to_,TAG,vector), "list->"S(TAG)"vector", 1, 0, 0,
 }
 #undef FUNC_NAME
 
-SCM_DEFINE (F(scm_any_to_,TAG,vector), "any->"S(TAG)"vector", 1, 0, 0,
-	    (SCM obj),
-	    "Convert @var{obj}, which can be a list, vector, or\n"
-	    "uniform vector, to a numeric uniform vector of\n"
-	    "type " S(TAG)".")
-#define FUNC_NAME s_F(scm_any_to_,TAG,vector)
-{
-  return coerce_to_uvec (TYPE, obj);
-}
-#undef FUNC_NAME
-
 #ifdef CTYPE
 
 SCM
diff --git a/module/Makefile.am b/module/Makefile.am
index a904a8f8e..0cec6379e 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -199,6 +199,7 @@ SRFI_SOURCES = \
   srfi/srfi-1.scm \
   srfi/srfi-2.scm \
   srfi/srfi-4.scm \
+  srfi/srfi-4/gnu.scm \
   srfi/srfi-6.scm \
   srfi/srfi-8.scm \
   srfi/srfi-9.scm \
diff --git a/module/srfi/srfi-4/gnu.scm b/module/srfi/srfi-4/gnu.scm
new file mode 100644
index 000000000..d3f73b3e9
--- /dev/null
+++ b/module/srfi/srfi-4/gnu.scm
@@ -0,0 +1,52 @@
+;;; Extensions to SRFI-4
+
+;; 	Copyright (C) 2001, 2002, 2004, 2006, 2009 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;; 
+;; This library 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
+;; Lesser General Public License for more details.
+;; 
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Commentary:
+
+;; Extensions to SRFI-4. Fully documented in the Guile Reference Manual.
+
+;;; Code:
+
+(define-module (srfi srfi-4 gnu)
+  #:use-module (srfi srfi-4)
+  #:export (;; Somewhat polymorphic conversions.
+            any->u8vector any->s8vector any->u16vector any->s16vector
+            any->u32vector any->s32vector any->u64vector any->s64vector
+            any->f32vector any->f64vector any->c32vector any->c64vector))
+
+
+(define-macro (define-any->vector . tags)
+  `(begin
+     ,@(map (lambda (tag)
+              `(define (,(symbol-append 'any-> tag 'vector) obj)
+                 (cond ((,(symbol-append tag 'vector?) obj) obj)
+                       ((pair? obj) (,(symbol-append 'list-> tag 'vector) obj))
+                       ((generalized-vector? obj)
+                        (let* ((len (generalized-vector-length obj))
+                               (v (,(symbol-append 'make- tag 'vector) len)))
+                          (let lp ((i 0))
+                            (if (< i len)
+                                (begin
+                                  (,(symbol-append tag 'vector-set!)
+                                   v i (generalized-vector-ref obj i))
+                                  (lp (1+ i)))
+                                v))))
+                       (else (scm-error 'wrong-type-arg #f "" '() (list obj))))))
+            tags)))
+
+(define-any->vector u8 s8 u16 s16 u32 s32 u64 s64 f32 f64 c32 c64)