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)