mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-10 22:10:21 +02:00
Merge branch 'lloda-array-support'
This commit is contained in:
Daniel Llorens
commit
7f2c824551
7 changed files with 117 additions and 89 deletions
|
|
@ -1,6 +1,6 @@
|
|||
/* Copyright (C) 1996, 1998, 2000, 2001, 2004, 2005, 2006, 2008, 2009,
|
||||
* 2010, 2011, 2012, 2013, 2014 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
|
||||
|
|
@ -63,11 +63,11 @@ static SCM
|
|||
make1array (SCM v, ssize_t inc)
|
||||
{
|
||||
SCM a = scm_i_make_array (1);
|
||||
SCM_I_ARRAY_BASE (a) = 0;
|
||||
SCM_I_ARRAY_SET_BASE (a, 0);
|
||||
SCM_I_ARRAY_DIMS (a)->lbnd = 0;
|
||||
SCM_I_ARRAY_DIMS (a)->ubnd = scm_c_array_length (v) - 1;
|
||||
SCM_I_ARRAY_DIMS (a)->inc = inc;
|
||||
SCM_I_ARRAY_V (a) = v;
|
||||
SCM_I_ARRAY_SET_V (a, v);
|
||||
return a;
|
||||
}
|
||||
|
||||
|
|
@ -195,9 +195,9 @@ scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
|
|||
if (k == kroll)
|
||||
{
|
||||
SCM y = lra;
|
||||
SCM_I_ARRAY_BASE (va0) = cindk (ra0, vi, kroll);
|
||||
SCM_I_ARRAY_SET_BASE (va0, cindk (ra0, vi, kroll));
|
||||
for (z = lva; !scm_is_null (z); z = SCM_CDR (z), y = SCM_CDR (y))
|
||||
SCM_I_ARRAY_BASE (SCM_CAR (z)) = cindk (SCM_CAR (y), vi, kroll);
|
||||
SCM_I_ARRAY_SET_BASE (SCM_CAR (z), cindk (SCM_CAR (y), vi, kroll));
|
||||
if (! (SCM_UNBNDP (data) ? cproc (va0, lva) : cproc (va0, data, lva)))
|
||||
return 0;
|
||||
--k;
|
||||
|
|
@ -815,7 +815,7 @@ array_compare (scm_t_array_handle *hx, scm_t_array_handle *hy,
|
|||
return 0;
|
||||
|
||||
i = hx->dims[dim].ubnd - hx->dims[dim].lbnd + 1;
|
||||
|
||||
|
||||
incx = hx->dims[dim].inc;
|
||||
incy = hy->dims[dim].inc;
|
||||
posx += (i - 1) * incx;
|
||||
|
|
@ -832,11 +832,11 @@ SCM
|
|||
scm_array_equal_p (SCM x, SCM y)
|
||||
{
|
||||
scm_t_array_handle hx, hy;
|
||||
SCM res;
|
||||
|
||||
SCM res;
|
||||
|
||||
scm_array_get_handle (x, &hx);
|
||||
scm_array_get_handle (y, &hy);
|
||||
|
||||
|
||||
res = scm_from_bool (hx.ndims == hy.ndims
|
||||
&& hx.element_type == hy.element_type);
|
||||
|
||||
|
|
@ -860,7 +860,7 @@ SCM_DEFINE (scm_i_array_equal_p, "array-equal?", 0, 2, 1,
|
|||
{
|
||||
if (SCM_UNBNDP (ra0) || SCM_UNBNDP (ra1))
|
||||
return SCM_BOOL_T;
|
||||
|
||||
|
||||
while (!scm_is_null (rest))
|
||||
{ if (scm_is_false (scm_array_equal_p (ra0, ra1)))
|
||||
return SCM_BOOL_F;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004,2005,
|
||||
* 2006, 2009, 2010, 2011, 2012, 2013, 2014 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
|
||||
|
|
@ -29,6 +29,8 @@
|
|||
#include <string.h>
|
||||
#include <assert.h>
|
||||
|
||||
#include "verify.h"
|
||||
|
||||
#include "libguile/_scm.h"
|
||||
#include "libguile/__scm.h"
|
||||
#include "libguile/eq.h"
|
||||
|
|
@ -92,7 +94,7 @@ SCM_DEFINE (scm_shared_array_offset, "shared-array-offset", 1, 0, 0,
|
|||
#undef FUNC_NAME
|
||||
|
||||
|
||||
SCM_DEFINE (scm_shared_array_increments, "shared-array-increments", 1, 0, 0,
|
||||
SCM_DEFINE (scm_shared_array_increments, "shared-array-increments", 1, 0, 0,
|
||||
(SCM ra),
|
||||
"For each dimension, return the distance between elements in the root vector.")
|
||||
#define FUNC_NAME s_scm_shared_array_increments
|
||||
|
|
@ -112,15 +114,19 @@ SCM_DEFINE (scm_shared_array_increments, "shared-array-increments", 1, 0, 0,
|
|||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
/* FIXME: to avoid this assumption, fix the accessors in arrays.h,
|
||||
scm_i_make_array, and the array cases in system/vm/assembler.scm. */
|
||||
|
||||
verify (sizeof (scm_t_array_dim) == 3*sizeof (scm_t_bits));
|
||||
|
||||
/* Matching SCM_I_ARRAY accessors in arrays.h */
|
||||
SCM
|
||||
scm_i_make_array (int ndim)
|
||||
{
|
||||
SCM ra;
|
||||
ra = scm_cell (((scm_t_bits) ndim << 17) + scm_tc7_array,
|
||||
(scm_t_bits) scm_gc_malloc (sizeof (scm_i_t_array) +
|
||||
ndim * sizeof (scm_t_array_dim),
|
||||
"array"));
|
||||
SCM_I_ARRAY_V (ra) = SCM_BOOL_F;
|
||||
SCM ra = scm_words (((scm_t_bits) ndim << 17) + scm_tc7_array, 3 + ndim*3);
|
||||
SCM_I_ARRAY_SET_V (ra, SCM_BOOL_F);
|
||||
SCM_I_ARRAY_SET_BASE (ra, 0);
|
||||
/* dimensions are unset */
|
||||
return ra;
|
||||
}
|
||||
|
||||
|
|
@ -139,7 +145,7 @@ scm_i_shap2ra (SCM args)
|
|||
scm_misc_error (NULL, s_bad_spec, SCM_EOL);
|
||||
|
||||
ra = scm_i_make_array (ndim);
|
||||
SCM_I_ARRAY_BASE (ra) = 0;
|
||||
SCM_I_ARRAY_SET_BASE (ra, 0);
|
||||
s = SCM_I_ARRAY_DIMS (ra);
|
||||
for (; !scm_is_null (args); s++, args = SCM_CDR (args))
|
||||
{
|
||||
|
|
@ -179,7 +185,7 @@ SCM_DEFINE (scm_make_typed_array, "make-typed-array", 2, 0, 1,
|
|||
size_t k, rlen = 1;
|
||||
scm_t_array_dim *s;
|
||||
SCM ra;
|
||||
|
||||
|
||||
ra = scm_i_shap2ra (bounds);
|
||||
SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
|
||||
s = SCM_I_ARRAY_DIMS (ra);
|
||||
|
|
@ -195,8 +201,7 @@ SCM_DEFINE (scm_make_typed_array, "make-typed-array", 2, 0, 1,
|
|||
if (scm_is_eq (fill, SCM_UNSPECIFIED))
|
||||
fill = SCM_UNDEFINED;
|
||||
|
||||
SCM_I_ARRAY_V (ra) =
|
||||
scm_make_generalized_vector (type, scm_from_size_t (rlen), fill);
|
||||
SCM_I_ARRAY_SET_V (ra, 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 (0 == s->lbnd)
|
||||
|
|
@ -217,7 +222,7 @@ scm_from_contiguous_typed_array (SCM type, SCM bounds, const void *bytes,
|
|||
scm_t_array_handle h;
|
||||
void *elts;
|
||||
size_t sz;
|
||||
|
||||
|
||||
ra = scm_i_shap2ra (bounds);
|
||||
SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
|
||||
s = SCM_I_ARRAY_DIMS (ra);
|
||||
|
|
@ -229,8 +234,7 @@ scm_from_contiguous_typed_array (SCM type, SCM bounds, const void *bytes,
|
|||
SCM_ASSERT_RANGE (1, bounds, s[k].lbnd <= s[k].ubnd + 1);
|
||||
rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc;
|
||||
}
|
||||
SCM_I_ARRAY_V (ra) =
|
||||
scm_make_generalized_vector (type, scm_from_size_t (rlen), SCM_UNDEFINED);
|
||||
SCM_I_ARRAY_SET_V (ra, scm_make_generalized_vector (type, scm_from_size_t (rlen), SCM_UNDEFINED));
|
||||
|
||||
|
||||
scm_array_get_handle (ra, &h);
|
||||
|
|
@ -273,7 +277,7 @@ scm_from_contiguous_array (SCM bounds, const SCM *elts, size_t len)
|
|||
scm_t_array_dim *s;
|
||||
SCM ra;
|
||||
scm_t_array_handle h;
|
||||
|
||||
|
||||
ra = scm_i_shap2ra (bounds);
|
||||
SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
|
||||
s = SCM_I_ARRAY_DIMS (ra);
|
||||
|
|
@ -288,7 +292,7 @@ scm_from_contiguous_array (SCM bounds, const SCM *elts, size_t len)
|
|||
if (rlen != len)
|
||||
SCM_MISC_ERROR ("element length and dimensions do not match", SCM_EOL);
|
||||
|
||||
SCM_I_ARRAY_V (ra) = scm_c_make_vector (rlen, SCM_UNDEFINED);
|
||||
SCM_I_ARRAY_SET_V (ra, scm_c_make_vector (rlen, SCM_UNDEFINED));
|
||||
scm_array_get_handle (ra, &h);
|
||||
memcpy (h.writable_elements, elts, rlen * sizeof(SCM));
|
||||
scm_array_handle_release (&h);
|
||||
|
|
@ -323,7 +327,7 @@ scm_i_ra_set_contp (SCM ra)
|
|||
SCM_CLR_ARRAY_CONTIGUOUS_FLAG (ra);
|
||||
return;
|
||||
}
|
||||
inc *= (SCM_I_ARRAY_DIMS (ra)[k].ubnd
|
||||
inc *= (SCM_I_ARRAY_DIMS (ra)[k].ubnd
|
||||
- SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1);
|
||||
}
|
||||
}
|
||||
|
|
@ -368,7 +372,7 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1,
|
|||
|
||||
if (SCM_I_ARRAYP (oldra))
|
||||
{
|
||||
SCM_I_ARRAY_V (ra) = SCM_I_ARRAY_V (oldra);
|
||||
SCM_I_ARRAY_SET_V (ra, SCM_I_ARRAY_V (oldra));
|
||||
old_base = old_min = old_max = SCM_I_ARRAY_BASE (oldra);
|
||||
s = scm_array_handle_dims (&old_handle);
|
||||
k = scm_array_handle_rank (&old_handle);
|
||||
|
|
@ -382,7 +386,7 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1,
|
|||
}
|
||||
else
|
||||
{
|
||||
SCM_I_ARRAY_V (ra) = oldra;
|
||||
SCM_I_ARRAY_SET_V (ra, oldra);
|
||||
old_base = old_min = 0;
|
||||
old_max = scm_c_array_length (oldra) - 1;
|
||||
}
|
||||
|
|
@ -398,9 +402,8 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1,
|
|||
ra = scm_make_generalized_vector (scm_array_type (ra),
|
||||
SCM_INUM0, SCM_UNDEFINED);
|
||||
else
|
||||
SCM_I_ARRAY_V (ra) =
|
||||
scm_make_generalized_vector (scm_array_type (ra),
|
||||
SCM_INUM0, SCM_UNDEFINED);
|
||||
SCM_I_ARRAY_SET_V (ra, scm_make_generalized_vector (scm_array_type (ra),
|
||||
SCM_INUM0, SCM_UNDEFINED));
|
||||
scm_array_handle_release (&old_handle);
|
||||
return ra;
|
||||
}
|
||||
|
|
@ -408,7 +411,8 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1,
|
|||
|
||||
imap = scm_apply_0 (mapfunc, scm_reverse (inds));
|
||||
i = scm_array_handle_pos (&old_handle, imap);
|
||||
SCM_I_ARRAY_BASE (ra) = new_min = new_max = i + old_base;
|
||||
new_min = new_max = i + old_base;
|
||||
SCM_I_ARRAY_SET_BASE (ra, new_min);
|
||||
indptr = inds;
|
||||
k = SCM_I_ARRAY_NDIM (ra);
|
||||
while (k--)
|
||||
|
|
@ -450,7 +454,7 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1,
|
|||
|
||||
|
||||
/* args are RA . DIMS */
|
||||
SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
|
||||
SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
|
||||
(SCM ra, SCM args),
|
||||
"Return an array sharing contents with @var{ra}, but with\n"
|
||||
"dimensions arranged in a different order. There must be one\n"
|
||||
|
|
@ -509,8 +513,8 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
|
|||
}
|
||||
ndim++;
|
||||
res = scm_i_make_array (ndim);
|
||||
SCM_I_ARRAY_V (res) = SCM_I_ARRAY_V (ra);
|
||||
SCM_I_ARRAY_BASE (res) = SCM_I_ARRAY_BASE (ra);
|
||||
SCM_I_ARRAY_SET_V (res, SCM_I_ARRAY_V (ra));
|
||||
SCM_I_ARRAY_SET_BASE (res, SCM_I_ARRAY_BASE (ra));
|
||||
for (k = ndim; k--;)
|
||||
{
|
||||
SCM_I_ARRAY_DIMS (res)[k].lbnd = 0;
|
||||
|
|
@ -534,7 +538,7 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
|
|||
r->ubnd = s->ubnd;
|
||||
if (r->lbnd < s->lbnd)
|
||||
{
|
||||
SCM_I_ARRAY_BASE (res) += (s->lbnd - r->lbnd) * r->inc;
|
||||
SCM_I_ARRAY_SET_BASE (res, SCM_I_ARRAY_BASE (res) + (s->lbnd - r->lbnd) * r->inc);
|
||||
r->lbnd = s->lbnd;
|
||||
}
|
||||
r->inc += s->inc;
|
||||
|
|
@ -596,8 +600,8 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
|
|||
SCM sra = scm_i_make_array (1);
|
||||
SCM_I_ARRAY_DIMS (sra)->lbnd = 0;
|
||||
SCM_I_ARRAY_DIMS (sra)->ubnd = len - 1;
|
||||
SCM_I_ARRAY_V (sra) = v;
|
||||
SCM_I_ARRAY_BASE (sra) = SCM_I_ARRAY_BASE (ra);
|
||||
SCM_I_ARRAY_SET_V (sra, v);
|
||||
SCM_I_ARRAY_SET_BASE (sra, SCM_I_ARRAY_BASE (ra));
|
||||
SCM_I_ARRAY_DIMS (sra)->inc = (ndim ? SCM_I_ARRAY_DIMS (ra)[ndim - 1].inc : 1);
|
||||
return sra;
|
||||
}
|
||||
|
|
@ -760,7 +764,7 @@ scm_i_print_array (SCM array, SCM port, scm_print_state *pstate)
|
|||
scm_intprint (h.ndims, 10, port);
|
||||
if (h.element_type != SCM_ARRAY_ELEMENT_TYPE_SCM)
|
||||
scm_write (scm_array_handle_element_type (&h), port);
|
||||
|
||||
|
||||
for (i = 0; i < h.ndims; i++)
|
||||
{
|
||||
if (h.dims[i].lbnd != 0)
|
||||
|
|
|
|||
|
|
@ -54,23 +54,18 @@ SCM_API SCM scm_list_to_typed_array (SCM type, SCM ndim, SCM lst);
|
|||
|
||||
/* internal. */
|
||||
|
||||
typedef struct scm_i_t_array
|
||||
{
|
||||
SCM v; /* the contents of the array, e.g., a vector or uniform vector. */
|
||||
unsigned long base;
|
||||
} scm_i_t_array;
|
||||
|
||||
#define SCM_I_ARRAY_FLAG_CONTIGUOUS (1 << 0)
|
||||
|
||||
#define SCM_I_ARRAYP(a) SCM_TYP16_PREDICATE (scm_tc7_array, a)
|
||||
#define SCM_I_ARRAY_NDIM(x) ((size_t) (SCM_CELL_WORD_0 (x)>>17))
|
||||
#define SCM_I_ARRAY_CONTP(x) (SCM_CELL_WORD_0 (x) & (SCM_I_ARRAY_FLAG_CONTIGUOUS << 16))
|
||||
|
||||
#define SCM_I_ARRAY_MEM(a) ((scm_i_t_array *) SCM_CELL_WORD_1 (a))
|
||||
#define SCM_I_ARRAY_V(a) (SCM_I_ARRAY_MEM (a)->v)
|
||||
#define SCM_I_ARRAY_BASE(a) (SCM_I_ARRAY_MEM (a)->base)
|
||||
#define SCM_I_ARRAY_DIMS(a) \
|
||||
((scm_t_array_dim *)((char *) SCM_I_ARRAY_MEM (a) + sizeof (scm_i_t_array)))
|
||||
#define SCM_I_ARRAY_V(a) SCM_CELL_OBJECT_1 (a)
|
||||
#define SCM_I_ARRAY_BASE(a) ((size_t) SCM_CELL_WORD_2 (a))
|
||||
#define SCM_I_ARRAY_DIMS(a) ((scm_t_array_dim *) SCM_CELL_OBJECT_LOC (a, 3))
|
||||
|
||||
#define SCM_I_ARRAY_SET_V(a, v) SCM_SET_CELL_OBJECT_1(a, v)
|
||||
#define SCM_I_ARRAY_SET_BASE(a, base) SCM_SET_CELL_WORD_2(a, base)
|
||||
|
||||
SCM_INTERNAL SCM scm_i_make_array (int ndim);
|
||||
SCM_INTERNAL int scm_i_print_array (SCM array, SCM port, scm_print_state *pstate);
|
||||
|
|
|
|||
|
|
@ -129,7 +129,6 @@ SCM_DEPRECATED SCM scm_internal_dynamic_wind (scm_t_guard before,
|
|||
#define scm_substring_move_right_x scm_substring_move_right_x__GONE__REPLACE_WITH__scm_substring_move_x
|
||||
#define scm_vtable_index_printer scm_vtable_index_printer__GONE__REPLACE_WITH__scm_vtable_index_instance_printer
|
||||
#define scm_vtable_index_vtable scm_vtable_index_vtable__GONE__REPLACE_WITH__scm_vtable_index_self
|
||||
typedef scm_i_t_array scm_i_t_array__GONE__REPLACE_WITH__scm_t_array;
|
||||
|
||||
#ifndef BUILDING_LIBGUILE
|
||||
#define SCM_ASYNC_TICK SCM_ASYNC_TICK__GONE__REPLACE_WITH__scm_async_tick
|
||||
|
|
|
|||
|
|
@ -900,14 +900,15 @@ table, its existing label is used directly."
|
|||
,(recur (make-uniform-vector-backing-store
|
||||
(uniform-array->bytevector obj)
|
||||
width))))))
|
||||
((array? obj)
|
||||
`((static-patch! ,label 1 ,(recur (shared-array-root obj)))))
|
||||
(else
|
||||
(error "don't know how to intern" obj))))
|
||||
(cond
|
||||
((immediate? obj) #f)
|
||||
((vhash-assoc obj (asm-constants asm)) => cdr)
|
||||
(else
|
||||
;; Note that calling intern may mutate asm-constants and
|
||||
;; asm-constant-inits.
|
||||
;; Note that calling intern may mutate asm-constants and asm-inits.
|
||||
(let* ((label (gensym "constant"))
|
||||
(inits (intern obj label)))
|
||||
(set-asm-constants! asm (vhash-cons obj label (asm-constants asm)))
|
||||
|
|
@ -1230,6 +1231,7 @@ should be .data or .rodata), and return the resulting linker object.
|
|||
(define tc7-program 69)
|
||||
(define tc7-bytevector 77)
|
||||
(define tc7-bitvector 95)
|
||||
(define tc7-array 93)
|
||||
|
||||
(let ((word-size (asm-word-size asm))
|
||||
(endianness (asm-endianness asm)))
|
||||
|
|
@ -1254,6 +1256,8 @@ should be .data or .rodata), and return the resulting linker object.
|
|||
(* 4 word-size))
|
||||
((uniform-vector-backing-store? x)
|
||||
(bytevector-length (uniform-vector-backing-store-bytes x)))
|
||||
((array? x)
|
||||
(* word-size (+ 3 (* 3 (array-rank x)))))
|
||||
(else
|
||||
word-size)))
|
||||
|
||||
|
|
@ -1310,7 +1314,7 @@ should be .data or .rodata), and return the resulting linker object.
|
|||
(write-immediate asm buf pos #f))
|
||||
|
||||
((string? obj)
|
||||
(let ((tag (logior tc7-ro-string (ash (string-length obj) 8))))
|
||||
(let ((tag (logior tc7-ro-string (ash (string-length obj) 8)))) ; FIXME: unused?
|
||||
(case word-size
|
||||
((4)
|
||||
(bytevector-u32-set! buf pos tc7-ro-string endianness)
|
||||
|
|
@ -1385,6 +1389,27 @@ should be .data or .rodata), and return the resulting linker object.
|
|||
;; Need to swap units of element-size bytes
|
||||
(error "FIXME: Implement byte order swap"))))
|
||||
|
||||
((array? obj)
|
||||
(let-values
|
||||
;; array tag + rank + contp flag: see libguile/arrays.h .
|
||||
(((tag) (logior tc7-array (ash (array-rank obj) 17) (ash 1 16)))
|
||||
((bv-set! bvs-set!)
|
||||
(case word-size
|
||||
((4) (values bytevector-u32-set! bytevector-s32-set!))
|
||||
((8) (values bytevector-u64-set! bytevector-s64-set!))
|
||||
(else (error "bad word size")))))
|
||||
(bv-set! buf pos tag endianness)
|
||||
(write-immediate asm buf (+ pos word-size) #f) ; root vector (fixed later)
|
||||
(bv-set! buf (+ pos (* word-size 2)) 0 endianness) ; base
|
||||
(let lp ((pos (+ pos (* word-size 3)))
|
||||
(bounds (array-shape obj))
|
||||
(incs (shared-array-increments obj)))
|
||||
(when (pair? bounds)
|
||||
(bvs-set! buf pos (first (first bounds)) endianness)
|
||||
(bvs-set! buf (+ pos word-size) (second (first bounds)) endianness)
|
||||
(bvs-set! buf (+ pos (* word-size 2)) (first incs) endianness)
|
||||
(lp (+ pos (* 3 word-size)) (cdr bounds) (cdr incs))))))
|
||||
|
||||
(else
|
||||
(error "unrecognized object" obj))))
|
||||
|
||||
|
|
|
|||
|
|
@ -465,6 +465,8 @@
|
|||
(define-syntax c&e
|
||||
(syntax-rules (pass-if pass-if-equal pass-if-exception)
|
||||
"Run the given tests both with the evaluator and the compiler/VM."
|
||||
((_ (pass-if exp))
|
||||
(c&e (pass-if "[unnamed test]" exp)))
|
||||
((_ (pass-if test-name exp))
|
||||
(begin (pass-if (string-append test-name " (eval)")
|
||||
(primitive-eval 'exp))
|
||||
|
|
|
|||
|
|
@ -200,7 +200,7 @@
|
|||
;;; array-equal?
|
||||
;;;
|
||||
|
||||
(with-test-prefix "array-equal?"
|
||||
(with-test-prefix/c&e "array-equal?"
|
||||
|
||||
(pass-if "#s16(...)"
|
||||
(array-equal? #s16(1 2 3) #s16(1 2 3))))
|
||||
|
|
@ -212,7 +212,7 @@
|
|||
(define exception:mapping-out-of-range
|
||||
(cons 'misc-error "^mapping out of range")) ;; per scm_make_shared_array
|
||||
|
||||
(with-test-prefix "make-shared-array"
|
||||
(with-test-prefix/c&e "make-shared-array"
|
||||
|
||||
;; this failed in guile 1.8.0
|
||||
(pass-if "vector unchanged"
|
||||
|
|
@ -283,9 +283,9 @@
|
|||
;;; array-contents
|
||||
;;;
|
||||
|
||||
(with-test-prefix "array-contents"
|
||||
(define (every-two x) (make-shared-array x (lambda (i) (list (* i 2))) 2))
|
||||
|
||||
(define (every-two x) (make-shared-array x (lambda (i) (list (* i 2))) 2))
|
||||
(with-test-prefix/c&e "array-contents"
|
||||
|
||||
(pass-if "simple vector"
|
||||
(let* ((a (make-array 0 4)))
|
||||
|
|
@ -342,30 +342,33 @@
|
|||
(not (array-contents b))))
|
||||
|
||||
;; FIXME maybe this should be allowed.
|
||||
#;
|
||||
(pass-if "broadcast vector -> empty"
|
||||
(let* ((a (make-array 0 4))
|
||||
(b (make-shared-array a (lambda (i j k) (list k)) 0 1 4)))
|
||||
(if #f #f)))
|
||||
;; (pass-if "broadcast vector -> empty"
|
||||
;; (let* ((a (make-array 0 4))
|
||||
;; (b (make-shared-array a (lambda (i j k) (list k)) 0 1 4)))
|
||||
;; (if #f #f)))
|
||||
|
||||
(pass-if "broadcast 2-rank I"
|
||||
(let* ((a #2((1 2 3) (4 5 6)))
|
||||
(b (make-shared-array a (lambda (i j) (list 0 j)) 2 3)))
|
||||
(not (array-contents b))))
|
||||
|
||||
(pass-if "broadcast 2-rank I"
|
||||
(pass-if "broadcast 2-rank II"
|
||||
(let* ((a #2((1 2 3) (4 5 6)))
|
||||
(b (make-shared-array a (lambda (i j) (list i 0)) 2 3)))
|
||||
(not (array-contents b)))))
|
||||
(not (array-contents b))))
|
||||
|
||||
(pass-if "literal array"
|
||||
(not (not (array-contents #2((1 2 3) (4 5 6)))))))
|
||||
|
||||
|
||||
;;;
|
||||
;;; 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)))))
|
||||
|
||||
(define amap1 (lambda (i) (list (* 2 i))))
|
||||
(define amap2 (lambda (i j) (list (+ 1 (* 2 i)) (+ 1 (* 2 j)))))
|
||||
(with-test-prefix/c&e "shared-array-root"
|
||||
|
||||
(pass-if "plain vector"
|
||||
(let* ((a (make-vector 4 0))
|
||||
|
|
@ -395,7 +398,7 @@
|
|||
(define exception:wrong-type-arg
|
||||
(cons #t "Wrong type"))
|
||||
|
||||
(with-test-prefix "transpose-array"
|
||||
(with-test-prefix/c&e "transpose-array"
|
||||
|
||||
(pass-if-exception "non array argument" exception:wrong-type-arg
|
||||
(transpose-array 99))
|
||||
|
|
@ -436,11 +439,11 @@
|
|||
;;; array->list
|
||||
;;;
|
||||
|
||||
(with-test-prefix "array->list"
|
||||
(pass-if-equal '(1 2 3) (array->list #s16(1 2 3)))
|
||||
(pass-if-equal '(1 2 3) (array->list #(1 2 3)))
|
||||
(pass-if-equal '((1 2) (3 4) (5 6)) (array->list #2((1 2) (3 4) (5 6))))
|
||||
(pass-if-equal '() (array->list #()))
|
||||
(with-test-prefix/c&e "array->list"
|
||||
(pass-if-equal "uniform vector" '(1 2 3) (array->list #s16(1 2 3)))
|
||||
(pass-if-equal "vector" '(1 2 3) (array->list #(1 2 3)))
|
||||
(pass-if-equal "rank 2 array" '((1 2) (3 4) (5 6)) (array->list #2((1 2) (3 4) (5 6))))
|
||||
(pass-if-equal "empty vector" '() (array->list #()))
|
||||
|
||||
(pass-if-equal "http://bugs.gnu.org/12465 - ok"
|
||||
'(3 4)
|
||||
|
|
@ -531,7 +534,7 @@
|
|||
;;; array-in-bounds?
|
||||
;;;
|
||||
|
||||
(with-test-prefix "array-in-bounds?"
|
||||
(with-test-prefix/c&e "array-in-bounds?"
|
||||
|
||||
(pass-if (let ((a (make-array #f '(425 425))))
|
||||
(eq? #f (array-in-bounds? a 0)))))
|
||||
|
|
@ -542,7 +545,7 @@
|
|||
|
||||
(with-test-prefix "array-type"
|
||||
|
||||
(with-test-prefix "on make-foo-vector"
|
||||
(with-test-prefix/c&e "on make-foo-vector"
|
||||
|
||||
(pass-if "bool"
|
||||
(eq? 'b (array-type (make-bitvector 1))))
|
||||
|
|
@ -728,7 +731,7 @@
|
|||
;;; syntax
|
||||
;;;
|
||||
|
||||
(with-test-prefix "syntax"
|
||||
(with-test-prefix/c&e "syntax"
|
||||
|
||||
(pass-if "rank and lower bounds"
|
||||
;; uniform u32 array of rank 2 with index ranges 2..3 and 7..8.
|
||||
|
|
@ -770,7 +773,7 @@
|
|||
;;; equal? with vector and one-dimensional array
|
||||
;;;
|
||||
|
||||
(with-test-prefix "equal?"
|
||||
(with-test-prefix/c&e "equal?"
|
||||
(pass-if "array and non-array"
|
||||
(not (equal? #2f64((0 1) (2 3)) 100)))
|
||||
|
||||
|
|
@ -805,12 +808,12 @@
|
|||
;;; slices as generalized vectors
|
||||
;;;
|
||||
|
||||
(let ((array #2u32((0 1) (2 3))))
|
||||
(define (array-row a i)
|
||||
(make-shared-array a (lambda (j) (list i j))
|
||||
(cadr (array-dimensions a))))
|
||||
(with-test-prefix "generalized vector slices"
|
||||
(pass-if (equal? (array-row array 1)
|
||||
#u32(2 3)))
|
||||
(pass-if (equal? (array-ref (array-row array 1) 0)
|
||||
2))))
|
||||
(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)))
|
||||
(pass-if (equal? (array-ref (array-row #2u32((0 1) (2 3)) 1) 0)
|
||||
2)))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue