2015-09-08 16:57:30 +02:00
|
|
|
;;;; array-map.test --- test array mapping functions -*- scheme -*-
|
2005-01-04 00:44:37 +00:00
|
|
|
;;;;
|
2013-04-03 19:13:23 +02:00
|
|
|
;;;; Copyright (C) 2004, 2005, 2006, 2009, 2013 Free Software Foundation, Inc.
|
2005-01-04 00:44:37 +00:00
|
|
|
;;;;
|
|
|
|
|
;;;; 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
|
2009-06-17 00:22:09 +01:00
|
|
|
;;;; version 3 of the License, or (at your option) any later version.
|
2005-01-04 00:44:37 +00:00
|
|
|
;;;;
|
|
|
|
|
;;;; 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
|
2005-05-23 19:57:22 +00:00
|
|
|
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
2005-01-04 00:44:37 +00:00
|
|
|
|
2015-09-08 16:57:30 +02:00
|
|
|
(define-module (test-suite test-array-map)
|
2005-01-04 00:44:37 +00:00
|
|
|
#:use-module (test-suite lib))
|
|
|
|
|
|
2013-04-19 12:57:13 +02:00
|
|
|
(define exception:shape-mismatch
|
|
|
|
|
(cons 'misc-error ".*shape mismatch.*"))
|
|
|
|
|
|
2011-12-22 17:13:07 -05:00
|
|
|
(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))))
|
|
|
|
|
|
2005-06-10 00:27:20 +00:00
|
|
|
;;;
|
|
|
|
|
;;; array-index-map!
|
|
|
|
|
;;;
|
|
|
|
|
|
|
|
|
|
(with-test-prefix "array-index-map!"
|
|
|
|
|
|
2013-04-19 10:42:40 +02:00
|
|
|
(pass-if "basic test"
|
|
|
|
|
(let ((nlst '()))
|
|
|
|
|
(array-index-map! (make-array #f '(1 1))
|
|
|
|
|
(lambda (n)
|
|
|
|
|
(set! nlst (cons n nlst))))
|
|
|
|
|
(equal? nlst '(1))))
|
|
|
|
|
|
|
|
|
|
(with-test-prefix "empty arrays"
|
|
|
|
|
|
|
|
|
|
(pass-if "all axes empty"
|
|
|
|
|
(array-index-map! (make-typed-array 'f64 0 0 0) (const 0))
|
|
|
|
|
(array-index-map! (make-typed-array 'b #t 0 0) (const #t))
|
2013-04-19 12:57:13 +02:00
|
|
|
(array-index-map! (make-typed-array #t 0 0 0) (const 0))
|
|
|
|
|
#t)
|
2013-04-19 10:42:40 +02:00
|
|
|
|
|
|
|
|
(pass-if "last axis empty"
|
|
|
|
|
(array-index-map! (make-typed-array 'f64 0 2 0) (const 0))
|
|
|
|
|
(array-index-map! (make-typed-array 'b #t 2 0) (const #t))
|
2013-04-19 12:57:13 +02:00
|
|
|
(array-index-map! (make-typed-array #t 0 2 0) (const 0))
|
|
|
|
|
#t)
|
2013-04-19 10:42:40 +02:00
|
|
|
|
2013-04-19 12:57:13 +02:00
|
|
|
; the 'f64 cases fail in 2.0.9 with out-of-range.
|
2013-04-19 10:42:40 +02:00
|
|
|
(pass-if "axis empty, other than last"
|
|
|
|
|
(array-index-map! (make-typed-array 'f64 0 0 2) (const 0))
|
|
|
|
|
(array-index-map! (make-typed-array 'b #t 0 2) (const #t))
|
2013-04-19 12:57:13 +02:00
|
|
|
(array-index-map! (make-typed-array #t 0 0 2) (const 0))
|
2013-04-30 16:11:07 +02:00
|
|
|
#t))
|
|
|
|
|
|
|
|
|
|
(pass-if "rank 2"
|
|
|
|
|
(let ((a (make-array 0 2 2))
|
|
|
|
|
(b (make-array 0 2 2)))
|
|
|
|
|
(array-index-map! a (lambda (i j) i))
|
|
|
|
|
(array-index-map! b (lambda (i j) j))
|
|
|
|
|
(and (array-equal? a #2((0 0) (1 1)))
|
|
|
|
|
(array-equal? b #2((0 1) (0 1)))))))
|
2013-04-18 15:10:29 +02:00
|
|
|
|
|
|
|
|
;;;
|
|
|
|
|
;;; array-copy!
|
|
|
|
|
;;;
|
|
|
|
|
|
|
|
|
|
(with-test-prefix "array-copy!"
|
|
|
|
|
|
2013-04-19 12:57:13 +02:00
|
|
|
(with-test-prefix "empty arrays"
|
|
|
|
|
|
|
|
|
|
(pass-if "empty other than last, #t"
|
|
|
|
|
(let* ((b (make-array 0 2 2))
|
|
|
|
|
(c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
|
|
|
|
|
(array-copy! #2:0:2() c)
|
|
|
|
|
(array-equal? #2:0:2() c)))
|
|
|
|
|
|
|
|
|
|
(pass-if "empty other than last, 'f64"
|
|
|
|
|
(let* ((b (make-typed-array 'f64 0 2 2))
|
|
|
|
|
(c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
|
|
|
|
|
(array-copy! #2:0:2() c)
|
|
|
|
|
(array-equal? #2f64:0:2() c)))
|
|
|
|
|
|
2013-04-24 16:34:31 +02:00
|
|
|
;; FIXME add empty, type 'b cases.
|
|
|
|
|
|
|
|
|
|
)
|
|
|
|
|
|
|
|
|
|
;; note that it is the opposite of array-map!. This is, unfortunately,
|
|
|
|
|
;; documented in the manual.
|
|
|
|
|
|
|
|
|
|
(pass-if "matching behavior I"
|
|
|
|
|
(let ((a #(1 2))
|
|
|
|
|
(b (make-array 0 3)))
|
|
|
|
|
(array-copy! a b)
|
|
|
|
|
(equal? b #(1 2 0))))
|
|
|
|
|
|
|
|
|
|
(pass-if-exception "matching behavior II" exception:shape-mismatch
|
|
|
|
|
(let ((a #(1 2 3))
|
|
|
|
|
(b (make-array 0 2)))
|
|
|
|
|
(array-copy! a b)
|
|
|
|
|
(equal? b #(1 2))))
|
|
|
|
|
|
2013-04-25 15:18:05 +02:00
|
|
|
;; here both a & b are are unrollable down to the first axis, but the
|
|
|
|
|
;; size mismatch limits unrolling to the last axis only.
|
|
|
|
|
|
|
|
|
|
(pass-if "matching behavior III"
|
|
|
|
|
(let ((a #3(((1 2) (3 4)) ((5 6) (7 8))))
|
|
|
|
|
(b (make-array 0 2 3 2)))
|
|
|
|
|
(array-copy! a b)
|
|
|
|
|
(array-equal? b #3(((1 2) (3 4) (0 0)) ((5 6) (7 8) (0 0))))))
|
|
|
|
|
|
|
|
|
|
(pass-if "rank 0"
|
|
|
|
|
(let ((a #0(99))
|
|
|
|
|
(b (make-array 0)))
|
|
|
|
|
(array-copy! a b)
|
|
|
|
|
(equal? b #0(99))))
|
|
|
|
|
|
|
|
|
|
(pass-if "rank 1"
|
|
|
|
|
(let* ((a #2((1 2) (3 4)))
|
|
|
|
|
(b (make-shared-array a (lambda (j) (list 1 j)) 2))
|
|
|
|
|
(c (make-shared-array a (lambda (i) (list (- 1 i) 1)) 2))
|
|
|
|
|
(d (make-array 0 2))
|
|
|
|
|
(e (make-array 0 2)))
|
|
|
|
|
(array-copy! b d)
|
|
|
|
|
(array-copy! c e)
|
|
|
|
|
(and (equal? d #(3 4))
|
|
|
|
|
(equal? e #(4 2)))))
|
|
|
|
|
|
2013-04-24 16:34:31 +02:00
|
|
|
(pass-if "rank 2"
|
|
|
|
|
(let ((a #2((1 2) (3 4)))
|
|
|
|
|
(b (make-array 0 2 2))
|
|
|
|
|
(c (make-array 0 2 2))
|
|
|
|
|
(d (make-array 0 2 2))
|
|
|
|
|
(e (make-array 0 2 2)))
|
|
|
|
|
(array-copy! a b)
|
|
|
|
|
(array-copy! a (transpose-array c 1 0))
|
|
|
|
|
(array-copy! (transpose-array a 1 0) d)
|
|
|
|
|
(array-copy! (transpose-array a 1 0) (transpose-array e 1 0))
|
|
|
|
|
(and (equal? a #2((1 2) (3 4)))
|
|
|
|
|
(equal? b #2((1 2) (3 4)))
|
|
|
|
|
(equal? c #2((1 3) (2 4)))
|
|
|
|
|
(equal? d #2((1 3) (2 4)))
|
|
|
|
|
(equal? e #2((1 2) (3 4))))))
|
|
|
|
|
|
2013-04-25 15:18:05 +02:00
|
|
|
(pass-if "rank 2, discontinuous"
|
|
|
|
|
(let ((A #2((0 1) (2 3) (4 5)))
|
|
|
|
|
(B #2((10 11) (12 13) (14 15)))
|
|
|
|
|
(C #2((20) (21) (22)))
|
|
|
|
|
(X (make-array 0 3 5))
|
|
|
|
|
(piece (lambda (X w s)
|
|
|
|
|
(make-shared-array
|
|
|
|
|
X (lambda (i j) (list i (+ j s))) 3 w))))
|
|
|
|
|
(array-copy! A (piece X 2 0))
|
|
|
|
|
(array-copy! B (piece X 2 2))
|
|
|
|
|
(array-copy! C (piece X 1 4))
|
|
|
|
|
(and (array-equal? X #2((0 1 10 11 20) (2 3 12 13 21) (4 5 14 15 22))))))
|
|
|
|
|
|
|
|
|
|
(pass-if "null increments, not empty"
|
|
|
|
|
(let ((a (make-array 0 2 2)))
|
|
|
|
|
(array-copy! (make-shared-array #0(1) (lambda x '()) 2 2) a)
|
|
|
|
|
(array-equal? #2((1 1) (1 1))))))
|
2005-06-10 00:27:20 +00:00
|
|
|
|
2005-01-04 00:44:37 +00:00
|
|
|
;;;
|
|
|
|
|
;;; array-map!
|
|
|
|
|
;;;
|
|
|
|
|
|
|
|
|
|
(with-test-prefix "array-map!"
|
|
|
|
|
|
|
|
|
|
(pass-if-exception "no args" exception:wrong-num-args
|
|
|
|
|
(array-map!))
|
|
|
|
|
|
2005-04-25 00:15:24 +00:00
|
|
|
(pass-if-exception "one arg" exception:wrong-num-args
|
2005-01-04 00:44:37 +00:00
|
|
|
(array-map! (make-array #f 5)))
|
|
|
|
|
|
2005-04-25 00:15:24 +00:00
|
|
|
(with-test-prefix "no sources"
|
2005-01-04 00:44:37 +00:00
|
|
|
|
2005-04-25 00:15:24 +00:00
|
|
|
(pass-if "closure 0"
|
|
|
|
|
(array-map! (make-array #f 5) (lambda () #f))
|
|
|
|
|
#t)
|
2005-01-04 00:44:37 +00:00
|
|
|
|
2005-04-25 00:15:24 +00:00
|
|
|
(pass-if-exception "closure 1" exception:wrong-num-args
|
|
|
|
|
(array-map! (make-array #f 5) (lambda (x) #f)))
|
|
|
|
|
|
|
|
|
|
(pass-if-exception "closure 2" exception:wrong-num-args
|
|
|
|
|
(array-map! (make-array #f 5) (lambda (x y) #f)))
|
|
|
|
|
|
|
|
|
|
(pass-if-exception "subr_1" exception:wrong-num-args
|
|
|
|
|
(array-map! (make-array #f 5) length))
|
|
|
|
|
|
|
|
|
|
(pass-if-exception "subr_2" exception:wrong-num-args
|
|
|
|
|
(array-map! (make-array #f 5) logtest))
|
|
|
|
|
|
|
|
|
|
(pass-if-exception "subr_2o" exception:wrong-num-args
|
|
|
|
|
(array-map! (make-array #f 5) number->string))
|
|
|
|
|
|
|
|
|
|
(pass-if-exception "dsubr" exception:wrong-num-args
|
implement transcendental sin, cos etc in c; deprecate $sin, $cos, etc
* libguile/deprecated.h:
* libguile/deprecated.c (scm_asinh, scm_acosh, scm_atanh): Deprecate
these stand-ins for the C99 asinh, acosh, and atanh functions. Guile
is not gnulib.
(scm_sys_atan2): Deprecate as well, in favor of scm_atan.
* libguile/numbers.h:
* libguile/numbers.c (scm_sin, scm_cos, scm_tan)
(scm_sinh, scm_cosh, scm_tanh)
(scm_asin, scm_acos, scm_atan)
(scm_sys_asinh, scm_sys_acosh, scm_sys_atanh): New functions,
replacing the combination of dsubrs and boot-9 wrappers with C subrs
that handle complex values. The latter three have _sys_ in their names
due to the name conflict with the deprecated scm_asinh et al.
Remove the $abs, $sin etc "dsubrs".
* module/ice-9/boot-9.scm: Remove transcendental functions, as this all
happens in C now.
* module/ice-9/deprecated.scm: Add aliases for $sin et al.
* test-suite/tests/ramap.test ("array-map!"): Adjust "dsubr" tests to
use sqrt, not $sqrt. They don't actually test dsubrs now. In the
two-source test, I'm pretty sure the dsubr array-map! should have been
failing, as indeed it does now; I've changed the test case to expect
the failure. I'd still like to know why it was succeeding before.
2009-09-03 22:29:10 +02:00
|
|
|
(array-map! (make-array #f 5) sqrt))
|
2005-04-25 00:15:24 +00:00
|
|
|
|
|
|
|
|
(pass-if "rpsubr"
|
|
|
|
|
(let ((a (make-array 'foo 5)))
|
|
|
|
|
(array-map! a =)
|
|
|
|
|
(equal? a (make-array #t 5))))
|
|
|
|
|
|
|
|
|
|
(pass-if "asubr"
|
|
|
|
|
(let ((a (make-array 'foo 5)))
|
|
|
|
|
(array-map! a +)
|
|
|
|
|
(equal? a (make-array 0 5))))
|
|
|
|
|
|
|
|
|
|
;; in Guile 1.6.4 and earlier this resulted in a segv
|
|
|
|
|
(pass-if "noop"
|
|
|
|
|
(array-map! (make-array #f 5) noop)
|
|
|
|
|
#t))
|
|
|
|
|
|
|
|
|
|
(with-test-prefix "one source"
|
|
|
|
|
|
|
|
|
|
(pass-if-exception "closure 0" exception:wrong-num-args
|
|
|
|
|
(array-map! (make-array #f 5) (lambda () #f)
|
2013-04-18 15:10:29 +02:00
|
|
|
(make-array #f 5)))
|
2005-04-25 00:15:24 +00:00
|
|
|
|
|
|
|
|
(pass-if "closure 1"
|
|
|
|
|
(let ((a (make-array #f 5)))
|
|
|
|
|
(array-map! a (lambda (x) 'foo) (make-array #f 5))
|
|
|
|
|
(equal? a (make-array 'foo 5))))
|
|
|
|
|
|
|
|
|
|
(pass-if-exception "closure 2" exception:wrong-num-args
|
|
|
|
|
(array-map! (make-array #f 5) (lambda (x y) #f)
|
2013-04-24 16:34:31 +02:00
|
|
|
(make-array #f 5)))
|
2005-04-25 00:15:24 +00:00
|
|
|
|
|
|
|
|
(pass-if "subr_1"
|
|
|
|
|
(let ((a (make-array #f 5)))
|
2013-04-18 15:10:29 +02:00
|
|
|
(array-map! a length (make-array '(x y z) 5))
|
|
|
|
|
(equal? a (make-array 3 5))))
|
2005-04-25 00:15:24 +00:00
|
|
|
|
|
|
|
|
(pass-if-exception "subr_2" exception:wrong-num-args
|
|
|
|
|
(array-map! (make-array #f 5) logtest
|
2013-04-18 15:10:29 +02:00
|
|
|
(make-array 999 5)))
|
2005-04-25 00:15:24 +00:00
|
|
|
|
|
|
|
|
(pass-if "subr_2o"
|
|
|
|
|
(let ((a (make-array #f 5)))
|
|
|
|
|
(array-map! a number->string (make-array 99 5))
|
|
|
|
|
(equal? a (make-array "99" 5))))
|
|
|
|
|
|
|
|
|
|
(pass-if "dsubr"
|
|
|
|
|
(let ((a (make-array #f 5)))
|
implement transcendental sin, cos etc in c; deprecate $sin, $cos, etc
* libguile/deprecated.h:
* libguile/deprecated.c (scm_asinh, scm_acosh, scm_atanh): Deprecate
these stand-ins for the C99 asinh, acosh, and atanh functions. Guile
is not gnulib.
(scm_sys_atan2): Deprecate as well, in favor of scm_atan.
* libguile/numbers.h:
* libguile/numbers.c (scm_sin, scm_cos, scm_tan)
(scm_sinh, scm_cosh, scm_tanh)
(scm_asin, scm_acos, scm_atan)
(scm_sys_asinh, scm_sys_acosh, scm_sys_atanh): New functions,
replacing the combination of dsubrs and boot-9 wrappers with C subrs
that handle complex values. The latter three have _sys_ in their names
due to the name conflict with the deprecated scm_asinh et al.
Remove the $abs, $sin etc "dsubrs".
* module/ice-9/boot-9.scm: Remove transcendental functions, as this all
happens in C now.
* module/ice-9/deprecated.scm: Add aliases for $sin et al.
* test-suite/tests/ramap.test ("array-map!"): Adjust "dsubr" tests to
use sqrt, not $sqrt. They don't actually test dsubrs now. In the
two-source test, I'm pretty sure the dsubr array-map! should have been
failing, as indeed it does now; I've changed the test case to expect
the failure. I'd still like to know why it was succeeding before.
2009-09-03 22:29:10 +02:00
|
|
|
(array-map! a sqrt (make-array 16.0 5))
|
2005-04-25 00:15:24 +00:00
|
|
|
(equal? a (make-array 4.0 5))))
|
|
|
|
|
|
|
|
|
|
(pass-if "rpsubr"
|
|
|
|
|
(let ((a (make-array 'foo 5)))
|
|
|
|
|
(array-map! a = (make-array 0 5))
|
|
|
|
|
(equal? a (make-array #t 5))))
|
|
|
|
|
|
|
|
|
|
(pass-if "asubr"
|
|
|
|
|
(let ((a (make-array 'foo 5)))
|
|
|
|
|
(array-map! a - (make-array 99 5))
|
|
|
|
|
(equal? a (make-array -99 5))))
|
|
|
|
|
|
|
|
|
|
;; in Guile 1.6.5 and 1.6.6 this was an error
|
|
|
|
|
(pass-if "1+"
|
|
|
|
|
(let ((a (make-array #f 5)))
|
|
|
|
|
(array-map! a 1+ (make-array 123 5))
|
2013-04-25 15:18:05 +02:00
|
|
|
(equal? a (make-array 124 5))))
|
|
|
|
|
|
|
|
|
|
(pass-if "rank 0"
|
|
|
|
|
(let ((a #0(99))
|
|
|
|
|
(b (make-array 0)))
|
|
|
|
|
(array-map! b values a)
|
|
|
|
|
(equal? b #0(99))))
|
|
|
|
|
|
|
|
|
|
(pass-if "rank 2, discontinuous"
|
|
|
|
|
(let ((A #2((0 1) (2 3) (4 5)))
|
|
|
|
|
(B #2((10 11) (12 13) (14 15)))
|
|
|
|
|
(C #2((20) (21) (22)))
|
|
|
|
|
(X (make-array 0 3 5))
|
|
|
|
|
(piece (lambda (X w s)
|
|
|
|
|
(make-shared-array
|
|
|
|
|
X (lambda (i j) (list i (+ j s))) 3 w))))
|
|
|
|
|
(array-map! (piece X 2 0) values A)
|
|
|
|
|
(array-map! (piece X 2 2) values B)
|
|
|
|
|
(array-map! (piece X 1 4) values C)
|
|
|
|
|
(and (array-equal? X #2((0 1 10 11 20) (2 3 12 13 21) (4 5 14 15 22))))))
|
|
|
|
|
|
|
|
|
|
(pass-if "null increments, not empty"
|
|
|
|
|
(let ((a (make-array 0 2 2)))
|
|
|
|
|
(array-map! a values (make-shared-array #0(1) (lambda x '()) 2 2))
|
|
|
|
|
(array-equal? a #2((1 1) (1 1))))))
|
2005-04-25 00:15:24 +00:00
|
|
|
|
|
|
|
|
(with-test-prefix "two sources"
|
|
|
|
|
|
|
|
|
|
(pass-if-exception "closure 0" exception:wrong-num-args
|
|
|
|
|
(array-map! (make-array #f 5) (lambda () #f)
|
2013-04-18 15:10:29 +02:00
|
|
|
(make-array #f 5) (make-array #f 5)))
|
2005-04-25 00:15:24 +00:00
|
|
|
|
|
|
|
|
(pass-if-exception "closure 1" exception:wrong-num-args
|
|
|
|
|
(array-map! (make-array #f 5) (lambda (x) #f)
|
2013-04-18 15:10:29 +02:00
|
|
|
(make-array #f 5) (make-array #f 5)))
|
2005-04-25 00:15:24 +00:00
|
|
|
|
|
|
|
|
(pass-if "closure 2"
|
|
|
|
|
(let ((a (make-array #f 5)))
|
2013-04-18 15:10:29 +02:00
|
|
|
(array-map! a (lambda (x y) 'foo)
|
|
|
|
|
(make-array #f 5) (make-array #f 5))
|
|
|
|
|
(equal? a (make-array 'foo 5))))
|
2005-04-25 00:15:24 +00:00
|
|
|
|
remove tc7_subr_* and tc7_lsubr_*
* libguile/tags.h: Remove tc7 #defines for subrs, replacing them with
placeholders. These were public, but hopfully unused. I don't see how
to usefully deprecate them.
* libguile/array-map.c (scm_array_map_x): Remove special cases for
certain subr types. This might make things slower for the moment,
otoh, native compilation should moot that question.
* libguile/eval.i.c:
* libguile/eval.c: Remove subr-handling cases. To regain this speed and
more won't have to wait for native compilation, though -- this change
smooths the way for subr dispatch in the VM.
* libguile/gsubr.c (scm_i_gsubr_apply): Fix a bug in which we didn't
detect too-many-arguments. This would only show up when using ceval,
as only ceval called this function.
* test-suite/tests/ramap.test ("array-map!"): Change the expected
exception if passed a procedure of the wrong arity. It now gives
wrong-num-args.
more won't have to wait for native compilation, though -- this change
smooths the way for subr dispatch in the VM.
* libguile/goops.c (scm_class_of): Remove subr cases. No speed
implication.
* libguile/objects.c (scm_valid_object_procedure_p): Remove this public
but undocumented, and useless, function. I do not think this will
affect anyone at all.
(scm_set_object_procedure_x): Replace a call to
scm_valid_object_procedure_p with scm_procedure_p, and actually wrap
with a scm_is_true.
* module/oop/goops.scm (initialize-object-procedure): Don't call
valid-object-procedure?.
2009-09-03 11:57:29 +02:00
|
|
|
(pass-if-exception "subr_1" exception:wrong-num-args
|
2005-04-25 00:15:24 +00:00
|
|
|
(array-map! (make-array #f 5) length
|
|
|
|
|
(make-array #f 5) (make-array #f 5)))
|
|
|
|
|
|
|
|
|
|
(pass-if "subr_2"
|
|
|
|
|
(let ((a (make-array 'foo 5)))
|
|
|
|
|
(array-map! a logtest
|
|
|
|
|
(make-array 999 5) (make-array 999 5))
|
|
|
|
|
(equal? a (make-array #t 5))))
|
|
|
|
|
|
|
|
|
|
(pass-if "subr_2o"
|
|
|
|
|
(let ((a (make-array #f 5)))
|
|
|
|
|
(array-map! a number->string
|
|
|
|
|
(make-array 32 5) (make-array 16 5))
|
|
|
|
|
(equal? a (make-array "20" 5))))
|
|
|
|
|
|
implement transcendental sin, cos etc in c; deprecate $sin, $cos, etc
* libguile/deprecated.h:
* libguile/deprecated.c (scm_asinh, scm_acosh, scm_atanh): Deprecate
these stand-ins for the C99 asinh, acosh, and atanh functions. Guile
is not gnulib.
(scm_sys_atan2): Deprecate as well, in favor of scm_atan.
* libguile/numbers.h:
* libguile/numbers.c (scm_sin, scm_cos, scm_tan)
(scm_sinh, scm_cosh, scm_tanh)
(scm_asin, scm_acos, scm_atan)
(scm_sys_asinh, scm_sys_acosh, scm_sys_atanh): New functions,
replacing the combination of dsubrs and boot-9 wrappers with C subrs
that handle complex values. The latter three have _sys_ in their names
due to the name conflict with the deprecated scm_asinh et al.
Remove the $abs, $sin etc "dsubrs".
* module/ice-9/boot-9.scm: Remove transcendental functions, as this all
happens in C now.
* module/ice-9/deprecated.scm: Add aliases for $sin et al.
* test-suite/tests/ramap.test ("array-map!"): Adjust "dsubr" tests to
use sqrt, not $sqrt. They don't actually test dsubrs now. In the
two-source test, I'm pretty sure the dsubr array-map! should have been
failing, as indeed it does now; I've changed the test case to expect
the failure. I'd still like to know why it was succeeding before.
2009-09-03 22:29:10 +02:00
|
|
|
(pass-if-exception "dsubr" exception:wrong-num-args
|
2005-04-25 00:15:24 +00:00
|
|
|
(let ((a (make-array #f 5)))
|
implement transcendental sin, cos etc in c; deprecate $sin, $cos, etc
* libguile/deprecated.h:
* libguile/deprecated.c (scm_asinh, scm_acosh, scm_atanh): Deprecate
these stand-ins for the C99 asinh, acosh, and atanh functions. Guile
is not gnulib.
(scm_sys_atan2): Deprecate as well, in favor of scm_atan.
* libguile/numbers.h:
* libguile/numbers.c (scm_sin, scm_cos, scm_tan)
(scm_sinh, scm_cosh, scm_tanh)
(scm_asin, scm_acos, scm_atan)
(scm_sys_asinh, scm_sys_acosh, scm_sys_atanh): New functions,
replacing the combination of dsubrs and boot-9 wrappers with C subrs
that handle complex values. The latter three have _sys_ in their names
due to the name conflict with the deprecated scm_asinh et al.
Remove the $abs, $sin etc "dsubrs".
* module/ice-9/boot-9.scm: Remove transcendental functions, as this all
happens in C now.
* module/ice-9/deprecated.scm: Add aliases for $sin et al.
* test-suite/tests/ramap.test ("array-map!"): Adjust "dsubr" tests to
use sqrt, not $sqrt. They don't actually test dsubrs now. In the
two-source test, I'm pretty sure the dsubr array-map! should have been
failing, as indeed it does now; I've changed the test case to expect
the failure. I'd still like to know why it was succeeding before.
2009-09-03 22:29:10 +02:00
|
|
|
(array-map! a sqrt
|
2005-04-25 00:15:24 +00:00
|
|
|
(make-array 16.0 5) (make-array 16.0 5))
|
|
|
|
|
(equal? a (make-array 4.0 5))))
|
|
|
|
|
|
|
|
|
|
(pass-if "rpsubr"
|
|
|
|
|
(let ((a (make-array 'foo 5)))
|
|
|
|
|
(array-map! a = (make-array 99 5) (make-array 77 5))
|
|
|
|
|
(equal? a (make-array #f 5))))
|
|
|
|
|
|
|
|
|
|
(pass-if "asubr"
|
|
|
|
|
(let ((a (make-array 'foo 5)))
|
|
|
|
|
(array-map! a - (make-array 99 5) (make-array 11 5))
|
|
|
|
|
(equal? a (make-array 88 5))))
|
|
|
|
|
|
|
|
|
|
(pass-if "+"
|
|
|
|
|
(let ((a (make-array #f 4)))
|
|
|
|
|
(array-map! a + #(1 2 3 4) #(5 6 7 8))
|
2011-12-22 17:13:07 -05:00
|
|
|
(equal? a #(6 8 10 12))))
|
2013-04-18 15:10:29 +02:00
|
|
|
|
2011-12-22 17:13:07 -05:00
|
|
|
(pass-if "noncompact arrays 1"
|
|
|
|
|
(let ((a #2((0 1) (2 3)))
|
2013-04-18 15:10:29 +02:00
|
|
|
(c (make-array 0 2)))
|
2011-12-22 17:13:07 -05:00
|
|
|
(begin
|
|
|
|
|
(array-map! c + (array-row a 1) (array-row a 1))
|
|
|
|
|
(array-equal? c #(4 6)))))
|
2013-04-18 15:10:29 +02:00
|
|
|
|
2011-12-22 17:13:07 -05:00
|
|
|
(pass-if "noncompact arrays 2"
|
|
|
|
|
(let ((a #2((0 1) (2 3)))
|
2013-04-18 15:10:29 +02:00
|
|
|
(c (make-array 0 2)))
|
2011-12-22 17:13:07 -05:00
|
|
|
(begin
|
|
|
|
|
(array-map! c + (array-col a 1) (array-col a 1))
|
|
|
|
|
(array-equal? c #(2 6)))))
|
2013-04-18 15:10:29 +02:00
|
|
|
|
2011-12-22 17:13:07 -05:00
|
|
|
(pass-if "noncompact arrays 3"
|
|
|
|
|
(let ((a #2((0 1) (2 3)))
|
2013-04-18 15:10:29 +02:00
|
|
|
(c (make-array 0 2)))
|
2011-12-22 17:13:07 -05:00
|
|
|
(begin
|
|
|
|
|
(array-map! c + (array-col a 1) (array-row a 1))
|
|
|
|
|
(array-equal? c #(3 6)))))
|
2013-04-18 15:10:29 +02:00
|
|
|
|
2011-12-22 17:13:07 -05:00
|
|
|
(pass-if "noncompact arrays 4"
|
|
|
|
|
(let ((a #2((0 1) (2 3)))
|
2013-04-18 15:10:29 +02:00
|
|
|
(c (make-array 0 2)))
|
2011-12-22 17:13:07 -05:00
|
|
|
(begin
|
|
|
|
|
(array-map! c + (array-col a 1) (array-row a 1))
|
2013-04-24 23:29:48 +02:00
|
|
|
(array-equal? c #(3 6)))))
|
|
|
|
|
|
|
|
|
|
(pass-if "offset arrays 1"
|
|
|
|
|
(let ((a #2@1@-3((0 1) (2 3)))
|
|
|
|
|
(c (make-array 0 '(1 2) '(-3 -2))))
|
|
|
|
|
(begin
|
|
|
|
|
(array-map! c + a a)
|
|
|
|
|
(array-equal? c #2@1@-3((0 2) (4 6)))))))
|
2013-04-24 16:34:31 +02:00
|
|
|
|
|
|
|
|
;; note that array-copy! has the opposite behavior.
|
|
|
|
|
|
|
|
|
|
(pass-if-exception "matching behavior I" exception:shape-mismatch
|
|
|
|
|
(let ((a #(1 2))
|
|
|
|
|
(b (make-array 0 3)))
|
|
|
|
|
(array-map! b values a)
|
|
|
|
|
(equal? b #(1 2 0))))
|
|
|
|
|
|
|
|
|
|
(pass-if "matching behavior II"
|
|
|
|
|
(let ((a #(1 2 3))
|
|
|
|
|
(b (make-array 0 2)))
|
|
|
|
|
(array-map! b values a)
|
2013-04-25 15:18:05 +02:00
|
|
|
(equal? b #(1 2))))
|
|
|
|
|
|
|
|
|
|
;; here both a & b are are unrollable down to the first axis, but the
|
|
|
|
|
;; size mismatch limits unrolling to the last axis only.
|
|
|
|
|
|
|
|
|
|
(pass-if "matching behavior III"
|
|
|
|
|
(let ((a #3(((1 2) (3 4) (5 6)) ((7 8) (9 10) (11 12))))
|
|
|
|
|
(b (make-array 0 2 2 2)))
|
|
|
|
|
(array-map! b values a)
|
|
|
|
|
(array-equal? b #3(((1 2) (3 4)) ((7 8) (9 10)))))))
|
2011-12-22 17:13:07 -05:00
|
|
|
|
|
|
|
|
;;;
|
|
|
|
|
;;; array-for-each
|
|
|
|
|
;;;
|
|
|
|
|
|
|
|
|
|
(with-test-prefix "array-for-each"
|
|
|
|
|
|
2013-04-03 21:34:31 +02:00
|
|
|
(with-test-prefix "1 source"
|
2013-04-25 15:18:05 +02:00
|
|
|
(pass-if-equal "rank 0"
|
|
|
|
|
'(99)
|
|
|
|
|
(let* ((a #0(99))
|
|
|
|
|
(l '())
|
|
|
|
|
(p (lambda (x) (set! l (cons x l)))))
|
|
|
|
|
(array-for-each p a)
|
|
|
|
|
l))
|
|
|
|
|
|
2013-04-03 21:34:31 +02:00
|
|
|
(pass-if-equal "noncompact array"
|
|
|
|
|
'(3 2 1 0)
|
|
|
|
|
(let* ((a #2((0 1) (2 3)))
|
|
|
|
|
(l '())
|
|
|
|
|
(p (lambda (x) (set! l (cons x l)))))
|
|
|
|
|
(array-for-each p a)
|
|
|
|
|
l))
|
|
|
|
|
|
|
|
|
|
(pass-if-equal "vector"
|
|
|
|
|
'(3 2 1 0)
|
|
|
|
|
(let* ((a #(0 1 2 3))
|
|
|
|
|
(l '())
|
|
|
|
|
(p (lambda (x) (set! l (cons x l)))))
|
|
|
|
|
(array-for-each p a)
|
|
|
|
|
l))
|
|
|
|
|
|
|
|
|
|
(pass-if-equal "shared array"
|
|
|
|
|
'(3 2 1 0)
|
|
|
|
|
(let* ((a #2((0 1) (2 3)))
|
|
|
|
|
(a' (make-shared-array a
|
|
|
|
|
(lambda (x)
|
|
|
|
|
(list (quotient x 4)
|
|
|
|
|
(modulo x 4)))
|
|
|
|
|
4))
|
|
|
|
|
(l '())
|
|
|
|
|
(p (lambda (x) (set! l (cons x l)))))
|
|
|
|
|
(array-for-each p a')
|
|
|
|
|
l)))
|
|
|
|
|
|
2011-12-22 17:13:07 -05:00
|
|
|
(with-test-prefix "3 sources"
|
2013-04-03 19:13:23 +02:00
|
|
|
(pass-if-equal "noncompact arrays 1"
|
Speed up for multi-arg cases of scm_ramap functions
This patch results in a 20%-40% speedup in the > 1 argument cases of
the following microbenchmarks:
(define A (make-shared-array #0(1) (const '()) #e1e7))
; 1, 2, 3 arguments.
(define a 0) ,time (array-for-each (lambda (b) (set! a (+ a b))) A)
(define a 0) ,time (array-for-each (lambda (b c) (set! a (+ a b c))) A A)
(define a 0) ,time (array-for-each (lambda (b c d) (set! a (+ a b c d))) A A A)
(define A (make-shared-array (make-array 1) (const '()) #e1e7))
(define B (make-shared-array #0(1) (const '()) #e1e7))
; 1, 2, 3 arguments.
,time (array-map! A + B)
,time (array-map! A + B B)
,time (array-map! A + B B B)
* libguile/array-map.c (scm_ramap): Note on cproc arguments.
(rafill): Assume that dst's lbnd is 0.
(racp): Assume that src's lbnd is 0.
(ramap): Assume that ra0's lbnd is 0. When there're more than two
arguments, compute the array handles before the loop. Allocate the arg
list once and reuse it in the loop.
(rafe): Do as in ramap(), when there's more than one argument.
(AREF, ASET): Remove.
2015-02-13 18:42:27 +01:00
|
|
|
'((3 1 3) (2 0 2))
|
2011-12-22 17:13:07 -05:00
|
|
|
(let* ((a #2((0 1) (2 3)))
|
|
|
|
|
(l '())
|
|
|
|
|
(rec (lambda args (set! l (cons args l)))))
|
Speed up for multi-arg cases of scm_ramap functions
This patch results in a 20%-40% speedup in the > 1 argument cases of
the following microbenchmarks:
(define A (make-shared-array #0(1) (const '()) #e1e7))
; 1, 2, 3 arguments.
(define a 0) ,time (array-for-each (lambda (b) (set! a (+ a b))) A)
(define a 0) ,time (array-for-each (lambda (b c) (set! a (+ a b c))) A A)
(define a 0) ,time (array-for-each (lambda (b c d) (set! a (+ a b c d))) A A A)
(define A (make-shared-array (make-array 1) (const '()) #e1e7))
(define B (make-shared-array #0(1) (const '()) #e1e7))
; 1, 2, 3 arguments.
,time (array-map! A + B)
,time (array-map! A + B B)
,time (array-map! A + B B B)
* libguile/array-map.c (scm_ramap): Note on cproc arguments.
(rafill): Assume that dst's lbnd is 0.
(racp): Assume that src's lbnd is 0.
(ramap): Assume that ra0's lbnd is 0. When there're more than two
arguments, compute the array handles before the loop. Allocate the arg
list once and reuse it in the loop.
(rafe): Do as in ramap(), when there's more than one argument.
(AREF, ASET): Remove.
2015-02-13 18:42:27 +01:00
|
|
|
(array-for-each rec (array-row a 1) (array-row a 0) (array-row a 1))
|
2013-04-03 19:13:23 +02:00
|
|
|
l))
|
|
|
|
|
|
|
|
|
|
(pass-if-equal "noncompact arrays 2"
|
|
|
|
|
'((3 3 3) (2 2 1))
|
2011-12-22 17:13:07 -05:00
|
|
|
(let* ((a #2((0 1) (2 3)))
|
|
|
|
|
(l '())
|
|
|
|
|
(rec (lambda args (set! l (cons args l)))))
|
|
|
|
|
(array-for-each rec (array-row a 1) (array-row a 1) (array-col a 1))
|
2013-04-03 19:13:23 +02:00
|
|
|
l))
|
|
|
|
|
|
|
|
|
|
(pass-if-equal "noncompact arrays 3"
|
|
|
|
|
'((3 3 3) (2 1 1))
|
2011-12-22 17:13:07 -05:00
|
|
|
(let* ((a #2((0 1) (2 3)))
|
|
|
|
|
(l '())
|
|
|
|
|
(rec (lambda args (set! l (cons args l)))))
|
|
|
|
|
(array-for-each rec (array-row a 1) (array-col a 1) (array-col a 1))
|
2013-04-03 19:13:23 +02:00
|
|
|
l))
|
|
|
|
|
|
|
|
|
|
(pass-if-equal "noncompact arrays 4"
|
|
|
|
|
'((3 2 3) (1 0 2))
|
2011-12-22 17:13:07 -05:00
|
|
|
(let* ((a #2((0 1) (2 3)))
|
|
|
|
|
(l '())
|
|
|
|
|
(rec (lambda args (set! l (cons args l)))))
|
|
|
|
|
(array-for-each rec (array-col a 1) (array-col a 0) (array-row a 1))
|
2013-04-19 12:57:13 +02:00
|
|
|
l)))
|
|
|
|
|
|
|
|
|
|
(with-test-prefix "empty arrays"
|
|
|
|
|
|
|
|
|
|
(pass-if "empty other than last, #t" ; fails in 2.0.9 with bad a.
|
|
|
|
|
(let* ((a (list))
|
|
|
|
|
(b (make-array 0 2 2))
|
|
|
|
|
(c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
|
|
|
|
|
(array-for-each (lambda (c) (set! a (cons c a))) c)
|
|
|
|
|
(equal? a '())))
|
|
|
|
|
|
|
|
|
|
(pass-if "empty other than last, f64" ; fails in 2.0.9 with out of range.
|
|
|
|
|
(let* ((a (list))
|
|
|
|
|
(b (make-typed-array 'f64 0 2 2))
|
|
|
|
|
(c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
|
|
|
|
|
(array-for-each (lambda (c) (set! a (cons c a))) c)
|
|
|
|
|
(equal? a '())))
|
|
|
|
|
|
|
|
|
|
;; FIXME add type 'b cases.
|
|
|
|
|
|
|
|
|
|
(pass-if-exception "empty arrays shape check" exception:shape-mismatch
|
|
|
|
|
(let* ((a (list))
|
|
|
|
|
(b (make-typed-array 'f64 0 0 2))
|
|
|
|
|
(c (make-typed-array 'f64 0 2 0)))
|
|
|
|
|
(array-for-each (lambda (b c) (set! a (cons* b c a))) b c)))))
|
2015-09-08 16:57:30 +02:00
|
|
|
|
|
|
|
|
;;;
|
|
|
|
|
;;; array-for-each-cell
|
|
|
|
|
;;;
|
|
|
|
|
|
|
|
|
|
(with-test-prefix "array-for-each-cell"
|
|
|
|
|
|
|
|
|
|
(pass-if-equal "1 argument frame rank 1"
|
|
|
|
|
#2((1 3 9) (2 7 8))
|
|
|
|
|
(let* ((a (list->array 2 '((9 1 3) (7 8 2)))))
|
|
|
|
|
(array-for-each-cell 1 (lambda (a) (sort! a <)) a)
|
|
|
|
|
a))
|
|
|
|
|
|
|
|
|
|
(pass-if-equal "2 arguments frame rank 1"
|
|
|
|
|
#f64(8 -1)
|
|
|
|
|
(let* ((x (list->typed-array 'f64 2 '((9 1) (7 8))))
|
|
|
|
|
(y (f64vector 99 99)))
|
|
|
|
|
(array-for-each-cell 1 (lambda (y x) (array-set! y (- (array-ref x 0) (array-ref x 1)))) y x)
|
|
|
|
|
y))
|
|
|
|
|
|
|
|
|
|
(pass-if-equal "regression: zero-sized frame loop without unrolling"
|
|
|
|
|
99
|
|
|
|
|
(let* ((x 99)
|
|
|
|
|
(o (make-array 0. 0 3 2)))
|
|
|
|
|
(array-for-each-cell 2
|
|
|
|
|
(lambda (o a0 a1)
|
|
|
|
|
(set! x 0))
|
|
|
|
|
o
|
|
|
|
|
(make-shared-array (make-array 1. 0 1) (const '(0 0)) 0 3)
|
|
|
|
|
(make-array 2. 0 3))
|
|
|
|
|
x)))
|