diff options
-rw-r--r-- | libguile/filesys.c | 10 | ||||
-rw-r--r-- | libguile/random.c | 6 | ||||
-rw-r--r-- | libguile/sort.c | 57 | ||||
-rw-r--r-- | libguile/stime.c | 2 | ||||
-rw-r--r-- | libguile/trees.c | 4 | ||||
-rw-r--r-- | libguile/validate.h | 4 | ||||
-rw-r--r-- | libguile/vectors.c | 9 | ||||
-rw-r--r-- | test-suite/Makefile.am | 1 | ||||
-rw-r--r-- | test-suite/tests/arrays.test | 2 | ||||
-rw-r--r-- | test-suite/tests/random.test | 55 |
10 files changed, 103 insertions, 47 deletions
diff --git a/libguile/filesys.c b/libguile/filesys.c index 8597f9096..aa3e67165 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -694,7 +694,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); @@ -755,7 +755,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); @@ -824,7 +824,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); } @@ -833,7 +833,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); } @@ -842,7 +842,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 6df2cd9df..915f17feb 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 2a36320ec..1b47afcbd 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 78539d9cd..c87692518 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 76bb68640..88adf8820 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 68ff3744d..7af698f5d 100644 --- a/libguile/validate.h +++ b/libguile/validate.h @@ -358,12 +358,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 920ead10e..8c0e15d3b 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 3ab34d6d8..01345a4a6 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -111,6 +111,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 8ad97f4b2..e0aa5ca3e 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 000000000..ab20b581d --- /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))))))) |