[Guile-commits] 03/11: Avoid unneeded internal use of array handles

[Daniel Llorens]

lloda pushed a commit to branch lloda-squash0
in repository guile.

commit 8748dc383829d852077b45f98e6de6f7151d0cbb
Author: Daniel Llorens <address@hidden>
Date:   Mon Feb 9 12:11:52 2015 +0100

    Avoid unneeded internal use of array handles
    
    * libguile/arrays.c (scm_shared_array_root): Adopt uniform check order.
    
      (scm_shared_array_offset, scm_shared_array_increments): Use the array
      fields directly just as scm_shared_array_root does.
    
      (scm_c_array_rank): Moved from libguile/generalized-arrays.c. Don't
      use array handles, but follow the same type check sequence as the
      other array functions (shared-array-root, etc).
    
      (scm_array_rank): Moved from libguile/generalized-arrays.h.
    
    * libguile/arrays.h: Move prototypes here.
    
    * test-suite/tests/arrays.test: Tests for shared-array-offset,
      shared-array-increments.
---
 libguile/arrays.c             |   65 +++++++++++++++++++++++------------
 libguile/arrays.h             |    3 ++
 libguile/generalized-arrays.c |   21 ------------
 libguile/generalized-arrays.h |    3 --
 test-suite/tests/arrays.test  |   76 ++++++++++++++++++++++++++++++++++-------
 5 files changed, 109 insertions(+), 59 deletions(-)

diff --git a/libguile/arrays.c b/libguile/arrays.c
index 3cb547f..fb522e1 100644
--- a/libguile/arrays.c
+++ b/libguile/arrays.c
@@ -64,6 +64,27 @@
   (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) & 
~(SCM_I_ARRAY_FLAG_CONTIGUOUS << 16)))
 
 
+size_t
+scm_c_array_rank (SCM array)
+{
+  if (SCM_I_ARRAYP (array))
+    return SCM_I_ARRAY_NDIM (array);
+  else if (scm_is_array (array))
+    return 1;
+  else
+    scm_wrong_type_arg_msg ("array-rank", SCM_ARG1, array, "array");
+}
+
+SCM_DEFINE (scm_array_rank, "array-rank", 1, 0, 0,
+           (SCM array),
+           "Return the number of dimensions of the array @var{array.}\n")
+#define FUNC_NAME s_scm_array_rank
+{
+  return scm_from_size_t (scm_c_array_rank (array));
+}
+#undef FUNC_NAME
+
+
 SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1, 0, 0,
            (SCM ra),
            "Return the root vector of a shared array.")
@@ -71,10 +92,10 @@ SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1, 
0, 0,
 {
   if (SCM_I_ARRAYP (ra))
     return SCM_I_ARRAY_V (ra);
-  else if (!scm_is_array (ra))
-    scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array");
-  else
+  else if (scm_is_array (ra))
     return ra;
+  else
+    scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array");
 }
 #undef FUNC_NAME
 
@@ -84,13 +105,12 @@ SCM_DEFINE (scm_shared_array_offset, 
"shared-array-offset", 1, 0, 0,
            "Return the root vector index of the first element in the array.")
 #define FUNC_NAME s_scm_shared_array_offset
 {
-  scm_t_array_handle handle;
-  SCM res;
-
-  scm_array_get_handle (ra, &handle);
-  res = scm_from_size_t (handle.base);
-  scm_array_handle_release (&handle);
-  return res;
+  if (SCM_I_ARRAYP (ra))
+    return scm_from_size_t (SCM_I_ARRAY_BASE (ra));
+  else if (scm_is_array (ra))
+    return scm_from_size_t (0);
+  else
+    scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array");
 }
 #undef FUNC_NAME
 
