From: Daniel Llorens <daniel.llorens@bluewin.ch>
To: guile-devel <guile-devel@gnu.org>
Subject: Re: vectors are something else
Date: Sat, 13 Apr 2013 02:40:55 +0200 [thread overview]
Message-ID: <8A58516D-20EE-4173-A5E7-DD5C8DB525E3@bluewin.ch> (raw)
In-Reply-To: <1188A28F-42A7-443A-BE25-EBF2CB301B04@bluewin.ch>
[-- Attachment #1: Type: text/plain, Size: 4016 bytes --]
Hello,
I've written this patch set while trying to understand how arrays are implemented in Guile. It does the following things.
1. array objects (most things produced by the array interface) are never vector? or uniform-vector?
Therefore, basic functions such as vector-ref, vector-length, etc. will fail with a type error on these objects. This is the behavior of bytevector-; after the patches each of these sets gives the same result (#t, #f, type error, type error)
(import (rnrs bytevectors))
(define (every-two a) (make-shared-array a (lambda (i) (list (* i 2))) 2))
(bitvector? (make-typed-array 'b #t 2))
(bitvector? (make-typed-array 'b #t '(1 2)))
(bitvector-ref (make-typed-array 'b #t '(1 2)))
(bitvector-ref (every-two (make-typed-array 'b #t 4)) 0) <--------- except for this one
(bytevector? (make-typed-array 's8 0 2))
(bytevector? (make-typed-array 's8 0 '(1 2)))
(bytevector-s8-ref (make-typed-array 's8 0 '(1 2)) 0)
(bytevector-s8-ref (every-two (make-typed-array 's8 0 4)) 0)
(s8vector? (make-typed-array 's8 0 2))
(s8vector? (make-typed-array 's8 0 '(1 2)))
(s8vector-ref (make-typed-array 's8 0 '(1 2)) 0)
(s8vector-ref (every-two (make-typed-array 's8 0 4)) 0)
(uniform-vector? (make-typed-array 's8 0 2))
(uniform-vector? (make-typed-array 's8 0 '(1 2)))
(uniform-vector-ref (make-typed-array 's8 0 '(1 2)) 0)
(uniform-vector-ref (every-two (make-typed-array 's8 0 4)) 0)
(vector? (make-typed-array #t 0 2))
(vector? (make-typed-array #t 0 '(1 2)))
(vector-ref (make-typed-array #t 0 '(1 2)) 0)
(vector-ref (every-two (make-typed-array #t 0 4)) 0)
After the discussion with Daniel Hartwig (not in this patchset), every fourth case would work as with bitvector. That's the behavior of stable-2.0 except for bytevector-s8-ref (& friends). In stable-2.0, the offset-1 cases are all broken except for bytevector-s8-ref (& friends).
2. Any object obtained from SCM_I_ARRAY_V is assumed to have base 0, inc 1, lbnd 0. This is true of all such objects (bitvector, bytevector, string and vector). This removes a bunch of redundant (and sometimes buggy) index computation in array-map.c, arrays.c, etc.
3. scm_array_get_handle places pointers to the underlying vector implementation in the array handle, so that is called directly instead of going through array_handle_ref and array_handle_set. This results in minor speedups of array-copy! and array-fill! and the following speedup of two-arg array-map!:
(define a (make-array 0. 1000000 10))
(define b (make-array 0. 1000000 10))
(define c (make-array *unspecified* 1000000 10))
before:
scheme@(guile-user)> ,time (array-map! c (lambda (a b) (+ a b)) a b)
;; 3.796000s real time, 3.780000s run time. 0.520000s spent in GC.
after:
scheme@(guile-user)> ,time (array-map! c (lambda (a b) (+ a b)) a b)
;; 2.789000s real time, 2.800000s run time. 0.310000s spent in GC.
These timings are still terrible though. The main benefit is that the impl-> call sequence is now easier to follow.
4. vectors are identified with 'simple vectors', so uses of simple-vector-ref and such have been replaced by vector-ref and such.
5. remove uses of most generalized-vector functions.
5. extra tests, bits and pieces, such as transpose-array now works with rank 0 arrays.
All tests in stable-2.0 pass as they were.
I've seen at least a new bug: this fails at the repl after, it succeeded before.
scheme@(guile-user)> #1@1(1 2 3)
While compiling expression:
ERROR: Wrong type (expecting vector): #1@1(1 2 3)
However, this works fine:
scheme@(guile-user)> (call-with-input-string "#1@1(1 2 3)" read)
$3 = #1@1(1 2 3)
I haven't tried to debug this, but there're problems with the reader even in stable-2.0:
#b(#t #t) => error
#1b(#t #t) => ok
#b@1(#t #t) => error
#1b@1(#t #t) => ok
my understanding is that all of these should work, and the printer actually produces the versions it doesn't read.
Anyway, the patches.
Regards
Daniel
[-- Attachment #2: 0001-Inline-generalized-vector-calls-in-array_handle_ref-.patch --]
[-- Type: application/octet-stream, Size: 1605 bytes --]
From 2c3a0a571e8e337e8b766da6e35d6285ae9457d8 Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Sun, 7 Apr 2013 16:15:38 +0200
Subject: [PATCH 01/22] Inline generalized-vector calls in array_handle_ref/set
* libguile/arrays.c: (array-handle-ref, array-handle-set): Ditto.
---
libguile/arrays.c | 18 ++++++++++++++----
1 file changed, 14 insertions(+), 4 deletions(-)
diff --git a/libguile/arrays.c b/libguile/arrays.c
index 1eb10b9..350da44 100644
--- a/libguile/arrays.c
+++ b/libguile/arrays.c
@@ -816,15 +816,25 @@ scm_i_print_array (SCM array, SCM port, scm_print_state *pstate)
}
static SCM
-array_handle_ref (scm_t_array_handle *h, size_t pos)
+array_handle_ref (scm_t_array_handle *hh, size_t pos)
{
- return scm_c_generalized_vector_ref (SCM_I_ARRAY_V (h->array), pos);
+ scm_t_array_handle h;
+ SCM ret;
+ scm_array_get_handle (SCM_I_ARRAY_V (hh->array), &h);
+ pos = h.base + h.dims[0].lbnd + pos * h.dims[0].inc;
+ ret = h.impl->vref (&h, pos);
+ scm_array_handle_release (&h);
+ return ret;
}
static void
-array_handle_set (scm_t_array_handle *h, size_t pos, SCM val)
+array_handle_set (scm_t_array_handle *hh, size_t pos, SCM val)
{
- scm_c_generalized_vector_set_x (SCM_I_ARRAY_V (h->array), pos, val);
+ scm_t_array_handle h;
+ scm_array_get_handle (SCM_I_ARRAY_V (hh->array), &h);
+ pos = h.base + h.dims[0].lbnd + pos * h.dims[0].inc;
+ h.impl->vset (&h, pos, val);
+ scm_array_handle_release (&h);
}
/* FIXME: should be handle for vect? maybe not, because of dims */
--
1.8.2
[-- Attachment #3: 0002-Don-t-use-generalized-vector-functions-in-uniform.c.patch --]
[-- Type: application/octet-stream, Size: 5488 bytes --]
From 8e9f0507df78fa13bc5c556bd2bebf7d93d78d06 Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Mon, 8 Apr 2013 13:13:21 +0200
Subject: [PATCH 02/22] Don't use generalized-vector functions in uniform.c
* libguile/uniform.c
- (scm_is_uniform_vector): replace scm_is_generalized_vector and
scm_generalized_vector_get_handle by scm_is_array and manual rank check.
- (scm_c_uniform_vector_length): inline length computation. This
removes a redundant rank check.
- (scm_c_uniform_vector_ref): inline impl->vref use. This removes
a redundant rank check.
- (scm_c_uniform_vector_set): inline impl->vset use. This removes
a redundant rank check.
- (scm_uniform_vector_writable_elements): replace
scm_generalized_vector_get_handle by scm_array_get_handle.
* test-suite/test/arrays.test
- rename uniform-vector-ref block to uniform-vector.
- exercise uniform-vector-length and shared arrays remaining uniform.
---
libguile/uniform.c | 41 +++++++++++++++++++++++++++++++----------
test-suite/tests/arrays.test | 24 ++++++++++++++++++++----
2 files changed, 51 insertions(+), 14 deletions(-)
diff --git a/libguile/uniform.c b/libguile/uniform.c
index a58242d..26193a3 100644
--- a/libguile/uniform.c
+++ b/libguile/uniform.c
@@ -87,10 +87,11 @@ scm_is_uniform_vector (SCM obj)
scm_t_array_handle h;
int ret = 0;
- if (scm_is_generalized_vector (obj))
+ if (scm_is_array (obj))
{
- scm_generalized_vector_get_handle (obj, &h);
- ret = SCM_ARRAY_ELEMENT_TYPE_IS_UNBOXED (h.element_type);
+ scm_array_get_handle (obj, &h);
+ ret = 1 == scm_array_handle_rank (&h)
+ && SCM_ARRAY_ELEMENT_TYPE_IS_UNBOXED (h.element_type);
scm_array_handle_release (&h);
}
return ret;
@@ -99,11 +100,16 @@ scm_is_uniform_vector (SCM obj)
size_t
scm_c_uniform_vector_length (SCM uvec)
{
+ scm_t_array_handle h;
+ size_t ret;
if (!scm_is_uniform_vector (uvec))
scm_wrong_type_arg_msg ("uniform-vector-length", 1, uvec,
"uniform vector");
- return scm_c_generalized_vector_length (uvec);
+ scm_array_get_handle (uvec, &h);
+ ret = h.dims[0].ubnd - h.dims[0].lbnd + 1;
+ scm_array_handle_release (&h);
+ return ret;
}
SCM_DEFINE (scm_uniform_vector_p, "uniform-vector?", 1, 0, 0,
@@ -150,11 +156,20 @@ SCM_DEFINE (scm_uniform_vector_element_size, "uniform-vector-element-size", 1, 0
#undef FUNC_NAME
SCM
-scm_c_uniform_vector_ref (SCM v, size_t idx)
+scm_c_uniform_vector_ref (SCM v, size_t pos)
{
+ scm_t_array_handle h;
+ SCM ret;
+
if (!scm_is_uniform_vector (v))
scm_wrong_type_arg_msg (NULL, 0, v, "uniform vector");
- return scm_c_generalized_vector_ref (v, idx);
+
+ scm_array_get_handle (v, &h);
+ pos = h.base + h.dims[0].lbnd + pos * h.dims[0].inc;
+ ret = h.impl->vref (&h, pos);
+ scm_array_handle_release (&h);
+ return ret;
+
}
SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0,
@@ -168,11 +183,17 @@ SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0,
#undef FUNC_NAME
void
-scm_c_uniform_vector_set_x (SCM v, size_t idx, SCM val)
+scm_c_uniform_vector_set_x (SCM v, size_t pos, SCM val)
{
+ scm_t_array_handle h;
+
if (!scm_is_uniform_vector (v))
scm_wrong_type_arg_msg (NULL, 0, v, "uniform vector");
- scm_c_generalized_vector_set_x (v, idx, val);
+
+ scm_array_get_handle (v, &h);
+ pos = h.base + h.dims[0].lbnd + pos * h.dims[0].inc;
+ h.impl->vset (&h, pos, val);
+ scm_array_handle_release (&h);
}
SCM_DEFINE (scm_uniform_vector_set_x, "uniform-vector-set!", 3, 0, 0,
@@ -206,12 +227,12 @@ scm_uniform_vector_elements (SCM uvec,
}
void *
-scm_uniform_vector_writable_elements (SCM uvec,
+scm_uniform_vector_writable_elements (SCM uvec,
scm_t_array_handle *h,
size_t *lenp, ssize_t *incp)
{
void *ret;
- scm_generalized_vector_get_handle (uvec, h);
+ scm_array_get_handle (uvec, h);
/* FIXME nonlocal exit */
ret = scm_array_handle_uniform_writable_elements (h);
if (lenp)
diff --git a/test-suite/tests/arrays.test b/test-suite/tests/arrays.test
index 0b3d57c..9d86371 100644
--- a/test-suite/tests/arrays.test
+++ b/test-suite/tests/arrays.test
@@ -574,12 +574,12 @@
(eqv? 8 (array-ref s2 2))))))
;;;
-;;; uniform-vector-ref
+;;; uniform-vector
;;;
-(with-test-prefix "uniform-vector-ref"
+(with-test-prefix "uniform-vector"
- (with-test-prefix "byte"
+ (with-test-prefix "uniform-vector-ref byte"
(let ((a (make-s8vector 1)))
@@ -594,7 +594,23 @@
(pass-if "-128"
(begin
(array-set! a -128 0)
- (= -128 (uniform-vector-ref a 0)))))))
+ (= -128 (uniform-vector-ref a 0))))))
+
+ (with-test-prefix "shared with rank 1 remain uniform vectors"
+
+ (let ((a #f64(1 2 3 4)))
+
+ (pass-if "change offset"
+ (let ((b (make-shared-array a (lambda (i) (list (+ i 1))) 3)))
+ (and (uniform-vector? b)
+ (= 3 (uniform-vector-length b))
+ (array-equal? b #f64(2 3 4)))))
+
+ (pass-if "change stride"
+ (let ((c (make-shared-array a (lambda (i) (list (* i 2))) 2)))
+ (and (uniform-vector? c)
+ (= 2 (uniform-vector-length c))
+ (array-equal? c #f64(1 3))))))))
;;;
;;; syntax
--
1.8.2
[-- Attachment #4: 0003-Don-t-use-generalized-vector-in-array-map.c-I.patch --]
[-- Type: application/octet-stream, Size: 6144 bytes --]
From 9fe3e2aa6d515699e3f96b38f65b1741c229e90b Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Mon, 8 Apr 2013 13:34:41 +0200
Subject: [PATCH 03/22] Don't use generalized-vector in array-map.c (I)
* array-map.c: (AREF, ASET): new internal functions replace
scm_c_generalized_vector_ref/set. These remove a redundant check for
rank in the generalized_vector set.
---
libguile/array-map.c | 58 +++++++++++++++++++++++++++++++++-------------------
1 file changed, 37 insertions(+), 21 deletions(-)
diff --git a/libguile/array-map.c b/libguile/array-map.c
index 1c443ac..2aa4d56 100644
--- a/libguile/array-map.c
+++ b/libguile/array-map.c
@@ -48,9 +48,28 @@
/* The WHAT argument for `scm_gc_malloc ()' et al. */
static const char indices_gc_hint[] = "array-indices";
+/* FIXME Versions of array_handle_ref/set in arrays.c */
+static SCM
+AREF (SCM v, size_t pos)
+{
+ scm_t_array_handle h;
+ SCM ret;
+ scm_array_get_handle (v, &h);
+ pos = h.base + h.dims[0].lbnd + pos * h.dims[0].inc;
+ ret = h.impl->vref (&h, pos);
+ scm_array_handle_release (&h);
+ return ret;
+}
-#define GVREF scm_c_generalized_vector_ref
-#define GVSET scm_c_generalized_vector_set_x
+static void
+ASET (SCM v, size_t pos, SCM val)
+{
+ scm_t_array_handle h;
+ scm_array_get_handle (v, &h);
+ pos = h.base + h.dims[0].lbnd + pos * h.dims[0].inc;
+ h.impl->vset (&h, pos, val);
+ scm_array_handle_release (&h);
+}
static unsigned long
cind (SCM ra, long *ve)
@@ -407,7 +426,7 @@ scm_array_fill_int (SCM ra, SCM fill, SCM ignore SCM_UNUSED)
ra = SCM_I_ARRAY_V (ra);
for (i = base; n--; i += inc)
- GVSET (ra, i, fill);
+ ASET (ra, i, fill);
return 1;
}
@@ -437,7 +456,7 @@ scm_ra_eqp (SCM ra0, SCM ras)
{
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
if (scm_is_true (scm_array_handle_ref (&ra0_handle, i0)))
- if (!scm_is_eq (GVREF (ra1, i1), GVREF (ra2, i2)))
+ if (!scm_is_eq (AREF (ra1, i1), AREF (ra2, i2)))
scm_array_handle_set (&ra0_handle, i0, SCM_BOOL_F);
}
@@ -470,8 +489,8 @@ ra_compare (SCM ra0, SCM ra1, SCM ra2, int opt)
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
if (scm_is_true (scm_array_handle_ref (&ra0_handle, i0)))
if (opt ?
- scm_is_true (scm_less_p (GVREF (ra1, i1), GVREF (ra2, i2))) :
- scm_is_false (scm_less_p (GVREF (ra1, i1), GVREF (ra2, i2))))
+ scm_is_true (scm_less_p (AREF (ra1, i1), AREF (ra2, i2))) :
+ scm_is_false (scm_less_p (AREF (ra1, i1), AREF (ra2, i2))))
scm_array_handle_set (&ra0_handle, i0, SCM_BOOL_F);
}
@@ -527,7 +546,7 @@ scm_ra_sum (SCM ra0, SCM ras)
default:
{
for (; n-- > 0; i0 += inc0, i1 += inc1)
- GVSET (ra0, i0, scm_sum (GVREF(ra0, i0), GVREF(ra1, i1)));
+ ASET (ra0, i0, scm_sum (AREF(ra0, i0), AREF(ra1, i1)));
break;
}
}
@@ -551,7 +570,7 @@ scm_ra_difference (SCM ra0, SCM ras)
default:
{
for (; n-- > 0; i0 += inc0)
- GVSET (ra0, i0, scm_difference (GVREF(ra0, i0), SCM_UNDEFINED));
+ ASET (ra0, i0, scm_difference (AREF(ra0, i0), SCM_UNDEFINED));
break;
}
}
@@ -567,8 +586,7 @@ scm_ra_difference (SCM ra0, SCM ras)
default:
{
for (; n-- > 0; i0 += inc0, i1 += inc1)
- GVSET (ra0, i0, scm_difference (GVREF (ra0, i0),
- GVREF (ra1, i1)));
+ ASET (ra0, i0, scm_difference (AREF (ra0, i0), AREF (ra1, i1)));
break;
}
}
@@ -596,8 +614,7 @@ scm_ra_product (SCM ra0, SCM ras)
default:
{
for (; n-- > 0; i0 += inc0, i1 += inc1)
- GVSET (ra0, i0, scm_product (GVREF (ra0, i0),
- GVREF (ra1, i1)));
+ ASET (ra0, i0, scm_product (AREF (ra0, i0), AREF (ra1, i1)));
}
}
}
@@ -619,7 +636,7 @@ scm_ra_divide (SCM ra0, SCM ras)
default:
{
for (; n-- > 0; i0 += inc0)
- GVSET (ra0, i0, scm_divide (GVREF (ra0, i0), SCM_UNDEFINED));
+ ASET (ra0, i0, scm_divide (AREF (ra0, i0), SCM_UNDEFINED));
break;
}
}
@@ -636,9 +653,8 @@ scm_ra_divide (SCM ra0, SCM ras)
{
for (; n-- > 0; i0 += inc0, i1 += inc1)
{
- SCM res = scm_divide (GVREF (ra0, i0),
- GVREF (ra1, i1));
- GVSET (ra0, i0, res);
+ SCM res = scm_divide (AREF (ra0, i0), AREF (ra1, i1));
+ ASET (ra0, i0, res);
}
break;
}
@@ -693,7 +709,7 @@ ramap (SCM ra0, SCM proc, SCM ras)
SCM args = SCM_EOL;
unsigned long k;
for (k = scm_c_vector_length (ras); k--;)
- args = scm_cons (GVREF (scm_c_vector_ref (ras, k), i), args);
+ args = scm_cons (AREF (scm_c_vector_ref (ras, k), i), args);
h0.impl->vset (&h0, i0, scm_apply_1 (proc, h1.impl->vref (&h1, i1), args));
}
}
@@ -753,7 +769,7 @@ rafe (SCM ra0, SCM proc, SCM ras)
SCM args = SCM_EOL;
unsigned long k;
for (k = scm_c_vector_length (ras); k--;)
- args = scm_cons (GVREF (scm_c_vector_ref (ras, k), i), args);
+ args = scm_cons (AREF (scm_c_vector_ref (ras, k), i), args);
scm_apply_1 (proc, h0.impl->vref (&h0, i0), args);
}
}
@@ -823,7 +839,7 @@ SCM_DEFINE (scm_array_index_map_x, "array-index-map!", 2, 0, 0,
{
for (j = kmax + 1, args = SCM_EOL; j--;)
args = scm_cons (scm_from_long (vinds[j]), args);
- GVSET (SCM_I_ARRAY_V (ra), i, scm_apply_0 (proc, args));
+ ASET (SCM_I_ARRAY_V (ra), i, scm_apply_0 (proc, args));
i += SCM_I_ARRAY_DIMS (ra)[k].inc;
}
k--;
@@ -846,10 +862,10 @@ SCM_DEFINE (scm_array_index_map_x, "array-index-map!", 2, 0, 0,
{
size_t length = scm_c_generalized_vector_length (ra);
for (i = 0; i < length; i++)
- GVSET (ra, i, scm_call_1 (proc, scm_from_ulong (i)));
+ ASET (ra, i, scm_call_1 (proc, scm_from_ulong (i)));
return SCM_UNSPECIFIED;
}
- else
+ else
scm_wrong_type_arg_msg (NULL, 0, ra, "array");
}
#undef FUNC_NAME
--
1.8.2
[-- Attachment #5: 0004-Don-t-use-generalized-vector-in-array-map.c-II.patch --]
[-- Type: application/octet-stream, Size: 4023 bytes --]
From b5bb76841000ff10dfca0d6e5b02b05817eaa9c6 Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Tue, 9 Apr 2013 16:57:16 +0200
Subject: [PATCH 04/22] Don't use generalized-vector in array-map.c (II)
* libguile/array-map.c
- replace scm_is_generalized_vector by scm_is_array && !SCM_I_ARRAY_P.
- replace scm_c_generalized_vector_length by scm_c_array_length.
- remove header.
---
libguile/array-map.c | 49 ++++++++++++++++++++++++-------------------------
1 file changed, 24 insertions(+), 25 deletions(-)
diff --git a/libguile/array-map.c b/libguile/array-map.c
index 2aa4d56..8484d8c 100644
--- a/libguile/array-map.c
+++ b/libguile/array-map.c
@@ -39,7 +39,6 @@
#include "libguile/bitvectors.h"
#include "libguile/srfi-4.h"
#include "libguile/generalized-arrays.h"
-#include "libguile/generalized-vectors.h"
#include "libguile/validate.h"
#include "libguile/array-map.h"
@@ -104,34 +103,34 @@ scm_ra_matchp (SCM ra0, SCM ras)
int i, ndim = 1;
int exact = 2 /* 4 */ ; /* Don't care about values >2 (yet?) */
- if (scm_is_generalized_vector (ra0))
+ if (!scm_is_array (ra0))
+ return 0;
+ else if (!SCM_I_ARRAYP (ra0))
{
s0->lbnd = 0;
s0->inc = 1;
- s0->ubnd = scm_c_generalized_vector_length (ra0) - 1;
+ s0->ubnd = scm_c_array_length (ra0) - 1;
}
- else if (SCM_I_ARRAYP (ra0))
+ else
{
ndim = SCM_I_ARRAY_NDIM (ra0);
s0 = SCM_I_ARRAY_DIMS (ra0);
bas0 = SCM_I_ARRAY_BASE (ra0);
}
- else
- return 0;
while (SCM_NIMP (ras))
{
ra1 = SCM_CAR (ras);
-
- if (scm_is_generalized_vector (ra1))
+
+ if (!SCM_I_ARRAYP (ra1))
{
size_t length;
-
+
if (1 != ndim)
return 0;
-
- length = scm_c_generalized_vector_length (ra1);
-
+
+ length = scm_c_array_length (ra1);
+
switch (exact)
{
case 4:
@@ -149,7 +148,7 @@ scm_ra_matchp (SCM ra0, SCM ras)
return 0;
}
}
- else if (SCM_I_ARRAYP (ra1) && ndim == SCM_I_ARRAY_NDIM (ra1))
+ else if (ndim == SCM_I_ARRAY_NDIM (ra1))
{
s1 = SCM_I_ARRAY_DIMS (ra1);
if (bas0 != SCM_I_ARRAY_BASE (ra1))
@@ -213,7 +212,7 @@ scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
if (SCM_IMP (vra0)) goto gencase;
if (!SCM_I_ARRAYP (vra0))
{
- size_t length = scm_c_generalized_vector_length (vra0);
+ size_t length = scm_c_array_length (vra0);
vra1 = scm_i_make_array (1);
SCM_I_ARRAY_BASE (vra1) = 0;
SCM_I_ARRAY_DIMS (vra1)->lbnd = 0;
@@ -271,7 +270,7 @@ scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
}
else
{
- size_t length = scm_c_generalized_vector_length (ra0);
+ size_t length = scm_c_array_length (ra0);
kmax = 0;
SCM_I_ARRAY_DIMS (vra0)->lbnd = 0;
SCM_I_ARRAY_DIMS (vra0)->ubnd = length - 1;
@@ -814,7 +813,16 @@ SCM_DEFINE (scm_array_index_map_x, "array-index-map!", 2, 0, 0,
unsigned long i;
SCM_VALIDATE_PROC (2, proc);
- if (SCM_I_ARRAYP (ra))
+ if (!scm_is_array (ra))
+ scm_wrong_type_arg_msg (NULL, 0, ra, "array");
+ else if (!SCM_I_ARRAYP (ra))
+ {
+ size_t length = scm_c_array_length (ra);
+ for (i = 0; i < length; ++i)
+ ASET (ra, i, scm_call_1 (proc, scm_from_ulong (i)));
+ return SCM_UNSPECIFIED;
+ }
+ else
{
SCM args = SCM_EOL;
int j, k, kmax = SCM_I_ARRAY_NDIM (ra) - 1;
@@ -858,15 +866,6 @@ SCM_DEFINE (scm_array_index_map_x, "array-index-map!", 2, 0, 0,
return SCM_UNSPECIFIED;
}
- else if (scm_is_generalized_vector (ra))
- {
- size_t length = scm_c_generalized_vector_length (ra);
- for (i = 0; i < length; i++)
- ASET (ra, i, scm_call_1 (proc, scm_from_ulong (i)));
- return SCM_UNSPECIFIED;
- }
- else
- scm_wrong_type_arg_msg (NULL, 0, ra, "array");
}
#undef FUNC_NAME
--
1.8.2
[-- Attachment #6: 0005-Replace-scm_c_generalized_vector_length-in-random.c.patch --]
[-- Type: application/octet-stream, Size: 1291 bytes --]
From 89327a0c65d232dce47876fe309f971005046da5 Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Tue, 9 Apr 2013 18:09:49 +0200
Subject: [PATCH 05/22] Replace scm_c_generalized_vector_length in random.c
* libguile/random.c: (random:solid-sphere!): array is of known
rank 1, so use scm_c_array_length() instead.
---
libguile/random.c | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/libguile/random.c b/libguile/random.c
index c0b04bc..6df2cd9 100644
--- a/libguile/random.c
+++ b/libguile/random.c
@@ -582,13 +582,13 @@ SCM_DEFINE (scm_random_solid_sphere_x, "random:solid-sphere!", 1, 1, 0,
scm_random_normal_vector_x (v, state);
vector_scale_x (v,
pow (scm_c_uniform01 (SCM_RSTATE (state)),
- 1.0 / scm_c_generalized_vector_length (v))
+ 1.0 / scm_c_array_length (v))
/ sqrt (vector_sum_squares (v)));
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
-SCM_DEFINE (scm_random_hollow_sphere_x, "random:hollow-sphere!", 1, 1, 0,
+SCM_DEFINE (scm_random_hollow_sphere_x, "random:hollow-sphere!", 1, 1, 0,
(SCM v, SCM state),
"Fills vect with inexact real random numbers\n"
"the sum of whose squares is equal to 1.0.\n"
--
1.8.2
[-- Attachment #7: 0006-Replace-scm_c_generalized_vector_length-in-arrays.c.patch --]
[-- Type: application/octet-stream, Size: 1848 bytes --]
From b3fd45ad958d2f3f5305489225a6ef6103309eed Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Tue, 9 Apr 2013 18:17:21 +0200
Subject: [PATCH 06/22] Replace scm_c_generalized_vector_length in arrays.c
* libguile/arrays.c: (scm_array_contents, scm_make_shared_array):
arrays are known of rank 1 so replace by scm_c_array_length.
---
libguile/arrays.c | 10 +++++-----
1 file changed, 5 insertions(+), 5 deletions(-)
diff --git a/libguile/arrays.c b/libguile/arrays.c
index 350da44..15f67fd 100644
--- a/libguile/arrays.c
+++ b/libguile/arrays.c
@@ -378,7 +378,7 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1,
{
SCM_I_ARRAY_V (ra) = oldra;
old_base = old_min = 0;
- old_max = scm_c_generalized_vector_length (oldra) - 1;
+ old_max = scm_c_array_length (oldra) - 1;
}
inds = SCM_EOL;
@@ -430,7 +430,7 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1,
if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
{
SCM v = SCM_I_ARRAY_V (ra);
- size_t length = scm_c_generalized_vector_length (v);
+ size_t length = scm_c_array_length (v);
if (1 == s->inc && 0 == s->lbnd && length == 1 + s->ubnd)
return v;
if (s->ubnd < s->lbnd)
@@ -583,14 +583,14 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
return SCM_BOOL_F;
}
}
-
+
{
SCM v = SCM_I_ARRAY_V (ra);
- size_t length = scm_c_generalized_vector_length (v);
+ size_t length = scm_c_array_length (v);
if ((len == length) && 0 == SCM_I_ARRAY_BASE (ra) && SCM_I_ARRAY_DIMS (ra)->inc)
return v;
}
-
+
sra = scm_i_make_array (1);
SCM_I_ARRAY_DIMS (sra)->lbnd = 0;
SCM_I_ARRAY_DIMS (sra)->ubnd = len - 1;
--
1.8.2
[-- Attachment #8: 0007-Remove-generalized-vectors.h-includes.patch --]
[-- Type: application/octet-stream, Size: 960 bytes --]
From f06acc15a1a2980eb44c6a9a8c7f1315fc8c5ea6 Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Tue, 9 Apr 2013 18:27:29 +0200
Subject: [PATCH 07/22] Remove generalized-vectors.h includes
* libguile/srfi-4.c, libguile/uniform.h: ditto.
---
libguile/srfi-4.c | 1 -
libguile/uniform.h | 1 -
2 files changed, 2 deletions(-)
diff --git a/libguile/srfi-4.c b/libguile/srfi-4.c
index af8126d..6e005b1 100644
--- a/libguile/srfi-4.c
+++ b/libguile/srfi-4.c
@@ -31,7 +31,6 @@
#include "libguile/eval.h"
#include "libguile/extensions.h"
#include "libguile/uniform.h"
-#include "libguile/generalized-vectors.h"
#include "libguile/validate.h"
diff --git a/libguile/uniform.h b/libguile/uniform.h
index f0d5915..ccc52a8 100644
--- a/libguile/uniform.h
+++ b/libguile/uniform.h
@@ -24,7 +24,6 @@
\f
#include "libguile/__scm.h"
-#include "libguile/generalized-vectors.h"
\f
--
1.8.2
[-- Attachment #9: 0008-Remove-unnecessary-condition-in-scm_make_typed_array.patch --]
[-- Type: application/octet-stream, Size: 957 bytes --]
From efa6103613f087c4a8a3e6d21985e8e359729dea Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Wed, 10 Apr 2013 01:07:02 +0200
Subject: [PATCH 08/22] Remove unnecessary condition in scm_make_typed_array
* libguile/arrays.c: NDIM = 1 guarantees that s->inc == 1. Remove condition.
---
libguile/arrays.c | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/libguile/arrays.c b/libguile/arrays.c
index 15f67fd..9b242a1 100644
--- a/libguile/arrays.c
+++ b/libguile/arrays.c
@@ -195,8 +195,9 @@ SCM_DEFINE (scm_make_typed_array, "make-typed-array", 2, 0, 1,
scm_make_generalized_vector (type, scm_from_size_t (rlen), fill);
if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
- if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc))
+ if (s->ubnd < s->lbnd || 0 == s->lbnd)
return SCM_I_ARRAY_V (ra);
+
return ra;
}
#undef FUNC_NAME
--
1.8.2
[-- Attachment #10: 0009-Tests-for-shared-array-root.patch --]
[-- Type: application/octet-stream, Size: 1736 bytes --]
From 048c47cf327b6cb43ec3b69f4f3222428d151624 Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Wed, 10 Apr 2013 13:45:05 +0200
Subject: [PATCH 09/22] Tests for shared-array-root
* test-suite/tests/arrays.test: check shared-array-root against
make-shared-array, array-contents.
---
test-suite/tests/arrays.test | 29 +++++++++++++++++++++++++++++
1 file changed, 29 insertions(+)
diff --git a/test-suite/tests/arrays.test b/test-suite/tests/arrays.test
index 9d86371..1353927 100644
--- a/test-suite/tests/arrays.test
+++ b/test-suite/tests/arrays.test
@@ -574,6 +574,35 @@
(eqv? 8 (array-ref s2 2))))))
;;;
+;;; shared-array-root
+;;;
+
+(with-test-prefix "shared-array-root"
+
+ (define amap1 (lambda (i) (list (* 2 i))))
+ (define amap2 (lambda (i j) (list (+ 1 (* 2 i)) (+ 1 (* 2 j)))))
+
+ (pass-if "plain vector"
+ (let* ((a (make-vector 4 0))
+ (b (make-shared-array a amap1 2)))
+ (eq? (shared-array-root a) (shared-array-root b) (array-contents a))))
+
+ (pass-if "plain array rank 2"
+ (let* ((a (make-array 0 4 4))
+ (b (make-shared-array a amap2 2 2)))
+ (eq? (shared-array-root a) (shared-array-root b) (array-contents a))))
+
+ (pass-if "uniform array rank 2"
+ (let* ((a (make-typed-array 'c64 0 4 4))
+ (b (make-shared-array a amap2 2 2)))
+ (eq? (shared-array-root a) (shared-array-root b) (array-contents a))))
+
+ (pass-if "bit array rank 2"
+ (let* ((a (make-typed-array 'b #f 4 4))
+ (b (make-shared-array a amap2 2 2)))
+ (eq? (shared-array-root a) (shared-array-root b) (array-contents a)))))
+
+;;;
;;; uniform-vector
;;;
--
1.8.2
[-- Attachment #11: 0010-Don-t-use-scm_is_generalized_vector-in-shared-array-.patch --]
[-- Type: application/octet-stream, Size: 1593 bytes --]
From 549594ee5f5556ee6ecb3a3c4ac1421364e7f3d5 Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Wed, 10 Apr 2013 13:48:13 +0200
Subject: [PATCH 10/22] Don't use scm_is_generalized_vector in
shared-array-root
* libguile/arrays.c: (scm_shared_array_root): replace check for
scm_is_generalized_vector.
---
libguile/arrays.c | 11 ++++++-----
1 file changed, 6 insertions(+), 5 deletions(-)
diff --git a/libguile/arrays.c b/libguile/arrays.c
index 9b242a1..3f73107 100644
--- a/libguile/arrays.c
+++ b/libguile/arrays.c
@@ -60,21 +60,22 @@
(SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) & ~(SCM_I_ARRAY_FLAG_CONTIGUOUS << 16)))
-SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1, 0, 0,
+SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1, 0, 0,
(SCM ra),
"Return the root vector of a shared array.")
#define FUNC_NAME s_scm_shared_array_root
{
- if (SCM_I_ARRAYP (ra))
+ if (!scm_is_array (ra))
+ scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array");
+ else if (SCM_I_ARRAYP (ra))
return SCM_I_ARRAY_V (ra);
- else if (scm_is_generalized_vector (ra))
+ else
return ra;
- scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array");
}
#undef FUNC_NAME
-SCM_DEFINE (scm_shared_array_offset, "shared-array-offset", 1, 0, 0,
+SCM_DEFINE (scm_shared_array_offset, "shared-array-offset", 1, 0, 0,
(SCM ra),
"Return the root vector index of the first element in the array.")
#define FUNC_NAME s_scm_shared_array_offset
--
1.8.2
[-- Attachment #12: 0011-Tests-for-transpose-array.patch --]
[-- Type: application/octet-stream, Size: 1846 bytes --]
From 2de78692e2159e8ec3de6f8556a8da57a5a88bf7 Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Wed, 10 Apr 2013 14:53:10 +0200
Subject: [PATCH 11/22] Tests for transpose-array
* test-suite/tests/arrays.test: test transpose-array for ranks 1, 2, 3.
---
test-suite/tests/arrays.test | 32 ++++++++++++++++++++++++++++++++
1 file changed, 32 insertions(+)
diff --git a/test-suite/tests/arrays.test b/test-suite/tests/arrays.test
index 1353927..c3a28c5 100644
--- a/test-suite/tests/arrays.test
+++ b/test-suite/tests/arrays.test
@@ -603,6 +603,38 @@
(eq? (shared-array-root a) (shared-array-root b) (array-contents a)))))
;;;
+;;; transpose-array
+;;;
+
+(with-test-prefix "transpose-array"
+
+ (pass-if "rank 1"
+ (let* ((a #(1 2 3))
+ (b (transpose-array a 0)))
+ (and (array-equal? a b)
+ (eq? (shared-array-root a) (shared-array-root b)))))
+
+ (pass-if "rank 2"
+ (let* ((a #2((1 2 3) (4 5 6)))
+ (b (transpose-array a 1 0))
+ (c (transpose-array a 0 1)))
+ (and (array-equal? b #2((1 4) (2 5) (3 6)))
+ (array-equal? c a)
+ (eq? (shared-array-root a)
+ (shared-array-root b)
+ (shared-array-root c)))))
+
+ ; rank > 2 is needed to check against the inverted axis index logic.
+ (pass-if "rank 3"
+ (let* ((a #3(((0 1 2 3) (4 5 6 7) (8 9 10 11))
+ ((12 13 14 15) (16 17 18 19) (20 21 22 23))))
+ (b (transpose-array a 1 2 0)))
+ (and (array-equal? b #3(((0 4 8) (12 16 20)) ((1 5 9) (13 17 21))
+ ((2 6 10) (14 18 22)) ((3 7 11) (15 19 23))))
+ (eq? (shared-array-root a)
+ (shared-array-root b))))))
+
+;;;
;;; uniform-vector
;;;
--
1.8.2
[-- Attachment #13: 0012-Don-t-use-scm_is_generalized_vector-in-transpose-arr.patch --]
[-- Type: application/octet-stream, Size: 2660 bytes --]
From 95511997d48dc2922fe515de7b963b411d85e0b1 Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Wed, 10 Apr 2013 15:11:33 +0200
Subject: [PATCH 12/22] Don't use scm_is_generalized_vector in transpose-array
* libguile/arrays.c (scm_transpose_array)
- Use scm_c_array_rank(), which contains an implicit is_array test.
- Handle the rank 0 case.
* test-suite/tests/arrays.test
- Add test for rank 0 case.
- Add failure test for non array argument.
---
libguile/arrays.c | 16 ++++++++--------
test-suite/tests/arrays.test | 13 +++++++++++++
2 files changed, 21 insertions(+), 8 deletions(-)
diff --git a/libguile/arrays.c b/libguile/arrays.c
index 3f73107..695ab78 100644
--- a/libguile/arrays.c
+++ b/libguile/arrays.c
@@ -476,20 +476,22 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
SCM_VALIDATE_REST_ARGUMENT (args);
SCM_ASSERT (SCM_NIMP (ra), ra, SCM_ARG1, FUNC_NAME);
- if (scm_is_generalized_vector (ra))
+ switch (scm_c_array_rank (ra))
{
+ case 0:
+ if (!scm_is_null (args))
+ SCM_WRONG_NUM_ARGS ();
+ return ra;
+ case 1:
/* Make sure that we are called with a single zero as
- arguments.
+ arguments.
*/
if (scm_is_null (args) || !scm_is_null (SCM_CDR (args)))
SCM_WRONG_NUM_ARGS ();
SCM_VALIDATE_INT_COPY (SCM_ARG2, SCM_CAR (args), i);
SCM_ASSERT_RANGE (SCM_ARG2, SCM_CAR (args), i == 0);
return ra;
- }
-
- if (SCM_I_ARRAYP (ra))
- {
+ default:
vargs = scm_vector (args);
if (SCM_SIMPLE_VECTOR_LENGTH (vargs) != SCM_I_ARRAY_NDIM (ra))
SCM_WRONG_NUM_ARGS ();
@@ -539,8 +541,6 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
scm_i_ra_set_contp (res);
return res;
}
-
- scm_wrong_type_arg_msg (NULL, 0, ra, "array");
}
#undef FUNC_NAME
diff --git a/test-suite/tests/arrays.test b/test-suite/tests/arrays.test
index c3a28c5..600c295 100644
--- a/test-suite/tests/arrays.test
+++ b/test-suite/tests/arrays.test
@@ -606,8 +606,21 @@
;;; transpose-array
;;;
+; see strings.test.
+(define exception:wrong-type-arg
+ (cons #t "Wrong type"))
+
(with-test-prefix "transpose-array"
+ (pass-if-exception "non array argument" exception:wrong-type-arg
+ (transpose-array 99))
+
+ (pass-if "rank 0"
+ (let* ((a #0(99))
+ (b (transpose-array a)))
+ (and (array-equal? a b)
+ (eq? (shared-array-root a) (shared-array-root b)))))
+
(pass-if "rank 1"
(let* ((a #(1 2 3))
(b (transpose-array a 0)))
--
1.8.2
[-- Attachment #14: 0013-Reorder-arrays.test.patch --]
[-- Type: application/octet-stream, Size: 11771 bytes --]
From 60e793100c43e3ad62031b5b0b542f1457351f7b Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Wed, 10 Apr 2013 15:28:52 +0200
Subject: [PATCH 13/22] Reorder arrays.test
* test-suite/tests/arrays.test: dependence reordering: first sanity, then
make-array, then array-equal?, then make-shared-array, shared-array-root,
then the rest, many of which use make-shared-array.
---
test-suite/tests/arrays.test | 304 +++++++++++++++++++++----------------------
1 file changed, 152 insertions(+), 152 deletions(-)
diff --git a/test-suite/tests/arrays.test b/test-suite/tests/arrays.test
index 600c295..0da1a19 100644
--- a/test-suite/tests/arrays.test
+++ b/test-suite/tests/arrays.test
@@ -6,12 +6,12 @@
;;;; 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
@@ -207,6 +207,154 @@
(array-equal? #s16(1 2 3) #s16(1 2 3))))
;;;
+;;; make-shared-array
+;;;
+
+(define exception:mapping-out-of-range
+ (cons 'misc-error "^mapping out of range")) ;; per scm_make_shared_array
+
+(with-test-prefix "make-shared-array"
+
+ ;; this failed in guile 1.8.0
+ (pass-if "vector unchanged"
+ (let* ((a (make-array #f '(0 7)))
+ (s (make-shared-array a list '(0 7))))
+ (array-equal? a s)))
+
+ (pass-if-exception "vector, high too big" exception:mapping-out-of-range
+ (let* ((a (make-array #f '(0 7))))
+ (make-shared-array a list '(0 8))))
+
+ (pass-if-exception "vector, low too big" exception:out-of-range
+ (let* ((a (make-array #f '(0 7))))
+ (make-shared-array a list '(-1 7))))
+
+ (pass-if "truncate columns"
+ (array-equal? (make-shared-array #2((a b c) (d e f) (g h i)) list 3 2)
+ #2((a b) (d e) (g h))))
+
+ (pass-if "pick one column"
+ (array-equal? (make-shared-array #2((a b c) (d e f) (g h i))
+ (lambda (i) (list i 2))
+ '(0 2))
+ #(c f i)))
+
+ (pass-if "diagonal"
+ (array-equal? (make-shared-array #2((a b c) (d e f) (g h i))
+ (lambda (i) (list i i))
+ '(0 2))
+ #(a e i)))
+
+ ;; this failed in guile 1.8.0
+ (pass-if "2 dims from 1 dim"
+ (array-equal? (make-shared-array #1(a b c d e f g h i j k l)
+ (lambda (i j) (list (+ (* i 3) j)))
+ 4 3)
+ #2((a b c) (d e f) (g h i) (j k l))))
+
+ (pass-if "reverse columns"
+ (array-equal? (make-shared-array #2((a b c) (d e f) (g h i))
+ (lambda (i j) (list i (- 2 j)))
+ 3 3)
+ #2((c b a) (f e d) (i h g))))
+
+ (pass-if "fixed offset, 0 based becomes 1 based"
+ (let* ((x #2((a b c) (d e f) (g h i)))
+ (y (make-shared-array x
+ (lambda (i j) (list (1- i) (1- j)))
+ '(1 3) '(1 3))))
+ (and (eq? (array-ref x 0 0) 'a)
+ (eq? (array-ref y 1 1) 'a))))
+
+ ;; this failed in guile 1.8.0
+ (pass-if "stride every third element"
+ (array-equal? (make-shared-array #1(a b c d e f g h i j k l)
+ (lambda (i) (list (* i 3)))
+ 4)
+ #1(a d g j)))
+
+ (pass-if "shared of shared"
+ (let* ((a #2((1 2 3) (4 5 6) (7 8 9)))
+ (s1 (make-shared-array a (lambda (i) (list i 1)) 3))
+ (s2 (make-shared-array s1 list '(1 2))))
+ (and (eqv? 5 (array-ref s2 1))
+ (eqv? 8 (array-ref s2 2))))))
+
+;;;
+;;; shared-array-root
+;;;
+
+(with-test-prefix "shared-array-root"
+
+ (define amap1 (lambda (i) (list (* 2 i))))
+ (define amap2 (lambda (i j) (list (+ 1 (* 2 i)) (+ 1 (* 2 j)))))
+
+ (pass-if "plain vector"
+ (let* ((a (make-vector 4 0))
+ (b (make-shared-array a amap1 2)))
+ (eq? (shared-array-root a) (shared-array-root b) (array-contents a))))
+
+ (pass-if "plain array rank 2"
+ (let* ((a (make-array 0 4 4))
+ (b (make-shared-array a amap2 2 2)))
+ (eq? (shared-array-root a) (shared-array-root b) (array-contents a))))
+
+ (pass-if "uniform array rank 2"
+ (let* ((a (make-typed-array 'c64 0 4 4))
+ (b (make-shared-array a amap2 2 2)))
+ (eq? (shared-array-root a) (shared-array-root b) (array-contents a))))
+
+ (pass-if "bit array rank 2"
+ (let* ((a (make-typed-array 'b #f 4 4))
+ (b (make-shared-array a amap2 2 2)))
+ (eq? (shared-array-root a) (shared-array-root b) (array-contents a)))))
+
+;;;
+;;; transpose-array
+;;;
+
+; see strings.test.
+(define exception:wrong-type-arg
+ (cons #t "Wrong type"))
+
+(with-test-prefix "transpose-array"
+
+ (pass-if-exception "non array argument" exception:wrong-type-arg
+ (transpose-array 99))
+
+ (pass-if "rank 0"
+ (let* ((a #0(99))
+ (b (transpose-array a)))
+ (and (array-equal? a b)
+ (eq? (shared-array-root a) (shared-array-root b)))))
+
+ (pass-if "rank 1"
+ (let* ((a #(1 2 3))
+ (b (transpose-array a 0)))
+ (and (array-equal? a b)
+ (eq? (shared-array-root a) (shared-array-root b)))))
+
+ (pass-if "rank 2"
+ (let* ((a #2((1 2 3) (4 5 6)))
+ (b (transpose-array a 1 0))
+ (c (transpose-array a 0 1)))
+ (and (array-equal? b #2((1 4) (2 5) (3 6)))
+ (array-equal? c a)
+ (eq? (shared-array-root a)
+ (shared-array-root b)
+ (shared-array-root c)))))
+
+ ; rank > 2 is needed to check against the inverted axis index logic.
+ (pass-if "rank 3"
+ (let* ((a #3(((0 1 2 3) (4 5 6 7) (8 9 10 11))
+ ((12 13 14 15) (16 17 18 19) (20 21 22 23))))
+ (b (transpose-array a 1 2 0)))
+ (and (array-equal? b #3(((0 4 8) (12 16 20)) ((1 5 9) (13 17 21))
+ ((2 6 10) (14 18 22)) ((3 7 11) (15 19 23))))
+ (eq? (shared-array-root a)
+ (shared-array-root b))))))
+
+;;;
;;; array->list
;;;
@@ -397,8 +545,8 @@
(for-each (lambda (type)
(pass-if (symbol->string type)
(eq? type
- (array-type (make-typed-array type
- *unspecified*
+ (array-type (make-typed-array type
+ *unspecified*
'(5 6))))))
types))))
@@ -500,154 +648,6 @@
(array-set! a 'y 4 8 0)))))
;;;
-;;; make-shared-array
-;;;
-
-(define exception:mapping-out-of-range
- (cons 'misc-error "^mapping out of range")) ;; per scm_make_shared_array
-
-(with-test-prefix "make-shared-array"
-
- ;; this failed in guile 1.8.0
- (pass-if "vector unchanged"
- (let* ((a (make-array #f '(0 7)))
- (s (make-shared-array a list '(0 7))))
- (array-equal? a s)))
-
- (pass-if-exception "vector, high too big" exception:mapping-out-of-range
- (let* ((a (make-array #f '(0 7))))
- (make-shared-array a list '(0 8))))
-
- (pass-if-exception "vector, low too big" exception:out-of-range
- (let* ((a (make-array #f '(0 7))))
- (make-shared-array a list '(-1 7))))
-
- (pass-if "truncate columns"
- (array-equal? (make-shared-array #2((a b c) (d e f) (g h i)) list 3 2)
- #2((a b) (d e) (g h))))
-
- (pass-if "pick one column"
- (array-equal? (make-shared-array #2((a b c) (d e f) (g h i))
- (lambda (i) (list i 2))
- '(0 2))
- #(c f i)))
-
- (pass-if "diagonal"
- (array-equal? (make-shared-array #2((a b c) (d e f) (g h i))
- (lambda (i) (list i i))
- '(0 2))
- #(a e i)))
-
- ;; this failed in guile 1.8.0
- (pass-if "2 dims from 1 dim"
- (array-equal? (make-shared-array #1(a b c d e f g h i j k l)
- (lambda (i j) (list (+ (* i 3) j)))
- 4 3)
- #2((a b c) (d e f) (g h i) (j k l))))
-
- (pass-if "reverse columns"
- (array-equal? (make-shared-array #2((a b c) (d e f) (g h i))
- (lambda (i j) (list i (- 2 j)))
- 3 3)
- #2((c b a) (f e d) (i h g))))
-
- (pass-if "fixed offset, 0 based becomes 1 based"
- (let* ((x #2((a b c) (d e f) (g h i)))
- (y (make-shared-array x
- (lambda (i j) (list (1- i) (1- j)))
- '(1 3) '(1 3))))
- (and (eq? (array-ref x 0 0) 'a)
- (eq? (array-ref y 1 1) 'a))))
-
- ;; this failed in guile 1.8.0
- (pass-if "stride every third element"
- (array-equal? (make-shared-array #1(a b c d e f g h i j k l)
- (lambda (i) (list (* i 3)))
- 4)
- #1(a d g j)))
-
- (pass-if "shared of shared"
- (let* ((a #2((1 2 3) (4 5 6) (7 8 9)))
- (s1 (make-shared-array a (lambda (i) (list i 1)) 3))
- (s2 (make-shared-array s1 list '(1 2))))
- (and (eqv? 5 (array-ref s2 1))
- (eqv? 8 (array-ref s2 2))))))
-
-;;;
-;;; shared-array-root
-;;;
-
-(with-test-prefix "shared-array-root"
-
- (define amap1 (lambda (i) (list (* 2 i))))
- (define amap2 (lambda (i j) (list (+ 1 (* 2 i)) (+ 1 (* 2 j)))))
-
- (pass-if "plain vector"
- (let* ((a (make-vector 4 0))
- (b (make-shared-array a amap1 2)))
- (eq? (shared-array-root a) (shared-array-root b) (array-contents a))))
-
- (pass-if "plain array rank 2"
- (let* ((a (make-array 0 4 4))
- (b (make-shared-array a amap2 2 2)))
- (eq? (shared-array-root a) (shared-array-root b) (array-contents a))))
-
- (pass-if "uniform array rank 2"
- (let* ((a (make-typed-array 'c64 0 4 4))
- (b (make-shared-array a amap2 2 2)))
- (eq? (shared-array-root a) (shared-array-root b) (array-contents a))))
-
- (pass-if "bit array rank 2"
- (let* ((a (make-typed-array 'b #f 4 4))
- (b (make-shared-array a amap2 2 2)))
- (eq? (shared-array-root a) (shared-array-root b) (array-contents a)))))
-
-;;;
-;;; transpose-array
-;;;
-
-; see strings.test.
-(define exception:wrong-type-arg
- (cons #t "Wrong type"))
-
-(with-test-prefix "transpose-array"
-
- (pass-if-exception "non array argument" exception:wrong-type-arg
- (transpose-array 99))
-
- (pass-if "rank 0"
- (let* ((a #0(99))
- (b (transpose-array a)))
- (and (array-equal? a b)
- (eq? (shared-array-root a) (shared-array-root b)))))
-
- (pass-if "rank 1"
- (let* ((a #(1 2 3))
- (b (transpose-array a 0)))
- (and (array-equal? a b)
- (eq? (shared-array-root a) (shared-array-root b)))))
-
- (pass-if "rank 2"
- (let* ((a #2((1 2 3) (4 5 6)))
- (b (transpose-array a 1 0))
- (c (transpose-array a 0 1)))
- (and (array-equal? b #2((1 4) (2 5) (3 6)))
- (array-equal? c a)
- (eq? (shared-array-root a)
- (shared-array-root b)
- (shared-array-root c)))))
-
- ; rank > 2 is needed to check against the inverted axis index logic.
- (pass-if "rank 3"
- (let* ((a #3(((0 1 2 3) (4 5 6 7) (8 9 10 11))
- ((12 13 14 15) (16 17 18 19) (20 21 22 23))))
- (b (transpose-array a 1 2 0)))
- (and (array-equal? b #3(((0 4 8) (12 16 20)) ((1 5 9) (13 17 21))
- ((2 6 10) (14 18 22)) ((3 7 11) (15 19 23))))
- (eq? (shared-array-root a)
- (shared-array-root b))))))
-
-;;;
;;; uniform-vector
;;;
--
1.8.2
[-- Attachment #15: 0014-Fix-bad-uses-of-base-and-lbnd-on-rank-1-arrays.patch --]
[-- Type: application/octet-stream, Size: 7020 bytes --]
From 9663f407aa5b0c3fef2b52a413cb95df2b303b8e Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Thu, 11 Apr 2013 13:03:45 +0200
Subject: [PATCH 14/22] Fix bad uses of base and lbnd on rank 1 arrays
* libguile/array-map.c
- rafill, ramap, rafe, racp: object from SCM_I_ARRAY_V always
has base 0, lbnd 0 and inc 1; make use of this.
* libguile/arrays.c
- array_handle_ref, array_handle_set: idem.
- array_get_handle: sanity check.
* libguile/generalized-vectors.c
- scm_c_generalized_vector_ref, scm_c_generalized_vector_set_x:
pos should be base when idx is lbnd. Furthermore, pos should be signed and
have its overflow checked; do this by handling the job to
scm_c_array_ref_1, scm_c_array_set_1_x.
* libguile/generalized-vectors.h
- fix prototypes.
---
libguile/array-map.c | 27 +++++++++++++--------------
libguile/arrays.c | 8 ++++++--
libguile/generalized-vectors.c | 20 ++++----------------
libguile/generalized-vectors.h | 4 ++--
4 files changed, 25 insertions(+), 34 deletions(-)
diff --git a/libguile/array-map.c b/libguile/array-map.c
index 8484d8c..426103c 100644
--- a/libguile/array-map.c
+++ b/libguile/array-map.c
@@ -194,9 +194,8 @@ scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
SCM lvra, *plvra;
long *vinds;
int k, kmax;
- int (*cproc) ();
+ int (*cproc) () = cproc_ptr;
- cproc = cproc_ptr;
switch (scm_ra_matchp (ra0, lra))
{
default:
@@ -344,8 +343,8 @@ rafill (SCM dst, SCM fill)
size_t i;
ssize_t inc;
scm_array_get_handle (SCM_I_ARRAY_V (dst), &h);
- i = h.base + h.dims[0].lbnd + SCM_I_ARRAY_BASE (dst)*h.dims[0].inc;
- inc = SCM_I_ARRAY_DIMS (dst)->inc * h.dims[0].inc;
+ i = SCM_I_ARRAY_BASE (dst);
+ inc = SCM_I_ARRAY_DIMS (dst)->inc;
for (; n-- > 0; i += inc)
h.impl->vset (&h, i, fill);
@@ -378,10 +377,10 @@ racp (SCM src, SCM dst)
scm_array_get_handle (SCM_I_ARRAY_V (src), &h_s);
scm_array_get_handle (SCM_I_ARRAY_V (dst), &h_d);
- i_s = h_s.base + h_s.dims[0].lbnd + SCM_I_ARRAY_BASE (src) * h_s.dims[0].inc;
- i_d = h_d.base + h_d.dims[0].lbnd + SCM_I_ARRAY_BASE (dst) * h_d.dims[0].inc;
- inc_s = SCM_I_ARRAY_DIMS (src)->inc * h_s.dims[0].inc;
- inc_d = SCM_I_ARRAY_DIMS (dst)->inc * h_d.dims[0].inc;
+ i_s = SCM_I_ARRAY_BASE (src);
+ i_d = SCM_I_ARRAY_BASE (dst);
+ inc_s = SCM_I_ARRAY_DIMS (src)->inc;
+ inc_d = SCM_I_ARRAY_DIMS (dst)->inc;
for (; n-- > 0; i_s += inc_s, i_d += inc_d)
h_d.impl->vset (&h_d, i_d, h_s.impl->vref (&h_s, i_s));
@@ -681,8 +680,8 @@ ramap (SCM ra0, SCM proc, SCM ras)
size_t i0, i0end;
ssize_t inc0;
scm_array_get_handle (SCM_I_ARRAY_V (ra0), &h0);
- i0 = h0.base + h0.dims[0].lbnd + SCM_I_ARRAY_BASE (ra0)*h0.dims[0].inc;
- inc0 = SCM_I_ARRAY_DIMS (ra0)->inc * h0.dims[0].inc;
+ i0 = SCM_I_ARRAY_BASE (ra0);
+ inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
i0end = i0 + n*inc0;
if (scm_is_null (ras))
for (; i0 < i0end; i0 += inc0)
@@ -694,8 +693,8 @@ ramap (SCM ra0, SCM proc, SCM ras)
size_t i1;
ssize_t inc1;
scm_array_get_handle (SCM_I_ARRAY_V (ra1), &h1);
- i1 = h1.base + h1.dims[0].lbnd + SCM_I_ARRAY_BASE (ra1)*h1.dims[0].inc;
- inc1 = SCM_I_ARRAY_DIMS (ra1)->inc * h1.dims[0].inc;
+ i1 = SCM_I_ARRAY_BASE (ra1);
+ inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
ras = SCM_CDR (ras);
if (scm_is_null (ras))
for (; i0 < i0end; i0 += inc0, i1 += inc1)
@@ -754,8 +753,8 @@ rafe (SCM ra0, SCM proc, SCM ras)
size_t i0, i0end;
ssize_t inc0;
scm_array_get_handle (SCM_I_ARRAY_V (ra0), &h0);
- i0 = h0.base + h0.dims[0].lbnd + SCM_I_ARRAY_BASE (ra0)*h0.dims[0].inc;
- inc0 = SCM_I_ARRAY_DIMS (ra0)->inc * h0.dims[0].inc;
+ i0 = SCM_I_ARRAY_BASE (ra0);
+ inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
i0end = i0 + n*inc0;
if (scm_is_null (ras))
for (; i0 < i0end; i0 += inc0)
diff --git a/libguile/arrays.c b/libguile/arrays.c
index 695ab78..191d02d 100644
--- a/libguile/arrays.c
+++ b/libguile/arrays.c
@@ -823,7 +823,6 @@ array_handle_ref (scm_t_array_handle *hh, size_t pos)
scm_t_array_handle h;
SCM ret;
scm_array_get_handle (SCM_I_ARRAY_V (hh->array), &h);
- pos = h.base + h.dims[0].lbnd + pos * h.dims[0].inc;
ret = h.impl->vref (&h, pos);
scm_array_handle_release (&h);
return ret;
@@ -834,7 +833,6 @@ array_handle_set (scm_t_array_handle *hh, size_t pos, SCM val)
{
scm_t_array_handle h;
scm_array_get_handle (SCM_I_ARRAY_V (hh->array), &h);
- pos = h.base + h.dims[0].lbnd + pos * h.dims[0].inc;
h.impl->vset (&h, pos, val);
scm_array_handle_release (&h);
}
@@ -845,6 +843,12 @@ array_get_handle (SCM array, scm_t_array_handle *h)
{
scm_t_array_handle vh;
scm_array_get_handle (SCM_I_ARRAY_V (array), &vh);
+ if (vh.dims[0].inc != 1 || vh.dims[0].lbnd != 0 || vh.base != 0)
+ {
+ fprintf(stderr, "INC %ld, %ld", vh.dims[0].inc, vh.dims[0].lbnd);
+ fflush(stderr);
+ abort();
+ }
h->element_type = vh.element_type;
h->elements = vh.elements;
h->writable_elements = vh.writable_elements;
diff --git a/libguile/generalized-vectors.c b/libguile/generalized-vectors.c
index 5e3e552..6e88f3c 100644
--- a/libguile/generalized-vectors.c
+++ b/libguile/generalized-vectors.c
@@ -110,27 +110,15 @@ scm_c_generalized_vector_length (SCM v)
}
SCM
-scm_c_generalized_vector_ref (SCM v, size_t idx)
+scm_c_generalized_vector_ref (SCM v, ssize_t idx)
{
- scm_t_array_handle h;
- size_t pos;
- SCM ret;
- scm_generalized_vector_get_handle (v, &h);
- pos = h.base + h.dims[0].lbnd + idx * h.dims[0].inc;
- ret = h.impl->vref (&h, pos);
- scm_array_handle_release (&h);
- return ret;
+ return scm_c_array_ref_1(v, idx);
}
void
-scm_c_generalized_vector_set_x (SCM v, size_t idx, SCM val)
+scm_c_generalized_vector_set_x (SCM v, ssize_t idx, SCM val)
{
- scm_t_array_handle h;
- size_t pos;
- scm_generalized_vector_get_handle (v, &h);
- pos = h.base + h.dims[0].lbnd + idx * h.dims[0].inc;
- h.impl->vset (&h, pos, val);
- scm_array_handle_release (&h);
+ scm_c_array_set_1_x(v, val, idx);
}
void
diff --git a/libguile/generalized-vectors.h b/libguile/generalized-vectors.h
index e2acb98..876537a 100644
--- a/libguile/generalized-vectors.h
+++ b/libguile/generalized-vectors.h
@@ -32,8 +32,8 @@
SCM_API int scm_is_generalized_vector (SCM obj);
SCM_API size_t scm_c_generalized_vector_length (SCM v);
-SCM_API SCM scm_c_generalized_vector_ref (SCM v, size_t idx);
-SCM_API void scm_c_generalized_vector_set_x (SCM v, size_t idx, SCM val);
+SCM_API SCM scm_c_generalized_vector_ref (SCM v, ssize_t idx);
+SCM_API void scm_c_generalized_vector_set_x (SCM v, ssize_t idx, SCM val);
SCM_API void scm_generalized_vector_get_handle (SCM vec,
scm_t_array_handle *h);
--
1.8.2
[-- Attachment #16: 0015-For-uniform-vectors-SCM_I_ARRAYP-can-t-be-true.patch --]
[-- Type: application/octet-stream, Size: 6067 bytes --]
From db6f9b83f1c21aa22446c3d644e5df68f7a0bdc8 Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Thu, 11 Apr 2013 13:10:08 +0200
Subject: [PATCH 15/22] For uniform vectors SCM_I_ARRAYP can't be true
This fixes an inconsistency where uniform-vector? of a shared array could
be true but -ref operations failed to account correctly for lbnd.
* libguile/uniform.c
- scm_is_uniform_vector: SCM_I_ARRAYP disqualifies obj as uniform vector.
- scm_c_uniform_vector_length: lbnd is known 0, so don't use it.
- scm_c_uniform_vector_ref: lbnd/base/inc are known to be 0/0/1.
- scm_c_uniform_vector_set_x!: idem.
- scm_uniform_vector_writable_elements: check uvec's type.
* test-suite/tests/arrays.test
- group the exception types at the top.
- check that uniform-vector functions do not accept general arrays.
---
libguile/uniform.c | 11 ++++-----
test-suite/tests/arrays.test | 58 +++++++++++++++++++++++++++-----------------
2 files changed, 41 insertions(+), 28 deletions(-)
diff --git a/libguile/uniform.c b/libguile/uniform.c
index 26193a3..dc6c024 100644
--- a/libguile/uniform.c
+++ b/libguile/uniform.c
@@ -87,11 +87,10 @@ scm_is_uniform_vector (SCM obj)
scm_t_array_handle h;
int ret = 0;
- if (scm_is_array (obj))
+ if (scm_is_array (obj) && !SCM_I_ARRAYP (obj))
{
scm_array_get_handle (obj, &h);
- ret = 1 == scm_array_handle_rank (&h)
- && SCM_ARRAY_ELEMENT_TYPE_IS_UNBOXED (h.element_type);
+ ret = SCM_ARRAY_ELEMENT_TYPE_IS_UNBOXED (h.element_type);
scm_array_handle_release (&h);
}
return ret;
@@ -107,7 +106,7 @@ scm_c_uniform_vector_length (SCM uvec)
"uniform vector");
scm_array_get_handle (uvec, &h);
- ret = h.dims[0].ubnd - h.dims[0].lbnd + 1;
+ ret = h.dims[0].ubnd + 1;
scm_array_handle_release (&h);
return ret;
}
@@ -165,7 +164,6 @@ scm_c_uniform_vector_ref (SCM v, size_t pos)
scm_wrong_type_arg_msg (NULL, 0, v, "uniform vector");
scm_array_get_handle (v, &h);
- pos = h.base + h.dims[0].lbnd + pos * h.dims[0].inc;
ret = h.impl->vref (&h, pos);
scm_array_handle_release (&h);
return ret;
@@ -191,7 +189,6 @@ scm_c_uniform_vector_set_x (SCM v, size_t pos, SCM val)
scm_wrong_type_arg_msg (NULL, 0, v, "uniform vector");
scm_array_get_handle (v, &h);
- pos = h.base + h.dims[0].lbnd + pos * h.dims[0].inc;
h.impl->vset (&h, pos, val);
scm_array_handle_release (&h);
}
@@ -232,6 +229,8 @@ scm_uniform_vector_writable_elements (SCM uvec,
size_t *lenp, ssize_t *incp)
{
void *ret;
+ if (!scm_is_uniform_vector (uvec))
+ scm_wrong_type_arg_msg (NULL, 0, uvec, "uniform vector");
scm_array_get_handle (uvec, h);
/* FIXME nonlocal exit */
ret = scm_array_handle_uniform_writable_elements (h);
diff --git a/test-suite/tests/arrays.test b/test-suite/tests/arrays.test
index 0da1a19..8ad97f4 100644
--- a/test-suite/tests/arrays.test
+++ b/test-suite/tests/arrays.test
@@ -22,16 +22,22 @@
#:use-module (srfi srfi-4)
#:use-module (srfi srfi-4 gnu))
-;;;
-;;; array?
-;;;
-
(define exception:wrong-num-indices
(cons 'misc-error "^wrong number of indices.*"))
(define exception:length-non-negative
(cons 'read-error ".*array length must be non-negative.*"))
+(define exception:mapping-out-of-range
+ (cons 'misc-error "^mapping out of range")) ;; per scm_make_shared_array
+
+; see strings.test.
+(define exception:wrong-type-arg
+ (cons #t "Wrong type"))
+
+;;;
+;;; array?
+;;;
(with-test-prefix "sanity"
;; At the current time of writing, bignums have a tc7 that is one bit
@@ -210,9 +216,6 @@
;;; make-shared-array
;;;
-(define exception:mapping-out-of-range
- (cons 'misc-error "^mapping out of range")) ;; per scm_make_shared_array
-
(with-test-prefix "make-shared-array"
;; this failed in guile 1.8.0
@@ -313,10 +316,6 @@
;;; transpose-array
;;;
-; see strings.test.
-(define exception:wrong-type-arg
- (cons #t "Wrong type"))
-
(with-test-prefix "transpose-array"
(pass-if-exception "non array argument" exception:wrong-type-arg
@@ -670,21 +669,36 @@
(array-set! a -128 0)
(= -128 (uniform-vector-ref a 0))))))
- (with-test-prefix "shared with rank 1 remain uniform vectors"
+ (with-test-prefix "arrays with lbnd!=0 are not uniform vectors"
+
+ (pass-if "bit"
+ (and (not (uniform-vector? #1b@1(#t #t #t)))
+ (uniform-vector? #1b(#t #t #t))))
+
+ (pass-if "s8"
+ (and (not (uniform-vector? #1s8@1(0 1 2)))
+ (uniform-vector? #1s8(0 1 2)))))
+
+
+ (with-test-prefix "shared with rank 1 do not remain uniform vectors"
(let ((a #f64(1 2 3 4)))
- (pass-if "change offset"
+ (pass-if-exception "change offset -length" exception:wrong-type-arg
(let ((b (make-shared-array a (lambda (i) (list (+ i 1))) 3)))
- (and (uniform-vector? b)
- (= 3 (uniform-vector-length b))
- (array-equal? b #f64(2 3 4)))))
-
- (pass-if "change stride"
- (let ((c (make-shared-array a (lambda (i) (list (* i 2))) 2)))
- (and (uniform-vector? c)
- (= 2 (uniform-vector-length c))
- (array-equal? c #f64(1 3))))))))
+ (= 3 (uniform-vector-length b))))
+
+ (pass-if-exception "change offset -ref" exception:wrong-type-arg
+ (let ((b (make-shared-array a (lambda (i) (list (+ i 1))) 3)))
+ (= 2 (uniform-vector-ref b 0))))
+
+ (pass-if-exception "change stride -length" exception:wrong-type-arg
+ (let ((b (make-shared-array a (lambda (i) (list (* i 2))) 2)))
+ (= 3 (uniform-vector-length b))))
+
+ (pass-if-exception "change stride -ref" exception:wrong-type-arg
+ (let ((b (make-shared-array a (lambda (i) (list (* i 2))) 2)))
+ (= 2 (uniform-vector-ref b 0)))))))
;;;
;;; syntax
--
1.8.2
[-- Attachment #17: 0016-Identify-scm_is_vector-with-scm_is_simple_vector.patch --]
[-- Type: application/octet-stream, Size: 14342 bytes --]
From 523838b40230a4f358ace69b4dfd05c2f3eec770 Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Thu, 11 Apr 2013 18:11:35 +0200
Subject: [PATCH 16/22] Identify scm_is_vector with scm_is_simple_vector
This patch fixes the bug (vector-ref #1@1(1 2 3) 1) => 2.
* libguile/vectors.c: (scm_is_vector): just as scm_is_simple_vector.
* libguile/filesys.c, libguile/random.c, libguile/stime.c, libguile/trees.c,
libguile/validate.h: use scm_is_vector instead of scm_is_simple_vector.
* libguile/sort.c
- scm_restricted_vector_sort_x: use scm_array_handle_writable_elements
instead of scm_vector_writable_elements, to work with non-vector
rank-1 array objects.
- scm_sort_x: check for scm_is_array instead of scm_is_vector. Rank
check is in restricted_vector_sort_x.
- scm_sort: ditto.
- scm_stable_sort_x: like scm_restricted_vector_sort_x.
- scm_stable_sort: like scm_sort.
* test-suite/tests/arrays.test: fix header.
* test-suite/tests/random.test: new coverage test covering
random:normal-vector!
* test-suite/Makefile.am: include random.test in make check.
---
libguile/filesys.c | 10 ++++----
libguile/random.c | 6 ++---
libguile/sort.c | 57 +++++++++++++++++++++++++-------------------
libguile/stime.c | 2 +-
libguile/trees.c | 4 ++--
libguile/validate.h | 4 ++--
libguile/vectors.c | 9 +------
test-suite/Makefile.am | 1 +
test-suite/tests/arrays.test | 2 +-
test-suite/tests/random.test | 55 ++++++++++++++++++++++++++++++++++++++++++
10 files changed, 103 insertions(+), 47 deletions(-)
create mode 100644 test-suite/tests/random.test
diff --git a/libguile/filesys.c b/libguile/filesys.c
index 5f6208d..c7aaed7 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -691,7 +691,7 @@ fill_select_type (fd_set *set, SCM *ports_ready, SCM list_or_vec, int pos)
{
int max_fd = 0;
- if (scm_is_simple_vector (list_or_vec))
+ if (scm_is_vector (list_or_vec))
{
int i = SCM_SIMPLE_VECTOR_LENGTH (list_or_vec);
@@ -752,7 +752,7 @@ retrieve_select_type (fd_set *set, SCM ports_ready, SCM list_or_vec)
{
SCM answer_list = ports_ready;
- if (scm_is_simple_vector (list_or_vec))
+ if (scm_is_vector (list_or_vec))
{
int i = SCM_SIMPLE_VECTOR_LENGTH (list_or_vec);
@@ -821,7 +821,7 @@ SCM_DEFINE (scm_select, "select", 3, 2, 0,
SCM write_ports_ready = SCM_EOL;
int max_fd;
- if (scm_is_simple_vector (reads))
+ if (scm_is_vector (reads))
{
read_count = SCM_SIMPLE_VECTOR_LENGTH (reads);
}
@@ -830,7 +830,7 @@ SCM_DEFINE (scm_select, "select", 3, 2, 0,
read_count = scm_ilength (reads);
SCM_ASSERT (read_count >= 0, reads, SCM_ARG1, FUNC_NAME);
}
- if (scm_is_simple_vector (writes))
+ if (scm_is_vector (writes))
{
write_count = SCM_SIMPLE_VECTOR_LENGTH (writes);
}
@@ -839,7 +839,7 @@ SCM_DEFINE (scm_select, "select", 3, 2, 0,
write_count = scm_ilength (writes);
SCM_ASSERT (write_count >= 0, writes, SCM_ARG2, FUNC_NAME);
}
- if (scm_is_simple_vector (excepts))
+ if (scm_is_vector (excepts))
{
except_count = SCM_SIMPLE_VECTOR_LENGTH (excepts);
}
diff --git a/libguile/random.c b/libguile/random.c
index 6df2cd9..915f17f 100644
--- a/libguile/random.c
+++ b/libguile/random.c
@@ -504,7 +504,7 @@ static void
vector_scale_x (SCM v, double c)
{
size_t n;
- if (scm_is_simple_vector (v))
+ if (scm_is_vector (v))
{
n = SCM_SIMPLE_VECTOR_LENGTH (v);
while (n-- > 0)
@@ -532,7 +532,7 @@ vector_sum_squares (SCM v)
{
double x, sum = 0.0;
size_t n;
- if (scm_is_simple_vector (v))
+ if (scm_is_vector (v))
{
n = SCM_SIMPLE_VECTOR_LENGTH (v);
while (n-- > 0)
@@ -626,7 +626,7 @@ SCM_DEFINE (scm_random_normal_vector_x, "random:normal-vector!", 1, 1, 0,
scm_generalized_vector_get_handle (v, &handle);
dim = scm_array_handle_dims (&handle);
- if (scm_is_vector (v))
+ if (handle.element_type == SCM_ARRAY_ELEMENT_TYPE_SCM)
{
SCM *elts = scm_array_handle_writable_elements (&handle);
for (i = dim->lbnd; i <= dim->ubnd; i++, elts += dim->inc)
diff --git a/libguile/sort.c b/libguile/sort.c
index 2a36320..1b47afc 100644
--- a/libguile/sort.c
+++ b/libguile/sort.c
@@ -77,18 +77,25 @@ SCM_DEFINE (scm_restricted_vector_sort_x, "restricted-vector-sort!", 4, 0, 0,
#define FUNC_NAME s_scm_restricted_vector_sort_x
{
size_t vlen, spos, len;
- ssize_t vinc;
scm_t_array_handle handle;
+ scm_t_array_dim *dim;
+
SCM *velts;
- velts = scm_vector_writable_elements (vec, &handle, &vlen, &vinc);
+ if (!scm_is_array (vec) || 1 != scm_c_array_rank (vec))
+ SCM_WRONG_TYPE_ARG (1, vec);
+
+ scm_array_get_handle (vec, &handle);
+ velts = scm_array_handle_writable_elements (&handle);
+ dim = scm_array_handle_dims (&handle);
+ vlen = dim->ubnd - dim->lbnd + 1;
spos = scm_to_unsigned_integer (startpos, 0, vlen);
len = scm_to_unsigned_integer (endpos, spos, vlen) - spos;
- if (vinc == 1)
- quicksort1 (velts + spos*vinc, len, less);
+ if (dim->inc == 1)
+ quicksort1 (velts + spos, len, less);
else
- quicksort (velts + spos*vinc, len, vinc, less);
+ quicksort (velts + spos*dim->inc, len, dim->inc, less);
scm_array_handle_release (&handle);
@@ -377,12 +384,12 @@ SCM_DEFINE (scm_sort_x, "sort!", 2, 0, 0,
SCM_VALIDATE_LIST_COPYLEN (1, items, len);
return scm_merge_list_step (&items, less, len);
}
- else if (scm_is_vector (items))
+ else if (scm_is_array (items))
{
scm_restricted_vector_sort_x (items,
less,
scm_from_int (0),
- scm_vector_length (items));
+ scm_array_length (items));
return items;
}
else
@@ -403,7 +410,7 @@ SCM_DEFINE (scm_sort, "sort", 2, 0, 0,
if (scm_is_pair (items))
return scm_sort_x (scm_list_copy (items), less);
- else if (scm_is_vector (items))
+ else if (scm_is_array (items) && 1 == scm_c_array_rank (items))
return scm_sort_x (scm_vector_copy (items), less);
else
SCM_WRONG_TYPE_ARG (1, items);
@@ -489,28 +496,30 @@ SCM_DEFINE (scm_stable_sort_x, "stable-sort!", 2, 0, 0,
SCM_VALIDATE_LIST_COPYLEN (1, items, len);
return scm_merge_list_step (&items, less, len);
}
- else if (scm_is_vector (items))
+ else if (scm_is_array (items) && 1 == scm_c_array_rank (items))
{
- scm_t_array_handle temp_handle, vec_handle;
- SCM temp, *temp_elts, *vec_elts;
+ scm_t_array_handle temp_handle, items_handle;
+ scm_t_array_dim *dim;
+ SCM temp, *temp_elts, *items_elts;
size_t len;
- ssize_t inc;
-
- vec_elts = scm_vector_writable_elements (items, &vec_handle,
- &len, &inc);
+
+ scm_array_get_handle (items, &items_handle);
+ items_elts = scm_array_handle_writable_elements (&items_handle);
+ dim = scm_array_handle_dims (&items_handle);
+ len = dim->ubnd - dim->lbnd + 1;
if (len == 0) {
- scm_array_handle_release (&vec_handle);
+ scm_array_handle_release (&items_handle);
return items;
}
-
+
temp = scm_c_make_vector (len, SCM_UNDEFINED);
- temp_elts = scm_vector_writable_elements (temp, &temp_handle,
- NULL, NULL);
+ scm_array_get_handle (temp, &temp_handle);
+ temp_elts = scm_array_handle_writable_elements (&temp_handle);
- scm_merge_vector_step (vec_elts, temp_elts, less, 0, len-1, inc);
+ scm_merge_vector_step (items_elts, temp_elts, less, 0, len-1, dim->inc);
scm_array_handle_release (&temp_handle);
- scm_array_handle_release (&vec_handle);
+ scm_array_handle_release (&items_handle);
return items;
}
@@ -532,15 +541,13 @@ SCM_DEFINE (scm_stable_sort, "stable-sort", 2, 0, 0,
if (scm_is_pair (items))
return scm_stable_sort_x (scm_list_copy (items), less);
- else if (scm_is_vector (items))
- return scm_stable_sort_x (scm_vector_copy (items), less);
else
- SCM_WRONG_TYPE_ARG (1, items);
+ return scm_stable_sort_x (scm_vector_copy (items), less);
}
#undef FUNC_NAME
-SCM_DEFINE (scm_sort_list_x, "sort-list!", 2, 0, 0,
+SCM_DEFINE (scm_sort_list_x, "sort-list!", 2, 0, 0,
(SCM items, SCM less),
"Sort the list @var{items}, using @var{less} for comparing the\n"
"list elements. The sorting is destructive, that means that the\n"
diff --git a/libguile/stime.c b/libguile/stime.c
index 78539d9..c876925 100644
--- a/libguile/stime.c
+++ b/libguile/stime.c
@@ -506,7 +506,7 @@ SCM_DEFINE (scm_gmtime, "gmtime", 1, 0, 0,
static void
bdtime2c (SCM sbd_time, struct tm *lt, int pos, const char *subr)
{
- SCM_ASSERT (scm_is_simple_vector (sbd_time)
+ SCM_ASSERT (scm_is_vector (sbd_time)
&& SCM_SIMPLE_VECTOR_LENGTH (sbd_time) == 11,
sbd_time, pos, subr);
diff --git a/libguile/trees.c b/libguile/trees.c
index 76bb686..88adf88 100644
--- a/libguile/trees.c
+++ b/libguile/trees.c
@@ -99,7 +99,7 @@ copy_tree (struct t_trace *const hare,
unsigned int tortoise_delay)
#define FUNC_NAME s_scm_copy_tree
{
- if (!scm_is_pair (hare->obj) && !scm_is_simple_vector (hare->obj))
+ if (!scm_is_pair (hare->obj) && !scm_is_vector (hare->obj))
{
return hare->obj;
}
@@ -128,7 +128,7 @@ copy_tree (struct t_trace *const hare,
--tortoise_delay;
}
- if (scm_is_simple_vector (hare->obj))
+ if (scm_is_vector (hare->obj))
{
size_t length = SCM_SIMPLE_VECTOR_LENGTH (hare->obj);
SCM new_vector = scm_c_make_vector (length, SCM_UNSPECIFIED);
diff --git a/libguile/validate.h b/libguile/validate.h
index 0bdc057..3495198 100644
--- a/libguile/validate.h
+++ b/libguile/validate.h
@@ -360,12 +360,12 @@
#define SCM_VALIDATE_VECTOR(pos, v) \
do { \
- SCM_ASSERT (scm_is_simple_vector (v), v, pos, FUNC_NAME); \
+ SCM_ASSERT (scm_is_vector (v), v, pos, FUNC_NAME); \
} while (0)
#define SCM_VALIDATE_VECTOR_OR_DVECTOR(pos, v) \
do { \
- SCM_ASSERT ((scm_is_simple_vector (v) \
+ SCM_ASSERT ((scm_is_vector (v) \
|| (scm_is_true (scm_f64vector_p (v)))), \
v, pos, FUNC_NAME); \
} while (0)
diff --git a/libguile/vectors.c b/libguile/vectors.c
index b386deb..775aa80 100644
--- a/libguile/vectors.c
+++ b/libguile/vectors.c
@@ -47,14 +47,7 @@
int
scm_is_vector (SCM obj)
{
- if (SCM_I_IS_VECTOR (obj))
- return 1;
- if (SCM_I_ARRAYP (obj) && SCM_I_ARRAY_NDIM (obj) == 1)
- {
- SCM v = SCM_I_ARRAY_V (obj);
- return SCM_I_IS_VECTOR (v);
- }
- return 0;
+ return SCM_I_IS_VECTOR (obj);
}
int
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 01ffd1c..6c736b6 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -109,6 +109,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/r6rs-unicode.test \
tests/rnrs-libraries.test \
tests/ramap.test \
+ tests/random.test \
tests/rdelim.test \
tests/reader.test \
tests/receive.test \
diff --git a/test-suite/tests/arrays.test b/test-suite/tests/arrays.test
index 8ad97f4..e0aa5ca 100644
--- a/test-suite/tests/arrays.test
+++ b/test-suite/tests/arrays.test
@@ -1,4 +1,4 @@
-;;;; unif.test --- tests guile's uniform arrays -*- scheme -*-
+;;;; arrays.test --- tests guile's uniform arrays -*- scheme -*-
;;;;
;;;; Copyright 2004, 2006, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
;;;;
diff --git a/test-suite/tests/random.test b/test-suite/tests/random.test
new file mode 100644
index 0000000..ab20b58
--- /dev/null
+++ b/test-suite/tests/random.test
@@ -0,0 +1,55 @@
+;;;; random.test --- tests guile's uniform arrays -*- scheme -*-
+;;;;
+;;;; Copyright 2013 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
+
+(define-module (test-suite test-random)
+ #:use-module ((system base compile) #:select (compile))
+ #:use-module (test-suite lib)
+ #:use-module (srfi srfi-4)
+ #:use-module (srfi srfi-4 gnu))
+
+; see strings.test, arrays.test.
+(define exception:wrong-type-arg
+ (cons #t "Wrong type"))
+
+;;;
+;;; random:normal-vector!
+;;;
+
+(with-test-prefix "random:normal-vector!"
+
+ ;; FIXME need proper function test.
+
+ (pass-if "non uniform"
+ (let ((a (make-vector 4 0))
+ (b (make-vector 4 0))
+ (c (make-shared-array (make-vector 8 0)
+ (lambda (i) (list (+ 1 (* 2 i)))) 4)))
+ (begin
+ (random:normal-vector! b (random-state-from-platform))
+ (random:normal-vector! c (random-state-from-platform))
+ (and (not (equal? a b)) (not (equal? a c))))))
+
+ (pass-if "uniform (f64)"
+ (let ((a (make-f64vector 4 0))
+ (b (make-f64vector 4 0))
+ (c (make-shared-array (make-f64vector 8 0)
+ (lambda (i) (list (+ 1 (* 2 i)))) 4)))
+ (begin
+ (random:normal-vector! b (random-state-from-platform))
+ (random:normal-vector! c (random-state-from-platform))
+ (and (not (equal? a b)) (not (equal? a c)))))))
--
1.8.2
[-- Attachment #18: 0017-vector-ref-vector-set-reject-non-vector-args.patch --]
[-- Type: application/octet-stream, Size: 2612 bytes --]
From 148805a550f716cfe1b5b38fdb0a85979ae88b25 Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Thu, 11 Apr 2013 18:28:19 +0200
Subject: [PATCH 17/22] vector-ref, vector-set! reject non vector? args
* libguile/vectors.c: (scm_c_vector_ref, scm_c_vector_set_x):
throw type error if v is not vector?.
---
libguile/vectors.c | 50 +-------------------------------------------------
1 file changed, 1 insertion(+), 49 deletions(-)
diff --git a/libguile/vectors.c b/libguile/vectors.c
index 775aa80..94951b0 100644
--- a/libguile/vectors.c
+++ b/libguile/vectors.c
@@ -213,27 +213,6 @@ scm_c_vector_ref (SCM v, size_t k)
return elt;
}
- else if (SCM_I_ARRAYP (v) && SCM_I_ARRAY_NDIM (v) == 1)
- {
- scm_t_array_dim *dim = SCM_I_ARRAY_DIMS (v);
- SCM vv = SCM_I_ARRAY_V (v);
- if (SCM_I_IS_VECTOR (vv))
- {
- register SCM elt;
-
- if (k >= dim->ubnd - dim->lbnd + 1)
- scm_out_of_range (NULL, scm_from_size_t (k));
- k = SCM_I_ARRAY_BASE (v) + k*dim->inc;
- elt = (SCM_I_VECTOR_ELTS (vv))[k];
-
- if (SCM_UNPACK (elt) == 0 && (SCM_I_WVECTP (vv)))
- /* ELT was a weak pointer and got nullified by the GC. */
- return SCM_BOOL_F;
-
- return elt;
- }
- scm_wrong_type_arg_msg (NULL, 0, v, "non-uniform vector");
- }
else
SCM_WTA_DISPATCH_2 (g_vector_ref, v, scm_from_size_t (k), 2, NULL);
}
@@ -275,35 +254,8 @@ scm_c_vector_set_x (SCM v, size_t k, SCM obj)
SCM_I_REGISTER_DISAPPEARING_LINK ((void **) link, SCM2PTR (obj));
}
}
- else if (SCM_I_ARRAYP (v) && SCM_I_ARRAY_NDIM (v) == 1)
- {
- scm_t_array_dim *dim = SCM_I_ARRAY_DIMS (v);
- SCM vv = SCM_I_ARRAY_V (v);
- if (SCM_I_IS_VECTOR (vv))
- {
- if (k >= dim->ubnd - dim->lbnd + 1)
- scm_out_of_range (NULL, scm_from_size_t (k));
- k = SCM_I_ARRAY_BASE (v) + k*dim->inc;
- (SCM_I_VECTOR_WELTS (vv))[k] = obj;
-
- if (SCM_I_WVECTP (vv))
- {
- /* Make it a weak pointer. */
- SCM *link = & SCM_I_VECTOR_WELTS (vv)[k];
- SCM_I_REGISTER_DISAPPEARING_LINK ((void **) link, SCM2PTR (obj));
- }
- }
- else
- scm_wrong_type_arg_msg (NULL, 0, v, "non-uniform vector");
- }
else
- {
- if (SCM_UNPACK (g_vector_set_x))
- scm_apply_generic (g_vector_set_x,
- scm_list_3 (v, scm_from_size_t (k), obj));
- else
- scm_wrong_type_arg_msg (NULL, 0, v, "vector");
- }
+ scm_wrong_type_arg_msg (NULL, 0, v, "vector");
}
SCM_DEFINE (scm_make_vector, "make-vector", 1, 1, 0,
--
1.8.2
[-- Attachment #19: 0018-vector-length-rejects-non-vector-arg.patch --]
[-- Type: application/octet-stream, Size: 2069 bytes --]
From 934d9f2c167eaed58343cc8707abe6d0538271aa Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Thu, 11 Apr 2013 19:32:23 +0200
Subject: [PATCH 18/22] vector-length rejects non vector? arg
* libguile/vectors.c
- scm_c_vector_length: error if SCM_I_IS_VECTOR (v) fails.
- scm_vector_length: Documentation for vector-length.
---
libguile/vectors.c | 32 +++++++++++++++-----------------
1 file changed, 15 insertions(+), 17 deletions(-)
diff --git a/libguile/vectors.c b/libguile/vectors.c
index 94951b0..46ee934 100644
--- a/libguile/vectors.c
+++ b/libguile/vectors.c
@@ -104,31 +104,29 @@ SCM_DEFINE (scm_vector_p, "vector?", 1, 0, 0,
}
#undef FUNC_NAME
-SCM_GPROC (s_vector_length, "vector-length", 1, 0, 0, scm_vector_length, g_vector_length);
-/* Returns the number of elements in @var{vector} as an exact integer. */
-SCM
-scm_vector_length (SCM v)
-{
- if (SCM_I_IS_VECTOR (v))
- return scm_from_size_t (SCM_I_VECTOR_LENGTH (v));
- else if (SCM_I_ARRAYP (v) && SCM_I_ARRAY_NDIM (v) == 1)
- {
- scm_t_array_dim *dim = SCM_I_ARRAY_DIMS (v);
- return scm_from_size_t (dim->ubnd - dim->lbnd + 1);
- }
- else
- SCM_WTA_DISPATCH_1 (g_vector_length, v, 1, NULL);
-}
-
size_t
scm_c_vector_length (SCM v)
{
if (SCM_I_IS_VECTOR (v))
return SCM_I_VECTOR_LENGTH (v);
else
- return scm_to_size_t (scm_vector_length (v));
+ scm_wrong_type_arg_msg (NULL, 0, v, "vector");
}
+SCM_DEFINE (scm_vector_length, "vector-length", 1, 0, 0,
+ (SCM v),
+ "Return the number of elements in vector @var{v} as an exact\n"
+ "integer.\n"
+ "\n"
+ "@lisp\n"
+ "(vector-length #(a b c)) @result{} 3\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_vector_length
+{
+ return scm_from_size_t (scm_c_vector_length (v));
+}
+#undef FUNC_NAME
+
SCM_REGISTER_PROC (s_list_to_vector, "list->vector", 1, 0, 0, scm_vector);
/*
"Return a newly created vector initialized to the elements of"
--
1.8.2
[-- Attachment #20: 0019-Online-documentation-for-vector-ref-vector-set.patch --]
[-- Type: application/octet-stream, Size: 5049 bytes --]
From 677b5b5aacd228c3e833bb09fe2524912f26b23c Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Thu, 11 Apr 2013 19:38:19 +0200
Subject: [PATCH 19/22] Online documentation for vector-ref, vector-set!
* libguile/vectors.c: (scm_vector_ref, scm_vector_set!): embed the
comments as documentation.
---
libguile/vectors.c | 84 ++++++++++++++++++++++++------------------------------
1 file changed, 38 insertions(+), 46 deletions(-)
diff --git a/libguile/vectors.c b/libguile/vectors.c
index 46ee934..82f79eb 100644
--- a/libguile/vectors.c
+++ b/libguile/vectors.c
@@ -136,9 +136,8 @@ SCM_REGISTER_PROC (s_list_to_vector, "list->vector", 1, 0, 0, scm_vector);
"(list->vector '(dididit dah)) @result{} #(dididit dah)\n"
"@end lisp")
*/
-SCM_DEFINE (scm_vector, "vector", 0, 0, 1,
+SCM_DEFINE (scm_vector, "vector", 0, 0, 1,
(SCM l),
- "@deffnx {Scheme Procedure} list->vector l\n"
"Return a newly allocated vector composed of the\n"
"given arguments. Analogous to @code{list}.\n"
"\n"
@@ -170,30 +169,6 @@ SCM_DEFINE (scm_vector, "vector", 0, 0, 1,
}
#undef FUNC_NAME
-SCM_GPROC (s_vector_ref, "vector-ref", 2, 0, 0, scm_vector_ref, g_vector_ref);
-
-/*
- "@var{k} must be a valid index of @var{vector}.\n"
- "@samp{Vector-ref} returns the contents of element @var{k} of\n"
- "@var{vector}.\n\n"
- "@lisp\n"
- "(vector-ref '#(1 1 2 3 5 8 13 21) 5) @result{} 8\n"
- "(vector-ref '#(1 1 2 3 5 8 13 21)\n"
- " (let ((i (round (* 2 (acos -1)))))\n"
- " (if (inexact? i)\n"
- " (inexact->exact i)\n"
- " i))) @result{} 13\n"
- "@end lisp"
-*/
-
-SCM
-scm_vector_ref (SCM v, SCM k)
-#define FUNC_NAME s_vector_ref
-{
- return scm_c_vector_ref (v, scm_to_size_t (k));
-}
-#undef FUNC_NAME
-
SCM
scm_c_vector_ref (SCM v, size_t k)
{
@@ -212,38 +187,36 @@ scm_c_vector_ref (SCM v, size_t k)
return elt;
}
else
- SCM_WTA_DISPATCH_2 (g_vector_ref, v, scm_from_size_t (k), 2, NULL);
+ scm_wrong_type_arg_msg (NULL, 0, v, "vector");
}
-SCM_GPROC (s_vector_set_x, "vector-set!", 3, 0, 0, scm_vector_set_x, g_vector_set_x);
-
-/* "@var{k} must be a valid index of @var{vector}.\n"
- "@code{Vector-set!} stores @var{obj} in element @var{k} of @var{vector}.\n"
- "The value returned by @samp{vector-set!} is unspecified.\n"
- "@lisp\n"
- "(let ((vec (vector 0 '(2 2 2 2) "Anna")))\n"
- " (vector-set! vec 1 '("Sue" "Sue"))\n"
- " vec) @result{} #(0 ("Sue" "Sue") "Anna")\n"
- "(vector-set! '#(0 1 2) 1 "doe") @result{} @emph{error} ; constant vector\n"
- "@end lisp"
-*/
-
-SCM
-scm_vector_set_x (SCM v, SCM k, SCM obj)
-#define FUNC_NAME s_vector_set_x
+SCM_DEFINE (scm_vector_ref, "vector-ref", 2, 0, 0,
+ (SCM v, SCM k),
+ "@var{k} must be a valid index of @var{vector}.\n"
+ "@samp{vector-ref} returns the contents of element @var{k} of\n"
+ "@var{vector}.\n\n"
+ "@lisp\n"
+ "(vector-ref '#(1 1 2 3 5 8 13 21) 5) @result{} 8\n"
+ "(vector-ref '#(1 1 2 3 5 8 13 21)\n"
+ " (let ((i (round (* 2 (acos -1)))))\n"
+ " (if (inexact? i)\n"
+ " (inexact->exact i)\n"
+ " i))) @result{} 13\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_vector_ref
{
- scm_c_vector_set_x (v, scm_to_size_t (k), obj);
- return SCM_UNSPECIFIED;
+ return scm_c_vector_ref (v, scm_to_size_t (k));
}
#undef FUNC_NAME
+
void
scm_c_vector_set_x (SCM v, size_t k, SCM obj)
{
if (SCM_I_IS_VECTOR (v))
{
if (k >= SCM_I_VECTOR_LENGTH (v))
- scm_out_of_range (NULL, scm_from_size_t (k));
+ scm_out_of_range (NULL, scm_from_size_t (k));
(SCM_I_VECTOR_WELTS(v))[k] = obj;
if (SCM_I_WVECTP (v))
{
@@ -256,6 +229,25 @@ scm_c_vector_set_x (SCM v, size_t k, SCM obj)
scm_wrong_type_arg_msg (NULL, 0, v, "vector");
}
+SCM_DEFINE (scm_vector_set_x, "vector-set!", 3, 0, 0,
+ (SCM v, SCM k, SCM obj),
+ "@var{k} must be a valid index of @var{vector}.\n"
+ "@code{Vector-set!} stores @var{obj} in element @var{k} of @var{vector}.\n"
+ "The value returned by @samp{vector-set!} is unspecified.\n"
+ "@lisp\n"
+ "(let ((vec (vector 0 '(2 2 2 2) \"Anna\")))\n"
+ " (vector-set! vec 1 '(\"Sue\" \"Sue\"))\n"
+ " vec) @result{} #(0 (\"Sue\" \"Sue\") \"Anna\")\n"
+ "(vector-set! '#(0 1 2) 1 \"doe\") @result{} @emph{error} ; constant vector\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_vector_set_x
+{
+ scm_c_vector_set_x (v, scm_to_size_t (k), obj);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
SCM_DEFINE (scm_make_vector, "make-vector", 1, 1, 0,
(SCM k, SCM fill),
"Return a newly allocated vector of @var{k} elements. If a\n"
--
1.8.2
[-- Attachment #21: 0020-Fix-rank-1-indirection-in-array-map.c.patch --]
[-- Type: application/octet-stream, Size: 1202 bytes --]
From 3c51bae1bb7590120c0ba7ae660f2fdd85f82dd4 Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Thu, 11 Apr 2013 22:49:22 +0200
Subject: [PATCH 20/22] Fix rank-1 indirection in array-map.c
* array-map.c: (AREF, ASET): fix buggy indirection carried over
from old generalized_vector-ref/set!.
---
libguile/array-map.c | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/libguile/array-map.c b/libguile/array-map.c
index 426103c..1bf309c 100644
--- a/libguile/array-map.c
+++ b/libguile/array-map.c
@@ -54,7 +54,7 @@ AREF (SCM v, size_t pos)
scm_t_array_handle h;
SCM ret;
scm_array_get_handle (v, &h);
- pos = h.base + h.dims[0].lbnd + pos * h.dims[0].inc;
+ pos = h.base + (pos - h.dims[0].lbnd) * h.dims[0].inc;
ret = h.impl->vref (&h, pos);
scm_array_handle_release (&h);
return ret;
@@ -65,7 +65,7 @@ ASET (SCM v, size_t pos, SCM val)
{
scm_t_array_handle h;
scm_array_get_handle (v, &h);
- pos = h.base + h.dims[0].lbnd + pos * h.dims[0].inc;
+ pos = h.base + (pos - h.dims[0].lbnd) * h.dims[0].inc;
h.impl->vset (&h, pos, val);
scm_array_handle_release (&h);
}
--
1.8.2
[-- Attachment #22: 0021-Match-uniform_vector_elements-with-vector_elements.patch --]
[-- Type: application/octet-stream, Size: 8702 bytes --]
From 33aa874f41fc03f2ad9460948c1439b84924fe1e Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Fri, 12 Apr 2013 15:04:52 +0200
Subject: [PATCH 21/22] Match uniform_vector_elements with vector_elements
* libguile/vectors.c
- (scm_vector_writable_elements): allow any non-uniform rank 1 array,
after the doc. Match the implementation with scm_uniform_vector_elements.
- (scm_vector_elements): after the above.
* libguile/uniform.c
- (scm_uniform_vector_writable_elements): ditto for uniform rank 1 arrays.
* libguile/sort.c
- revert the changes in 7a6fd9, except for the argument type test; allow
what scm_vector_(writable_)elements allows.
---
libguile/sort.c | 57 +++++++++++++++++++-----------------------------------
libguile/uniform.c | 24 +++++++++++------------
libguile/vectors.c | 40 ++++++++++++++++----------------------
3 files changed, 49 insertions(+), 72 deletions(-)
diff --git a/libguile/sort.c b/libguile/sort.c
index 1b47afc..0dd8c8c 100644
--- a/libguile/sort.c
+++ b/libguile/sort.c
@@ -77,25 +77,18 @@ SCM_DEFINE (scm_restricted_vector_sort_x, "restricted-vector-sort!", 4, 0, 0,
#define FUNC_NAME s_scm_restricted_vector_sort_x
{
size_t vlen, spos, len;
+ ssize_t vinc;
scm_t_array_handle handle;
- scm_t_array_dim *dim;
-
SCM *velts;
- if (!scm_is_array (vec) || 1 != scm_c_array_rank (vec))
- SCM_WRONG_TYPE_ARG (1, vec);
-
- scm_array_get_handle (vec, &handle);
- velts = scm_array_handle_writable_elements (&handle);
- dim = scm_array_handle_dims (&handle);
- vlen = dim->ubnd - dim->lbnd + 1;
+ velts = scm_vector_writable_elements (vec, &handle, &vlen, &vinc);
spos = scm_to_unsigned_integer (startpos, 0, vlen);
len = scm_to_unsigned_integer (endpos, spos, vlen) - spos;
- if (dim->inc == 1)
- quicksort1 (velts + spos, len, less);
+ if (vinc == 1)
+ quicksort1 (velts + spos*vinc, len, less);
else
- quicksort (velts + spos*dim->inc, len, dim->inc, less);
+ quicksort (velts + spos*vinc, len, vinc, less);
scm_array_handle_release (&handle);
@@ -151,25 +144,19 @@ SCM_DEFINE (scm_sorted_p, "sorted?", 2, 0, 0,
size_t i, len;
ssize_t inc;
const SCM *elts;
- SCM result = SCM_BOOL_T;
elts = scm_vector_elements (items, &handle, &len, &inc);
-
for (i = 1; i < len; i++, elts += inc)
{
if (scm_is_true (scm_call_2 (less, elts[inc], elts[0])))
{
- result = SCM_BOOL_F;
- break;
+ scm_array_handle_release (&handle);
+ return SCM_BOOL_F;
}
}
-
scm_array_handle_release (&handle);
-
- return result;
+ return SCM_BOOL_T;
}
-
- return SCM_BOOL_F;
}
#undef FUNC_NAME
@@ -496,40 +483,36 @@ SCM_DEFINE (scm_stable_sort_x, "stable-sort!", 2, 0, 0,
SCM_VALIDATE_LIST_COPYLEN (1, items, len);
return scm_merge_list_step (&items, less, len);
}
- else if (scm_is_array (items) && 1 == scm_c_array_rank (items))
+ else
{
- scm_t_array_handle temp_handle, items_handle;
- scm_t_array_dim *dim;
- SCM temp, *temp_elts, *items_elts;
+ scm_t_array_handle temp_handle, vec_handle;
+ SCM temp, *temp_elts, *vec_elts;
size_t len;
+ ssize_t inc;
- scm_array_get_handle (items, &items_handle);
- items_elts = scm_array_handle_writable_elements (&items_handle);
- dim = scm_array_handle_dims (&items_handle);
- len = dim->ubnd - dim->lbnd + 1;
+ vec_elts = scm_vector_writable_elements (items, &vec_handle,
+ &len, &inc);
if (len == 0) {
- scm_array_handle_release (&items_handle);
+ scm_array_handle_release (&vec_handle);
return items;
}
temp = scm_c_make_vector (len, SCM_UNDEFINED);
- scm_array_get_handle (temp, &temp_handle);
- temp_elts = scm_array_handle_writable_elements (&temp_handle);
+ temp_elts = scm_vector_writable_elements (temp, &temp_handle,
+ NULL, NULL);
- scm_merge_vector_step (items_elts, temp_elts, less, 0, len-1, dim->inc);
+ scm_merge_vector_step (vec_elts, temp_elts, less, 0, len-1, inc);
scm_array_handle_release (&temp_handle);
- scm_array_handle_release (&items_handle);
+ scm_array_handle_release (&vec_handle);
return items;
}
- else
- SCM_WRONG_TYPE_ARG (1, items);
}
#undef FUNC_NAME
-SCM_DEFINE (scm_stable_sort, "stable-sort", 2, 0, 0,
+SCM_DEFINE (scm_stable_sort, "stable-sort", 2, 0, 0,
(SCM items, SCM less),
"Sort the sequence @var{items}, which may be a list or a\n"
"vector. @var{less} is used for comparing the sequence elements.\n"
diff --git a/libguile/uniform.c b/libguile/uniform.c
index dc6c024..2e684d6 100644
--- a/libguile/uniform.c
+++ b/libguile/uniform.c
@@ -215,22 +215,14 @@ SCM_DEFINE (scm_uniform_vector_to_list, "uniform-vector->list", 1, 0, 0,
}
#undef FUNC_NAME
-const void *
-scm_uniform_vector_elements (SCM uvec,
- scm_t_array_handle *h,
- size_t *lenp, ssize_t *incp)
-{
- return scm_uniform_vector_writable_elements (uvec, h, lenp, incp);
-}
-
void *
scm_uniform_vector_writable_elements (SCM uvec,
scm_t_array_handle *h,
size_t *lenp, ssize_t *incp)
{
- void *ret;
- if (!scm_is_uniform_vector (uvec))
- scm_wrong_type_arg_msg (NULL, 0, uvec, "uniform vector");
+ void * ret;
+ if (!scm_is_array (uvec) || 1 != scm_c_array_rank (uvec))
+ scm_wrong_type_arg_msg (NULL, 0, uvec, "rank 1 uniform array");
scm_array_get_handle (uvec, h);
/* FIXME nonlocal exit */
ret = scm_array_handle_uniform_writable_elements (h);
@@ -243,7 +235,15 @@ scm_uniform_vector_writable_elements (SCM uvec,
return ret;
}
-SCM_DEFINE (scm_uniform_vector_length, "uniform-vector-length", 1, 0, 0,
+const void *
+scm_uniform_vector_elements (SCM uvec,
+ scm_t_array_handle *h,
+ size_t *lenp, ssize_t *incp)
+{
+ return scm_uniform_vector_writable_elements (uvec, h, lenp, incp);
+}
+
+SCM_DEFINE (scm_uniform_vector_length, "uniform-vector-length", 1, 0, 0,
(SCM v),
"Return the number of elements in the uniform vector @var{v}.")
#define FUNC_NAME s_scm_uniform_vector_length
diff --git a/libguile/vectors.c b/libguile/vectors.c
index 82f79eb..94399b0 100644
--- a/libguile/vectors.c
+++ b/libguile/vectors.c
@@ -56,45 +56,39 @@ scm_is_simple_vector (SCM obj)
return SCM_I_IS_VECTOR (obj);
}
-const SCM *
-scm_vector_elements (SCM vec, scm_t_array_handle *h,
- size_t *lenp, ssize_t *incp)
-{
- if (SCM_I_WVECTP (vec))
- /* FIXME: We should check each (weak) element of the vector for NULL and
- convert it to SCM_BOOL_F. */
- abort ();
-
- scm_generalized_vector_get_handle (vec, h);
- if (lenp)
- {
- scm_t_array_dim *dim = scm_array_handle_dims (h);
- *lenp = dim->ubnd - dim->lbnd + 1;
- *incp = dim->inc;
- }
- return scm_array_handle_elements (h);
-}
-
SCM *
scm_vector_writable_elements (SCM vec, scm_t_array_handle *h,
size_t *lenp, ssize_t *incp)
{
+ SCM * ret;
+
if (SCM_I_WVECTP (vec))
/* FIXME: We should check each (weak) element of the vector for NULL and
convert it to SCM_BOOL_F. */
abort ();
- scm_generalized_vector_get_handle (vec, h);
+ if (!scm_is_array (vec) || 1 != scm_c_array_rank (vec))
+ scm_wrong_type_arg_msg (NULL, 0, vec, "rank 1 array");
+ scm_array_get_handle (vec, h);
+ /* FIXME nonlocal exit */
+ ret = scm_array_handle_writable_elements (h);
if (lenp)
{
scm_t_array_dim *dim = scm_array_handle_dims (h);
*lenp = dim->ubnd - dim->lbnd + 1;
*incp = dim->inc;
}
- return scm_array_handle_writable_elements (h);
+ return ret;
+}
+
+const SCM *
+scm_vector_elements (SCM vec, scm_t_array_handle *h,
+ size_t *lenp, ssize_t *incp)
+{
+ return scm_vector_writable_elements (vec, h, lenp, incp);
}
-SCM_DEFINE (scm_vector_p, "vector?", 1, 0, 0,
+SCM_DEFINE (scm_vector_p, "vector?", 1, 0, 0,
(SCM obj),
"Return @code{#t} if @var{obj} is a vector, otherwise return\n"
"@code{#f}.")
@@ -156,7 +150,7 @@ SCM_DEFINE (scm_vector, "vector", 0, 0, 1,
res = scm_c_make_vector (len, SCM_UNSPECIFIED);
data = scm_vector_writable_elements (res, &handle, NULL, NULL);
i = 0;
- while (scm_is_pair (l) && i < len)
+ while (scm_is_pair (l) && i < len)
{
data[i] = SCM_CAR (l);
l = SCM_CDR (l);
--
1.8.2
[-- Attachment #23: 0022-Use-underlying-vector-implementation-directly-in-arr.patch --]
[-- Type: application/octet-stream, Size: 6782 bytes --]
From 1aa7e85068e02fa4c99ffac13deefab125d88c56 Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Fri, 12 Apr 2013 17:50:09 +0200
Subject: [PATCH 22/22] Use underlying vector implementation directly in array
handles
* libguile/array-handle.c
- scm_array_get_handle: if the object is an array, point impl to
the underlying vector instead of array impl, then fix the axes. Avoid
calling scm_i_array_implementation_for_obj twice.
* libguile/arrays.c
- array_handle_ref, array_handle_set, array_get_handle: remove.
* libguile/bitvectors.c, libguile/bytevectors.c, libguile/strings.c,
libguile/vectors.c: fix base = 0 in the array handle.
* libguile/vectors.c: (vector_handle_set, vector_handle_ref): do not
use h->dims.
---
libguile/array-handle.c | 39 ++++++++++++++++++++++++++-------------
libguile/arrays.c | 47 +----------------------------------------------
libguile/bitvectors.c | 1 +
libguile/bytevectors.c | 1 +
libguile/strings.c | 1 +
libguile/vectors.c | 5 +++--
6 files changed, 33 insertions(+), 61 deletions(-)
diff --git a/libguile/array-handle.c b/libguile/array-handle.c
index 08778f3..f298f28 100644
--- a/libguile/array-handle.c
+++ b/libguile/array-handle.c
@@ -61,19 +61,32 @@ scm_i_array_implementation_for_obj (SCM obj)
void
scm_array_get_handle (SCM array, scm_t_array_handle *h)
{
- scm_t_array_implementation *impl = scm_i_array_implementation_for_obj (array);
- if (!impl)
- scm_wrong_type_arg_msg (NULL, 0, array, "array");
- h->array = array;
- h->impl = impl;
- h->base = 0;
- h->ndims = 0;
- h->dims = NULL;
- h->element_type = SCM_ARRAY_ELEMENT_TYPE_SCM; /* have to default to
- something... */
- h->elements = NULL;
- h->writable_elements = NULL;
- h->impl->get_handle (array, h);
+ scm_t_array_implementation *impl;
+ if (SCM_I_ARRAYP (array))
+ {
+ SCM v = SCM_I_ARRAY_V (array);
+ impl = scm_i_array_implementation_for_obj (v);
+ h->impl = impl;
+ h->impl->get_handle (v, h);
+ /* this works because the v's impl NEVER uses dims/ndims/base */
+ h->dims = SCM_I_ARRAY_DIMS (array);
+ h->ndims = SCM_I_ARRAY_NDIM (array);
+ h->base = SCM_I_ARRAY_BASE (array);
+ }
+ else
+ {
+ impl = scm_i_array_implementation_for_obj (array);
+ if (impl)
+ {
+ h->impl = impl;
+ /* see bitvector_get_handle, string_get_handle,
+ bytevector_get_handle, vector_get_handle, only ever called
+ from here */
+ h->impl->get_handle (array, h);
+ }
+ else
+ scm_wrong_type_arg_msg (NULL, 0, array, "array");
+ }
}
ssize_t
diff --git a/libguile/arrays.c b/libguile/arrays.c
index 191d02d..6397067 100644
--- a/libguile/arrays.c
+++ b/libguile/arrays.c
@@ -817,52 +817,7 @@ scm_i_print_array (SCM array, SCM port, scm_print_state *pstate)
return scm_i_print_array_dimension (&h, 0, 0, port, pstate);
}
-static SCM
-array_handle_ref (scm_t_array_handle *hh, size_t pos)
-{
- scm_t_array_handle h;
- SCM ret;
- scm_array_get_handle (SCM_I_ARRAY_V (hh->array), &h);
- ret = h.impl->vref (&h, pos);
- scm_array_handle_release (&h);
- return ret;
-}
-
-static void
-array_handle_set (scm_t_array_handle *hh, size_t pos, SCM val)
-{
- scm_t_array_handle h;
- scm_array_get_handle (SCM_I_ARRAY_V (hh->array), &h);
- h.impl->vset (&h, pos, val);
- scm_array_handle_release (&h);
-}
-
-/* FIXME: should be handle for vect? maybe not, because of dims */
-static void
-array_get_handle (SCM array, scm_t_array_handle *h)
-{
- scm_t_array_handle vh;
- scm_array_get_handle (SCM_I_ARRAY_V (array), &vh);
- if (vh.dims[0].inc != 1 || vh.dims[0].lbnd != 0 || vh.base != 0)
- {
- fprintf(stderr, "INC %ld, %ld", vh.dims[0].inc, vh.dims[0].lbnd);
- fflush(stderr);
- abort();
- }
- h->element_type = vh.element_type;
- h->elements = vh.elements;
- h->writable_elements = vh.writable_elements;
- scm_array_handle_release (&vh);
-
- h->dims = SCM_I_ARRAY_DIMS (array);
- h->ndims = SCM_I_ARRAY_NDIM (array);
- h->base = SCM_I_ARRAY_BASE (array);
-}
-
-SCM_ARRAY_IMPLEMENTATION (scm_tc7_array,
- 0x7f,
- array_handle_ref, array_handle_set,
- array_get_handle)
+SCM_ARRAY_IMPLEMENTATION (scm_tc7_array, 0x7f, NULL, NULL, NULL)
void
scm_init_arrays ()
diff --git a/libguile/bitvectors.c b/libguile/bitvectors.c
index 0158490..c05a327 100644
--- a/libguile/bitvectors.c
+++ b/libguile/bitvectors.c
@@ -868,6 +868,7 @@ bitvector_handle_set (scm_t_array_handle *h, size_t pos, SCM val)
static void
bitvector_get_handle (SCM bv, scm_t_array_handle *h)
{
+ h->base = 0;
h->array = bv;
h->ndims = 1;
h->dims = &h->dim0;
diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c
index cf41f2f..fc576e7 100644
--- a/libguile/bytevectors.c
+++ b/libguile/bytevectors.c
@@ -2214,6 +2214,7 @@ bv_handle_set_x (scm_t_array_handle *h, size_t index, SCM val)
static void
bytevector_get_handle (SCM v, scm_t_array_handle *h)
{
+ h->base = 0;
h->array = v;
h->ndims = 1;
h->dims = &h->dim0;
diff --git a/libguile/strings.c b/libguile/strings.c
index 1b241e5..df60bd3 100644
--- a/libguile/strings.c
+++ b/libguile/strings.c
@@ -2395,6 +2395,7 @@ string_handle_set (scm_t_array_handle *h, size_t index, SCM val)
static void
string_get_handle (SCM v, scm_t_array_handle *h)
{
+ h->base = 0;
h->array = v;
h->ndims = 1;
h->dims = &h->dim0;
diff --git a/libguile/vectors.c b/libguile/vectors.c
index 94399b0..ef6b02e 100644
--- a/libguile/vectors.c
+++ b/libguile/vectors.c
@@ -530,7 +530,7 @@ SCM_DEFINE (scm_vector_move_right_x, "vector-move-right!", 5, 0, 0,
static SCM
vector_handle_ref (scm_t_array_handle *h, size_t idx)
{
- if (idx > h->dims[0].ubnd)
+ if (idx > h->dim0.ubnd)
scm_out_of_range ("vector-handle-ref", scm_from_size_t (idx));
return ((SCM*)h->elements)[idx];
}
@@ -538,7 +538,7 @@ vector_handle_ref (scm_t_array_handle *h, size_t idx)
static void
vector_handle_set (scm_t_array_handle *h, size_t idx, SCM val)
{
- if (idx > h->dims[0].ubnd)
+ if (idx > h->dim0.ubnd)
scm_out_of_range ("vector-handle-set!", scm_from_size_t (idx));
((SCM*)h->writable_elements)[idx] = val;
}
@@ -546,6 +546,7 @@ vector_handle_set (scm_t_array_handle *h, size_t idx, SCM val)
static void
vector_get_handle (SCM v, scm_t_array_handle *h)
{
+ h->base = 0;
h->array = v;
h->ndims = 1;
h->dims = &h->dim0;
--
1.8.2
next prev parent reply other threads:[~2013-04-13 0:40 UTC|newest]
Thread overview: 19+ messages / expand[flat|nested] mbox.gz Atom feed top
[not found] <mailman.1287634.1365761713.854.guile-devel@gnu.org>
2013-04-12 12:37 ` vectors are something else Daniel Llorens
2013-04-12 14:06 ` Daniel Hartwig
2013-04-13 0:40 ` Daniel Llorens [this message]
[not found] <mailman.1288755.1365813667.854.guile-devel@gnu.org>
2013-04-15 11:29 ` Daniel Llorens
2013-04-15 12:28 ` Daniel Hartwig
2013-04-15 14:08 ` Daniel Llorens
2013-04-15 14:17 ` Daniel Hartwig
2013-04-16 2:00 ` Mark H Weaver
2013-04-16 4:10 ` Daniel Llorens
2013-04-16 6:19 ` Mark H Weaver
2013-04-16 8:31 ` Daniel Llorens
[not found] <mailman.197.1365782461.8676.guile-devel@gnu.org>
2013-04-12 23:12 ` Daniel Llorens
2013-04-10 23:07 Daniel Llorens
2013-04-11 7:29 ` Daniel Llorens
2013-04-11 23:53 ` Daniel Hartwig
2013-04-12 7:23 ` Daniel Llorens
2013-04-12 10:15 ` Daniel Hartwig
2013-04-12 10:41 ` Daniel Hartwig
2013-04-12 21:43 ` Mark H Weaver
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/guile/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=8A58516D-20EE-4173-A5E7-DD5C8DB525E3@bluewin.ch \
--to=daniel.llorens@bluewin.ch \
--cc=guile-devel@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).