@@ -100,18 +120,19 @@ SCM_DEFINE (scm_shared_array_increments, 
"shared-array-increments", 1, 0, 0,
            "For each dimension, return the distance between elements in the 
root vector.")
 #define FUNC_NAME s_scm_shared_array_increments
 {
-  scm_t_array_handle handle;
-  SCM res = SCM_EOL;
-  size_t k;
-  scm_t_array_dim *s;
-
-  scm_array_get_handle (ra, &handle);
-  k = scm_array_handle_rank (&handle);
-  s = scm_array_handle_dims (&handle);
-  while (k--)
-    res = scm_cons (scm_from_ssize_t (s[k].inc), res);
-  scm_array_handle_release (&handle);
-  return res;
+  if (SCM_I_ARRAYP (ra))
+    {
+      size_t k = SCM_I_ARRAY_NDIM (ra);
+      SCM res = SCM_EOL;
+      scm_t_array_dim *dims = SCM_I_ARRAY_DIMS (ra);
+      while (k--)
+        res = scm_cons (scm_from_ssize_t (dims[k].inc), res);
+      return res;
+    }
+  else if (scm_is_array (ra))
+    return scm_list_1 (scm_from_ssize_t (1));
+  else
+    scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array");
 }
 #undef FUNC_NAME
 
diff --git a/libguile/arrays.h b/libguile/arrays.h
index 4baa51e..d3e409f 100644
--- a/libguile/arrays.h
+++ b/libguile/arrays.h
@@ -50,6 +50,9 @@ SCM_API SCM scm_array_contents (SCM ra, SCM strict);
 SCM_API SCM scm_list_to_array (SCM ndim, SCM lst);
 SCM_API SCM scm_list_to_typed_array (SCM type, SCM ndim, SCM lst);
 
+SCM_API size_t scm_c_array_rank (SCM ra);
+SCM_API SCM scm_array_rank (SCM ra);
+
 /* internal. */
 
 #define SCM_I_ARRAY_FLAG_CONTIGUOUS (1 << 0)  /* currently unused */
diff --git a/libguile/generalized-arrays.c b/libguile/generalized-arrays.c
index 9a001eb..fdbdb4a 100644
--- a/libguile/generalized-arrays.c
+++ b/libguile/generalized-arrays.c
@@ -104,27 +104,6 @@ SCM_DEFINE (scm_typed_array_p, "typed-array?", 2, 0, 0,
 }
 #undef FUNC_NAME
 
-size_t
-scm_c_array_rank (SCM array)
-{
-  scm_t_array_handle handle;
-  size_t res;
-
-  scm_array_get_handle (array, &handle);
-  res = scm_array_handle_rank (&handle);
-  scm_array_handle_release (&handle);
-  return res;
-}
-
-SCM_DEFINE (scm_array_rank, "array-rank", 1, 0, 0, 
-           (SCM array),
-           "Return the number of dimensions of the array @var{array.}\n")
-#define FUNC_NAME s_scm_array_rank
-{
-  return scm_from_size_t (scm_c_array_rank (array));
-}
-#undef FUNC_NAME
-
 
 size_t
 scm_c_array_length (SCM array)
diff --git a/libguile/generalized-arrays.h b/libguile/generalized-arrays.h
index dfdb8bd..cfa6905 100644
--- a/libguile/generalized-arrays.h
+++ b/libguile/generalized-arrays.h
@@ -41,9 +41,6 @@ SCM_INTERNAL SCM scm_array_p_2 (SCM);
 SCM_API int scm_is_typed_array (SCM obj, SCM type);
 SCM_API SCM scm_typed_array_p (SCM v, SCM type);
 
-SCM_API size_t scm_c_array_rank (SCM ra);
-SCM_API SCM scm_array_rank (SCM ra);
-
 SCM_API size_t scm_c_array_length (SCM ra);
 SCM_API SCM scm_array_length (SCM ra);
 
diff --git a/test-suite/tests/arrays.test b/test-suite/tests/arrays.test
index 6f37196..c40457b 100644
--- a/test-suite/tests/arrays.test
+++ b/test-suite/tests/arrays.test
@@ -23,9 +23,13 @@
   #:use-module (srfi srfi-4)
   #:use-module (srfi srfi-4 gnu))
 
-;;;
-;;; array?
-;;;
+(define (array-row a i)
+  (make-shared-array a (lambda (j) (list i j))
+                     (cadr (array-dimensions a))))
+
+(define (array-col a j)
+  (make-shared-array a (lambda (i) (list i j))
+                     (car (array-dimensions a))))
 
 (define exception:wrong-num-indices
   (cons 'misc-error "^wrong number of indices.*"))
@@ -33,6 +37,15 @@
 (define exception:length-non-negative
   (cons 'read-error ".*array length must be non-negative.*"))
 
+(define exception:wrong-type-arg
+  (cons #t "Wrong type"))
+
+(define exception:mapping-out-of-range
+  (cons 'misc-error "^mapping out of range"))  ;; per scm_make_shared_array
+
+;;;
+;;; array?
+;;;
 
 (with-test-prefix "array?"
 
@@ -216,9 +229,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/c&e "make-shared-array"
 
   ;; this failed in guile 1.8.0
@@ -404,13 +414,57 @@
       (eq? (shared-array-root a) (shared-array-root b) (array-contents a)))))
 
 ;;;
+;;; shared-array-offset
+;;;
+
+(with-test-prefix/c&e "shared-array-offset"
+
+  (pass-if "plain vector"
+    (zero? (shared-array-offset (make-vector 4 0))))
+
+  (pass-if "plain array rank 2"
+    (zero? (shared-array-offset (make-array 0 4 4))))
+
+  (pass-if "row of rank-2 array, I"
+    (= 0 (shared-array-offset (array-row (make-array 0 5 3) 0))))
+
+  (pass-if "row of rank-2 array, II"
+    (= 4 (shared-array-offset (array-row (make-array 0 6 4) 1))))
+
+  (pass-if "col of rank-2 array, I"
+    (= 0 (shared-array-offset (array-col (make-array 0 5 3) 0))))
+
+  (pass-if "col of rank-2 array, II"
+    (= 1 (shared-array-offset (array-col (make-array 0 6 4) 1)))))
+
+
+;;;
+;;; shared-array-increments
+;;;
+
+(with-test-prefix/c&e "shared-array-increments"
+
+  (pass-if "plain vector"
+    (equal? '(1) (shared-array-increments (make-vector 4 0))))
+
+  (pass-if "plain array rank 2"
+    (equal? '(4 1) (shared-array-increments (make-array 0 3 4))))
+
+  (pass-if "plain array rank 3"
+    (equal? '(20 5 1) (shared-array-increments (make-array 0 3 4 5))))
+
+  (pass-if "row of rank-2 array"
+    (equal? '(1) (shared-array-increments (array-row (make-array 0 5 3) 0))))
+
+  (pass-if "col of rank-2 array"
+    (equal? '(3) (shared-array-increments (array-col (make-array 0 5 3) 0)))))
+
+
+;;;
 ;;; transpose-array
 ;;;
 
 ; see strings.test.
-(define exception:wrong-type-arg
-  (cons #t "Wrong type"))
-
 (with-test-prefix/c&e "transpose-array"
 
   (pass-if-exception "non array argument" exception:wrong-type-arg
@@ -821,10 +875,6 @@
 ;;; slices as generalized vectors
 ;;;
 
-(define (array-row a i)
-  (make-shared-array a (lambda (j) (list i j))
-                     (cadr (array-dimensions a))))
-
 (with-test-prefix/c&e "generalized vector slices"
   (pass-if (equal? (array-row #2u32((0 1) (2 3)) 1)
                    #u32(2 3)))