mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-25 22:12:40 -08:00
Code Issues Projects Releases Packages Wiki Activity
ecl/src/c/array.d
Kris Katterjohn 2c651a9ecd Improve some error messages for functions of exactly one variable 
This changes
  "the value of the first argument"
to
  "the value of the only argument"
in some type-error error messages for functions accepting exactly
one argument.
2017-02-07 16:19:17 -06:00

1425 lines
38 KiB
C
Raw Blame History

/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */
/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */
/*
* array.c - array routines
*
* Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya
* Copyright (c) 1990 Giuseppe Attardi
* Copyright (c) 2001 Juan Jose Garcia Ripoll
*
* See file 'LICENSE' for the copyright details.
*
*/
#include <limits.h>
#include <string.h>
#include <ecl/ecl.h>
#define ECL_DEFINE_AET_SIZE
#include <ecl/internal.h>
static const cl_object ecl_aet_name[] = {
ECL_T, /* ecl_aet_object */
@'single-float', /* ecl_aet_sf */
@'double-float', /* ecl_aet_df */
@'bit', /* ecl_aet_bit: cannot be handled with this code */
@'ext::cl-fixnum', /* ecl_aet_fix */
@'ext::cl-index', /* ecl_aet_index */
@'ext::byte8', /* ecl_aet_b8 */
@'ext::integer8', /* ecl_aet_i8 */
#ifdef ecl_uint16_t
@'ext::byte16',
@'ext::integer16',
#endif
#ifdef ecl_uint32_t
@'ext::byte32',
@'ext::integer32',
#endif
#ifdef ecl_uint64_t
@'ext::byte64',
@'ext::integer64',
#endif
#ifdef ECL_UNICODE
@'character', /* ecl_aet_ch */
#endif
@'base-char' /* ecl_aet_bc */
};
static void FEbad_aet() ecl_attr_noreturn;
static void
FEbad_aet()
{
FEerror(
"A routine from ECL got an object with a bad array element type.\n"
"If you are running a standard copy of ECL, please report this bug.\n"
"If you are embedding ECL into an application, please ensure you\n"
"passed the right value to the array creation routines.\n",0);
}
static cl_index
out_of_bounds_error(cl_index ndx, cl_object x)
{
cl_object type = cl_list(3, @'integer', ecl_make_fixnum(0),
ecl_make_fixnum(x->array.dim));
FEwrong_type_argument(ecl_make_integer(ndx), type);
}
void
FEwrong_dimensions(cl_object a, cl_index rank)
{
cl_object list = cl_make_list(3, ecl_make_fixnum(rank),
@':initial-element', @'*');
cl_object type = cl_list(3, @'array', @'*', list);
FEwrong_type_argument(type, a);
}
static ECL_INLINE cl_index
checked_index(cl_object function, cl_object a, int which, cl_object index,
cl_index nonincl_limit)
{
cl_index output;
unlikely_if (!ECL_FIXNUMP(index) || ecl_fixnum_minusp(index))
FEwrong_index(function, a, which, index, nonincl_limit);
output = ecl_fixnum(index);
unlikely_if (output >= nonincl_limit)
FEwrong_index(function, a, which, index, nonincl_limit);
return output;
}
cl_index
ecl_to_index(cl_object n)
{
switch (ecl_t_of(n)) {
case t_fixnum: {
cl_fixnum out = ecl_fixnum(n);
if (out < 0 || out >= ECL_ARRAY_DIMENSION_LIMIT)
FEtype_error_index(ECL_NIL, out);
return out;
}
default:
FEwrong_type_only_arg(@[coerce], n, @[fixnum]);
}
}
cl_object
cl_row_major_aref(cl_object x, cl_object indx)
{
cl_index j = ecl_to_size(indx);
@(return ecl_aref(x, j));
}
cl_object
si_row_major_aset(cl_object x, cl_object indx, cl_object val)
{
cl_index j = ecl_to_size(indx);
@(return ecl_aset(x, j, val));
}
@(defun aref (x &rest indx)
@ {
cl_index i, j;
cl_index r = narg - 1;
switch (ecl_t_of(x)) {
case t_array:
if (r != x->array.rank)
FEerror("Wrong number of indices.", 0);
for (i = j = 0; i < r; i++) {
cl_index s = checked_index(@[aref], x, i,
ecl_va_arg(indx),
x->array.dims[i]);
j = j*(x->array.dims[i]) + s;
}
break;
case t_vector:
#ifdef ECL_UNICODE
case t_string:
#endif
case t_base_string:
case t_bitvector:
if (r != 1)
FEerror("Wrong number of indices.", 0);
j = checked_index(@[aref], x, -1, ecl_va_arg(indx), x->vector.dim);
break;
default:
FEwrong_type_nth_arg(@[aref], 1, x, @[array]);
}
@(return ecl_aref_unsafe(x, j));
} @)
cl_object
ecl_aref_unsafe(cl_object x, cl_index index)
{
switch (x->array.elttype) {
case ecl_aet_object:
return x->array.self.t[index];
case ecl_aet_bc:
return ECL_CODE_CHAR(x->base_string.self[index]);
#ifdef ECL_UNICODE
case ecl_aet_ch:
return ECL_CODE_CHAR(x->string.self[index]);
#endif
case ecl_aet_bit:
index += x->vector.offset;
if (x->vector.self.bit[index/CHAR_BIT] & (0200>>index%CHAR_BIT))
return(ecl_make_fixnum(1));
else
return(ecl_make_fixnum(0));
case ecl_aet_fix:
return ecl_make_integer(x->array.self.fix[index]);
case ecl_aet_index:
return ecl_make_unsigned_integer(x->array.self.index[index]);
case ecl_aet_sf:
return(ecl_make_single_float(x->array.self.sf[index]));
case ecl_aet_df:
return(ecl_make_double_float(x->array.self.df[index]));
case ecl_aet_b8:
return ecl_make_uint8_t(x->array.self.b8[index]);
case ecl_aet_i8:
return ecl_make_int8_t(x->array.self.i8[index]);
#ifdef ecl_uint16_t
case ecl_aet_b16:
return ecl_make_uint16_t(x->array.self.b16[index]);
case ecl_aet_i16:
return ecl_make_int16_t(x->array.self.i16[index]);
#endif
#ifdef ecl_uint32_t
case ecl_aet_b32:
return ecl_make_uint32_t(x->array.self.b32[index]);
case ecl_aet_i32:
return ecl_make_int32_t(x->array.self.i32[index]);
#endif
#ifdef ecl_uint64_t
case ecl_aet_b64:
return ecl_make_uint64_t(x->array.self.b64[index]);
case ecl_aet_i64:
return ecl_make_int64_t(x->array.self.i64[index]);
#endif
default:
FEbad_aet();
}
}
cl_object
ecl_aref(cl_object x, cl_index index)
{
if (ecl_unlikely(!ECL_ARRAYP(x))) {
FEwrong_type_nth_arg(@[aref], 1, x, @[array]);
}
if (ecl_unlikely(index >= x->array.dim)) {
FEwrong_index(@[row-major-aref], x, -1, ecl_make_fixnum(index),
x->array.dim);
}
return ecl_aref_unsafe(x, index);
}
cl_object
ecl_aref1(cl_object x, cl_index index)
{
if (ecl_unlikely(!ECL_VECTORP(x))) {
FEwrong_type_nth_arg(@[aref], 1, x, @[array]);
}
if (ecl_unlikely(index >= x->array.dim)) {
FEwrong_index(@[aref], x, -1, ecl_make_fixnum(index),
x->array.dim);
}
return ecl_aref_unsafe(x, index);
}
void *
ecl_row_major_ptr(cl_object x, cl_index index, cl_index bytes)
{
cl_index elt_size, offset;
cl_elttype elt_type;
if (ecl_unlikely(!ECL_ARRAYP(x))) {
FEwrong_type_nth_arg(@[aref], 1, x, @[array]);
}
elt_type = x->array.elttype;
if (ecl_unlikely(elt_type == ecl_aet_bit || elt_type == ecl_aet_object))
FEerror("In ecl_row_major_ptr: Specialized array expected, element type ~S found.",
1,ecl_elttype_to_symbol(elt_type));
elt_size = ecl_aet_size[elt_type];
offset = index*elt_size;
/* don't check bounds if bytes == 0 */
if (ecl_unlikely(bytes > 0 && offset + bytes > x->array.dim*elt_size)) {
FEwrong_index(@[row-major-aref], x, -1, ecl_make_fixnum(index),
x->array.dim);
}
return x->array.self.b8 + offset;
}
/*
Internal function for setting array elements:
(si:aset value array dim0 ... dimN)
*/
@(defun si::aset (x &rest dims)
@ {
cl_index i, j;
cl_index r = narg - 2;
cl_object v;
switch (ecl_t_of(x)) {
case t_array:
if (ecl_unlikely(r != x->array.rank))
FEerror("Wrong number of indices.", 0);
for (i = j = 0; i < r; i++) {
cl_index s = checked_index(@[si::aset], x, i,
ecl_va_arg(dims),
x->array.dims[i]);
j = j*(x->array.dims[i]) + s;
}
break;
case t_vector:
#ifdef ECL_UNICODE
case t_string:
#endif
case t_base_string:
case t_bitvector:
if (ecl_unlikely(r != 1))
FEerror("Wrong number of indices.", 0);
j = checked_index(@[si::aset], x, -1, ecl_va_arg(dims),
x->vector.dim);
break;
default:
FEwrong_type_nth_arg(@[si::aset], 1, x, @[array]);
}
v = ecl_va_arg(dims);
@(return ecl_aset_unsafe(x, j, v));
} @)
cl_object
ecl_aset_unsafe(cl_object x, cl_index index, cl_object value)
{
switch (x->array.elttype) {
case ecl_aet_object:
x->array.self.t[index] = value;
break;
case ecl_aet_bc:
/* INV: ecl_char_code() checks the type of `value' */
x->base_string.self[index] = ecl_char_code(value);
break;
#ifdef ECL_UNICODE
case ecl_aet_ch:
x->string.self[index] = ecl_char_code(value);
break;
#endif
case ecl_aet_bit: {
cl_fixnum i = ecl_to_bit(value);
index += x->vector.offset;
if (i == 0)
x->vector.self.bit[index/CHAR_BIT] &= ~(0200>>index%CHAR_BIT);
else
x->vector.self.bit[index/CHAR_BIT] |= 0200>>index%CHAR_BIT;
break;
}
case ecl_aet_fix:
x->array.self.fix[index] = ecl_to_fix(value);
break;
case ecl_aet_index:
x->array.self.index[index] = ecl_to_size(value);
break;
case ecl_aet_sf:
x->array.self.sf[index] = ecl_to_float(value);
break;
case ecl_aet_df:
x->array.self.df[index] = ecl_to_double(value);
break;
case ecl_aet_b8:
x->array.self.b8[index] = ecl_to_uint8_t(value);
break;
case ecl_aet_i8:
x->array.self.i8[index] = ecl_to_int8_t(value);
break;
#ifdef ecl_uint16_t
case ecl_aet_b16:
x->array.self.b16[index] = ecl_to_uint16_t(value);
break;
case ecl_aet_i16:
x->array.self.i16[index] = ecl_to_int16_t(value);
break;
#endif
#ifdef ecl_uint32_t
case ecl_aet_b32:
x->array.self.b32[index] = ecl_to_uint32_t(value);
break;
case ecl_aet_i32:
x->array.self.i32[index] = ecl_to_int32_t(value);
break;
#endif
#ifdef ecl_uint64_t
case ecl_aet_b64:
x->array.self.b64[index] = ecl_to_uint64_t(value);
break;
case ecl_aet_i64:
x->array.self.i64[index] = ecl_to_int64_t(value);
break;
#endif
}
return(value);
}
cl_object
ecl_aset(cl_object x, cl_index index, cl_object value)
{
if (ecl_unlikely(!ECL_ARRAYP(x))) {
FEwrong_type_nth_arg(@[si::aset], 1, x, @[array]);
}
if (ecl_unlikely(index >= x->array.dim)) {
out_of_bounds_error(index, x);
}
return ecl_aset_unsafe(x, index, value);
}
cl_object
ecl_aset1(cl_object x, cl_index index, cl_object value)
{
if (ecl_unlikely(!ECL_VECTORP(x))) {
FEwrong_type_nth_arg(@[si::aset], 1, x, @[array]);
}
if (ecl_unlikely(index >= x->array.dim)) {
out_of_bounds_error(index, x);
}
return ecl_aset_unsafe(x, index, value);
}
/*
Internal function for making arrays of more than one dimension:
(si:make-pure-array dimension-list element-type adjustable
displaced-to displaced-index-offset)
*/
cl_object
si_make_pure_array(cl_object etype, cl_object dims, cl_object adj,
cl_object fillp, cl_object displ, cl_object disploff)
{
cl_index r, s, i, j;
cl_object x;
if (ECL_FIXNUMP(dims)) {
return si_make_vector(etype, dims, adj, fillp, displ, disploff);
} else if (ecl_unlikely(!ECL_LISTP(dims))) {
FEwrong_type_nth_arg(@[make-array], 1, dims,
cl_list(3, @'or', @'list', @'fixnum'));
}
r = ecl_length(dims);
if (ecl_unlikely(r >= ECL_ARRAY_RANK_LIMIT)) {
FEerror("The array rank, ~R, is too large.", 1, ecl_make_fixnum(r));
} else if (r == 1) {
return si_make_vector(etype, ECL_CONS_CAR(dims), adj, fillp,
displ, disploff);
} else if (ecl_unlikely(!Null(fillp))) {
FEerror(":FILL-POINTER may not be specified for an array of rank ~D",
1, ecl_make_fixnum(r));
}
x = ecl_alloc_object(t_array);
x->array.displaced = ECL_NIL;
x->array.self.t = NULL; /* for GC sake */
x->array.rank = r;
x->array.elttype = (short)ecl_symbol_to_elttype(etype);
x->array.flags = 0; /* no fill pointer, no adjustable */
x->array.dims = (cl_index *)ecl_alloc_atomic_align(sizeof(cl_index)*r, sizeof(cl_index));
for (i = 0, s = 1; i < r; i++, dims = ECL_CONS_CDR(dims)) {
cl_object d = ECL_CONS_CAR(dims);
if (ecl_unlikely(!ECL_FIXNUMP(d) ||
ecl_fixnum_minusp(d) ||
ecl_fixnum_greater(d, ecl_make_fixnum(ECL_ARRAY_DIMENSION_LIMIT))))
{
cl_object type = ecl_make_integer_type(ecl_make_fixnum(0),
ecl_make_fixnum(ECL_ARRAY_DIMENSION_LIMIT));
FEwrong_type_nth_arg(@[make-array], 1, d, type);
}
j = ecl_fixnum(d);
s *= (x->array.dims[i] = j);
if (ecl_unlikely(s > ECL_ARRAY_TOTAL_LIMIT)) {
cl_object type = ecl_make_integer_type(ecl_make_fixnum(0),
ecl_make_fixnum(ECL_ARRAY_TOTAL_LIMIT));
FEwrong_type_key_arg(@[make-array], @[array-total-size],
ecl_make_fixnum(s), type);
}
}
x->array.dim = s;
if (adj != ECL_NIL) {
x->array.flags |= ECL_FLAG_ADJUSTABLE;
}
if (Null(displ))
ecl_array_allocself(x);
else
ecl_displace(x, displ, disploff);
@(return x);
}
/*
Internal function for making vectors:
(si:make-vector element-type dimension adjustable fill-pointer
displaced-to displaced-index-offset)
*/
cl_object
si_make_vector(cl_object etype, cl_object dim, cl_object adj,
cl_object fillp, cl_object displ, cl_object disploff)
{
cl_index d, f;
cl_object x;
cl_elttype aet;
AGAIN:
aet = ecl_symbol_to_elttype(etype);
if (ecl_unlikely(!ECL_FIXNUMP(dim) || ecl_fixnum_minusp(dim) ||
ecl_fixnum_greater(dim, ECL_ARRAY_DIMENSION_LIMIT))) {
cl_object type = ecl_make_integer_type(ecl_make_fixnum(0),
ecl_make_fixnum(ECL_ARRAY_DIMENSION_LIMIT));
FEwrong_type_nth_arg(@[make-array], 1, dim, type);
}
d = ecl_fixnum(dim);
if (aet == ecl_aet_bc) {
x = ecl_alloc_object(t_base_string);
x->base_string.elttype = (short)aet;
} else if (aet == ecl_aet_bit) {
x = ecl_alloc_object(t_bitvector);
x->vector.elttype = (short)aet;
#ifdef ECL_UNICODE
} else if (aet == ecl_aet_ch) {
x = ecl_alloc_object(t_string);
x->string.elttype = (short)aet;
#endif
} else {
x = ecl_alloc_object(t_vector);
x->vector.elttype = (short)aet;
}
x->vector.self.t = NULL; /* for GC sake */
x->vector.displaced = ECL_NIL;
x->vector.dim = d;
x->vector.flags = 0;
if (adj != ECL_NIL) {
x->vector.flags |= ECL_FLAG_ADJUSTABLE;
}
if (Null(fillp)) {
f = d;
} else if (fillp == ECL_T) {
x->vector.flags |= ECL_FLAG_HAS_FILL_POINTER;
f = d;
} else if (ECL_FIXNUMP(fillp) && ecl_fixnum_geq(fillp,ecl_make_fixnum(0)) &&
((f = ecl_fixnum(fillp)) <= d)) {
x->vector.flags |= ECL_FLAG_HAS_FILL_POINTER;
} else {
fillp = ecl_type_error(@'make-array',"fill pointer",fillp,
cl_list(3,@'or',cl_list(3,@'member',ECL_NIL,ECL_T),
cl_list(3,@'integer',ecl_make_fixnum(0),
dim)));
goto AGAIN;
}
x->vector.fillp = f;
if (Null(displ))
ecl_array_allocself(x);
else
ecl_displace(x, displ, disploff);
@(return x);
}
cl_object *
alloc_pointerfull_memory(cl_index l)
{
cl_object *p = ecl_alloc_align(sizeof(cl_object) * l, sizeof(cl_object));
cl_index i;
for (i = 0; l--;)
p[i++] = ECL_NIL;
return p;
}
void
ecl_array_allocself(cl_object x)
{
cl_elttype t = x->array.elttype;
cl_index d = x->array.dim;
switch (t) {
/* assign self field only after it has been filled, for GC sake */
case ecl_aet_object:
x->array.self.t = alloc_pointerfull_memory(d);
return;
#ifdef ECL_UNICODE
case ecl_aet_ch: {
ecl_character *elts;
d *= sizeof(ecl_character);
elts = (ecl_character *)ecl_alloc_atomic_align(d, sizeof(ecl_character));
x->string.self = elts;
return;
}
#endif
case ecl_aet_bc: {
cl_index elt_size = 1;
x->vector.self.bc = (ecl_base_char *)ecl_alloc_atomic(d+1);
/* Null terminate the string */
x->vector.self.bc[d] = 0;
break;
}
case ecl_aet_bit:
d = (d + (CHAR_BIT-1)) / CHAR_BIT;
x->vector.self.bit = (byte *)ecl_alloc_atomic(d);
x->vector.offset = 0;
break;
default: {
cl_index elt_size = ecl_aet_size[t];
d *= elt_size;
x->vector.self.bc = (ecl_base_char *)ecl_alloc_atomic_align(d, elt_size);
}
}
}
cl_object
ecl_alloc_simple_vector(cl_index l, cl_elttype aet)
{
cl_object x;
switch (aet) {
case ecl_aet_bc:
x = ecl_alloc_compact_object(t_base_string, l+1);
x->base_string.self = ECL_COMPACT_OBJECT_EXTRA(x);
x->base_string.self[l] = 0;
break;
#ifdef ECL_UNICODE
case ecl_aet_ch:
{
cl_index bytes = sizeof(ecl_character) * l;
x = ecl_alloc_compact_object(t_string, bytes);
x->string.self = ECL_COMPACT_OBJECT_EXTRA(x);
}
break;
#endif
case ecl_aet_bit:
{
cl_index bytes = (l + (CHAR_BIT-1))/CHAR_BIT;
x = ecl_alloc_compact_object(t_bitvector, bytes);
x->vector.self.bit = ECL_COMPACT_OBJECT_EXTRA(x);
x->vector.offset = 0;
}
break;
case ecl_aet_object:
{
x = ecl_alloc_object(t_vector);
x->vector.self.t = alloc_pointerfull_memory(l);
}
break;
default:
x = ecl_alloc_compact_object(t_vector, l * ecl_aet_size[aet]);
x->vector.self.bc = ECL_COMPACT_OBJECT_EXTRA(x);
}
x->base_string.elttype = aet;
x->base_string.flags = 0; /* no fill pointer, not adjustable */
x->base_string.displaced = ECL_NIL;
x->base_string.dim = x->base_string.fillp = l;
return x;
}
cl_elttype
ecl_symbol_to_elttype(cl_object x)
{
BEGIN:
if (x == @'base-char')
return(ecl_aet_bc);
#ifdef ECL_UNICODE
if (x == @'character')
return(ecl_aet_ch);
#endif
else if (x == @'bit')
return(ecl_aet_bit);
else if (x == @'ext::cl-fixnum')
return(ecl_aet_fix);
else if (x == @'ext::cl-index')
return(ecl_aet_index);
else if (x == @'single-float' || x == @'short-float')
return(ecl_aet_sf);
else if (x == @'double-float')
return(ecl_aet_df);
else if (x == @'long-float') {
#ifdef ECL_LONG_FLOAT
return(ecl_aet_object);
#else
return(ecl_aet_df);
#endif
} else if (x == @'ext::byte8')
return(ecl_aet_b8);
else if (x == @'ext::integer8')
return(ecl_aet_i8);
#ifdef ecl_uint16_t
else if (x == @'ext::byte16')
return(ecl_aet_b16);
else if (x == @'ext::integer16')
return(ecl_aet_i16);
#endif
#ifdef ecl_uint32_t
else if (x == @'ext::byte32')
return(ecl_aet_b32);
else if (x == @'ext::integer32')
return(ecl_aet_i32);
#endif
#ifdef ecl_uint64_t
else if (x == @'ext::byte64')
return(ecl_aet_b64);
else if (x == @'ext::integer64')
return(ecl_aet_i64);
#endif
else if (x == @'t')
return(ecl_aet_object);
else if (x == ECL_NIL) {
FEerror("ECL does not support arrays with element type NIL", 0);
}
x = cl_upgraded_array_element_type(1, x);
goto BEGIN;
}
cl_object
ecl_elttype_to_symbol(cl_elttype aet)
{
return ecl_aet_name[aet];
}
cl_object
si_array_element_type_byte_size(cl_object type) {
cl_elttype aet = ECL_ARRAYP(type) ?
type->array.elttype :
ecl_symbol_to_elttype(type);
cl_object size = ecl_make_fixnum(ecl_aet_size[aet]);
if (aet == ecl_aet_bit)
size = ecl_make_ratio(ecl_make_fixnum(1),ecl_make_fixnum(CHAR_BIT));
@(return size ecl_elttype_to_symbol(aet));
}
static void *
address_inc(void *address, cl_fixnum inc, cl_elttype elt_type)
{
union ecl_array_data aux;
aux.t = address;
switch (elt_type) {
case ecl_aet_object:
return aux.t + inc;
case ecl_aet_fix:
return aux.fix + inc;
case ecl_aet_index:
return aux.fix + inc;
case ecl_aet_sf:
return aux.sf + inc;
case ecl_aet_bc:
return aux.bc + inc;
#ifdef ECL_UNICODE
case ecl_aet_ch:
return aux.c + inc;
#endif
case ecl_aet_df:
return aux.df + inc;
case ecl_aet_b8:
case ecl_aet_i8:
return aux.b8 + inc;
#ifdef ecl_uint16_t
case ecl_aet_b16:
case ecl_aet_i16:
return aux.b16 + inc;
#endif
#ifdef ecl_uint32_t
case ecl_aet_b32:
case ecl_aet_i32:
return aux.b32 + inc;
#endif
#ifdef ecl_uint64_t
case ecl_aet_b64:
case ecl_aet_i64:
return aux.b64 + inc;
#endif
default:
FEbad_aet();
}
}
cl_object
cl_array_element_type(cl_object a)
{
@(return ecl_elttype_to_symbol(ecl_array_elttype(a)));
}
/*
Displace(from, to, offset) displaces the from-array
to the to-array (the original array) by the specified offset.
It changes the a_displaced field of both arrays.
The field is a cons; the car of the from-array points to
the to-array and the cdr of the to-array is a list of arrays
displaced to the to-array, so the from-array is pushed to the
cdr of the to-array's array.displaced.
*/
void
ecl_displace(cl_object from, cl_object to, cl_object offset)
{
cl_index j;
void *base;
cl_elttype totype, fromtype;
fromtype = from->array.elttype;
if (ecl_unlikely(!ECL_FIXNUMP(offset) || ((j = ecl_fixnum(offset)) < 0))) {
FEwrong_type_key_arg(@[adjust-array], @[:displaced-index-offset],
offset, @[fixnum]);
}
if (ecl_t_of(to) == t_foreign) {
if (fromtype == ecl_aet_bit || fromtype == ecl_aet_object) {
FEerror("Cannot displace arrays with element type T or BIT onto foreign data",0);
}
base = to->foreign.data;
from->array.displaced = to;
} else {
cl_fixnum maxdim;
totype = to->array.elttype;
if (totype != fromtype)
FEerror("Cannot displace the array, "
"because the element types don't match.", 0);
maxdim = to->array.dim - from->array.dim;
if (maxdim < 0)
FEerror("Cannot displace the array, "
"because the total size of the to-array"
"is too small.", 0);
if (j > maxdim) {
cl_object type = ecl_make_integer_type(ecl_make_fixnum(0),
ecl_make_fixnum(maxdim));
FEwrong_type_key_arg(@[adjust-array], @[:displaced-index-offset],
offset, type);
}
from->array.displaced = ecl_list1(to);
/* We only need to keep track of the arrays that displace to us
* when this one array is adjustable */
if (ECL_ADJUSTABLE_ARRAY_P(to)) {
cl_object track_list = to->array.displaced;
if (Null(track_list))
to->array.displaced =
track_list = ecl_list1(ECL_NIL);
ECL_RPLACD(track_list,
CONS(from, ECL_CONS_CDR(track_list)));
}
if (fromtype == ecl_aet_bit) {
j += to->vector.offset;
from->vector.offset = j%CHAR_BIT;
from->vector.self.bit = to->vector.self.bit + j/CHAR_BIT;
return;
}
base = to->array.self.t;
}
from->array.self.t = address_inc(base, j, fromtype);
}
cl_object
si_array_raw_data(cl_object x)
{
cl_elttype et = ecl_array_elttype(x);
cl_index total_size = x->vector.dim * ecl_aet_size[et];
cl_object output, to_array;
uint8_t *data;
if (et == ecl_aet_object) {
FEerror("EXT:ARRAY-RAW-DATA can not get data "
"from an array with element type T.", 0);
}
data = x->vector.self.b8;
to_array = x->array.displaced;
if (to_array == ECL_NIL || ((to_array = ECL_CONS_CAR(to_array)) == ECL_NIL)) {
cl_index used_size = total_size;
int flags = 0;
if (ECL_ARRAY_HAS_FILL_POINTER_P(x)) {
used_size = x->vector.fillp * ecl_aet_size[et];
flags = ECL_FLAG_HAS_FILL_POINTER;
}
output = ecl_alloc_object(t_vector);
output->vector.elttype = ecl_aet_b8;
output->vector.self.b8 = data;
output->vector.dim = total_size;
output->vector.fillp = used_size;
output->vector.flags = flags;
output->vector.displaced = ECL_NIL;
} else {
cl_index displ = data - to_array->vector.self.b8;
cl_object fillp = ECL_NIL;
if (ECL_ARRAY_HAS_FILL_POINTER_P(x)) {
fillp = ecl_make_fixnum(x->vector.fillp * ecl_aet_size[et]);
}
output = si_make_vector(@'ext::byte8',
ecl_make_fixnum(total_size),
ECL_NIL,
fillp,
si_array_raw_data(to_array),
ecl_make_fixnum(displ));
}
@(return output);
}
cl_elttype
ecl_array_elttype(cl_object x)
{
if (ecl_unlikely(!ECL_ARRAYP(x)))
FEwrong_type_argument(@[array], x);
return x->array.elttype;
}
cl_object
cl_array_rank(cl_object a)
{
@(return ecl_make_fixnum(ecl_array_rank(a)));
}
cl_index
ecl_array_rank(cl_object a)
{
switch (ecl_t_of(a)) {
case t_array:
return a->array.rank;
#ifdef ECL_UNICODE
case t_string:
#endif
case t_base_string:
case t_vector:
case t_bitvector:
return 1;
default:
FEwrong_type_only_arg(@[array-rank], a, @[array]);
}
}
cl_object
cl_array_dimension(cl_object a, cl_object index)
{
@(return ecl_make_fixnum(ecl_array_dimension(a, ecl_to_size(index))));
}
cl_index
ecl_array_dimension(cl_object a, cl_index index)
{
switch (ecl_t_of(a)) {
case t_array: {
if (ecl_unlikely(index > a->array.rank))
FEwrong_dimensions(a, index+1);
return a->array.dims[index];
}
#ifdef ECL_UNICODE
case t_string:
#endif
case t_base_string:
case t_vector:
case t_bitvector:
if (ecl_unlikely(index))
FEwrong_dimensions(a, index+1);
return a->vector.dim;
default:
FEwrong_type_only_arg(@[array-dimension], a, @[array]);
}
}
cl_object
cl_array_total_size(cl_object a)
{
if (ecl_unlikely(!ECL_ARRAYP(a)))
FEwrong_type_only_arg(@[array-total-size], a, @[array]);
@(return ecl_make_fixnum(a->array.dim));
}
cl_object
cl_adjustable_array_p(cl_object a)
{
if (ecl_unlikely(!ECL_ARRAYP(a)))
FEwrong_type_only_arg(@[adjustable-array-p], a, @[array]);
@(return (ECL_ADJUSTABLE_ARRAY_P(a) ? ECL_T : ECL_NIL));
}
/*
Internal function for checking if an array is displaced.
*/
cl_object
cl_array_displacement(cl_object a)
{
const cl_env_ptr the_env = ecl_process_env();
cl_object to_array;
cl_index offset;
if (ecl_unlikely(!ECL_ARRAYP(a)))
FEwrong_type_only_arg(@[array-displacement], a, @[array]);
to_array = a->array.displaced;
if (Null(to_array)) {
offset = 0;
} else if (Null(to_array = CAR(a->array.displaced))) {
offset = 0;
} else {
switch (a->array.elttype) {
case ecl_aet_object:
offset = a->array.self.t - to_array->array.self.t;
break;
case ecl_aet_bc:
offset = a->array.self.bc - to_array->array.self.bc;
break;
#ifdef ECL_UNICODE
case ecl_aet_ch:
offset = a->array.self.c - to_array->array.self.c;
break;
#endif
case ecl_aet_bit:
offset = a->array.self.bit - to_array->array.self.bit;
offset = offset * CHAR_BIT + a->array.offset
- to_array->array.offset;
break;
case ecl_aet_fix:
offset = a->array.self.fix - to_array->array.self.fix;
break;
case ecl_aet_index:
offset = a->array.self.fix - to_array->array.self.fix;
break;
case ecl_aet_sf:
offset = a->array.self.sf - to_array->array.self.sf;
break;
case ecl_aet_df:
offset = a->array.self.df - to_array->array.self.df;
break;
case ecl_aet_b8:
case ecl_aet_i8:
offset = a->array.self.b8 - to_array->array.self.b8;
break;
#ifdef ecl_uint16_t
case ecl_aet_b16:
case ecl_aet_i16:
offset = a->array.self.b16 - to_array->array.self.b16;
break;
#endif
#ifdef ecl_uint32_t
case ecl_aet_b32:
case ecl_aet_i32:
offset = a->array.self.b32 - to_array->array.self.b32;
break;
#endif
#ifdef ecl_uint64_t
case ecl_aet_b64:
case ecl_aet_i64:
offset = a->array.self.b64 - to_array->array.self.b64;
break;
#endif
default:
FEbad_aet();
}
}
ecl_return2(the_env, to_array, ecl_make_fixnum(offset));
}
cl_object
cl_svref(cl_object x, cl_object index)
{
const cl_env_ptr the_env = ecl_process_env();
cl_index i;
if (ecl_unlikely(ecl_t_of(x) != t_vector ||
(x->vector.flags & (ECL_FLAG_ADJUSTABLE | ECL_FLAG_HAS_FILL_POINTER)) ||
CAR(x->vector.displaced) != ECL_NIL ||
(cl_elttype)x->vector.elttype != ecl_aet_object))
{
FEwrong_type_nth_arg(@[svref],1,x,@[simple-vector]);
}
i = checked_index(@[svref], x, -1, index, x->vector.dim);
ecl_return1(the_env, x->vector.self.t[i]);
}
cl_object
si_svset(cl_object x, cl_object index, cl_object v)
{
const cl_env_ptr the_env = ecl_process_env();
cl_index i;
if (ecl_unlikely(ecl_t_of(x) != t_vector ||
(x->vector.flags & (ECL_FLAG_ADJUSTABLE | ECL_FLAG_HAS_FILL_POINTER)) ||
CAR(x->vector.displaced) != ECL_NIL ||
(cl_elttype)x->vector.elttype != ecl_aet_object))
{
FEwrong_type_nth_arg(@[si::svset],1,x,@[simple-vector]);
}
i = checked_index(@[svref], x, -1, index, x->vector.dim);
ecl_return1(the_env, x->vector.self.t[i] = v);
}
cl_object
cl_array_has_fill_pointer_p(cl_object a)
{
const cl_env_ptr the_env = ecl_process_env();
cl_object r;
switch (ecl_t_of(a)) {
case t_array:
r = ECL_NIL; break;
case t_vector:
case t_bitvector:
#ifdef ECL_UNICODE
case t_string:
#endif
case t_base_string:
r = ECL_ARRAY_HAS_FILL_POINTER_P(a)? ECL_T : ECL_NIL;
break;
default:
FEwrong_type_only_arg(@[array-has-fill-pointer-p],a,@[array]);
}
ecl_return1(the_env, r);
}
cl_object
cl_fill_pointer(cl_object a)
{
const cl_env_ptr the_env = ecl_process_env();
if (ecl_unlikely(!ECL_VECTORP(a)))
FEwrong_type_only_arg(@[fill-pointer], a, @[vector]);
if (ecl_unlikely(!ECL_ARRAY_HAS_FILL_POINTER_P(a))) {
const char *type = "(AND VECTOR (SATISFIES ARRAY-HAS-FILL-POINTER-P))";
FEwrong_type_only_arg(@[fill-pointer], a, ecl_read_from_cstring(type));
}
ecl_return1(the_env, ecl_make_fixnum(a->vector.fillp));
}
/*
Internal function for setting fill pointer.
*/
cl_object
si_fill_pointer_set(cl_object a, cl_object fp)
{
const cl_env_ptr the_env = ecl_process_env();
cl_fixnum i;
if (ecl_unlikely(!ECL_VECTORP(a) || !ECL_ARRAY_HAS_FILL_POINTER_P(a))) {
const char *type = "(AND VECTOR (SATISFIES ARRAY-HAS-FILL-POINTER-P))";
FEwrong_type_nth_arg(@[adjust-array], 1, a,
ecl_read_from_cstring(type));
}
if (ecl_unlikely(!ECL_FIXNUMP(fp) || ((i = ecl_fixnum(fp)) < 0) ||
(i > a->vector.dim))) {
cl_object type = ecl_make_integer_type(ecl_make_fixnum(0),
ecl_make_fixnum(a->vector.dim-1));
FEwrong_type_key_arg(@[adjust-array], @[:fill-pointer], fp, type);
}
a->vector.fillp = i;
ecl_return1(the_env, fp);
}
/*
Internal function for replacing the contents of arrays:
(si:replace-array old-array new-array).
Used in ADJUST-ARRAY.
*/
cl_object
si_replace_array(cl_object olda, cl_object newa)
{
const cl_env_ptr the_env = ecl_process_env();
cl_object dlist;
if (ecl_t_of(olda) != ecl_t_of(newa)
|| (ecl_t_of(olda) == t_array && olda->array.rank != newa->array.rank))
goto CANNOT;
if (!ECL_ADJUSTABLE_ARRAY_P(olda)) {
/* When an array is not adjustable, we simply output the new array */
olda = newa;
goto OUTPUT;
}
for (dlist = CDR(olda->array.displaced); dlist != ECL_NIL; dlist = CDR(dlist)) {
cl_object other_array = CAR(dlist);
cl_object offset;
cl_array_displacement(other_array);
offset = ecl_nth_value(the_env, 1);
ecl_displace(other_array, newa, offset);
}
switch (ecl_t_of(olda)) {
case t_array:
case t_vector:
case t_bitvector:
olda->array = newa->array;
break;
#ifdef ECL_UNICODE
case t_string:
#endif
case t_base_string:
olda->base_string = newa->base_string;
break;
default:
CANNOT:
FEerror("Cannot replace the array ~S by the array ~S.",
2, olda, newa);
}
OUTPUT:
ecl_return1(the_env, olda);
}
void
ecl_copy_subarray(cl_object dest, cl_index i0, cl_object orig,
cl_index i1, cl_index l)
{
cl_elttype t = ecl_array_elttype(dest);
if (i0 + l > dest->array.dim) {
l = dest->array.dim - i0;
}
if (i1 + l > orig->array.dim) {
l = orig->array.dim - i1;
}
if (t != ecl_array_elttype(orig) || t == ecl_aet_bit) {
if (dest == orig && i0 > i1) {
for (i0 += l, i1 += l; l--; ) {
ecl_aset_unsafe(dest, --i0,
ecl_aref_unsafe(orig, --i1));
}
} else {
while (l--) {
ecl_aset_unsafe(dest, i0++,
ecl_aref_unsafe(orig, i1++));
}
}
} else {
/* We could have singled out also dest == orig and used memcpy
* but gcc-4.6 breaks this code even when i0 < i1 if the regions
* overlap sufficiently. */
cl_index elt_size = ecl_aet_size[t];
memmove(dest->array.self.bc + i0 * elt_size,
orig->array.self.bc + i1 * elt_size,
l * elt_size);
}
}
void
ecl_reverse_subarray(cl_object x, cl_index i0, cl_index i1)
{
cl_elttype t = ecl_array_elttype(x);
cl_index i, j;
if (x->array.dim == 0) {
return;
}
if (i1 >= x->array.dim) {
i1 = x->array.dim;
}
switch (t) {
case ecl_aet_object:
case ecl_aet_fix:
case ecl_aet_index:
for (i = i0, j = i1-1; i < j; i++, --j) {
cl_object y = x->vector.self.t[i];
x->vector.self.t[i] = x->vector.self.t[j];
x->vector.self.t[j] = y;
}
break;
case ecl_aet_sf:
for (i = i0, j = i1-1; i < j; i++, --j) {
float y = x->array.self.sf[i];
x->array.self.sf[i] = x->array.self.sf[j];
x->array.self.sf[j] = y;
}
break;
case ecl_aet_df:
for (i = i0, j = i1-1; i < j; i++, --j) {
double y = x->array.self.df[i];
x->array.self.df[i] = x->array.self.df[j];
x->array.self.df[j] = y;
}
break;
case ecl_aet_bc:
for (i = i0, j = i1-1; i < j; i++, --j) {
ecl_base_char y = x->array.self.bc[i];
x->array.self.bc[i] = x->array.self.bc[j];
x->array.self.bc[j] = y;
}
break;
case ecl_aet_b8:
case ecl_aet_i8:
for (i = i0, j = i1-1; i < j; i++, --j) {
ecl_uint8_t y = x->array.self.b8[i];
x->array.self.b8[i] = x->array.self.b8[j];
x->array.self.b8[j] = y;
}
break;
#ifdef ecl_uint16_t
case ecl_aet_b16:
case ecl_aet_i16:
for (i = i0, j = i1-1; i < j; i++, --j) {
ecl_uint16_t y = x->array.self.b16[i];
x->array.self.b16[i] = x->array.self.b16[j];
x->array.self.b16[j] = y;
}
break;
#endif
#ifdef ecl_uint32_t
case ecl_aet_b32:
case ecl_aet_i32:
for (i = i0, j = i1-1; i < j; i++, --j) {
ecl_uint32_t y = x->array.self.b32[i];
x->array.self.b32[i] = x->array.self.b32[j];
x->array.self.b32[j] = y;
}
break;
#endif
#ifdef ecl_uint64_t
case ecl_aet_b64:
case ecl_aet_i64:
for (i = i0, j = i1-1; i < j; i++, --j) {
ecl_uint64_t y = x->array.self.b64[i];
x->array.self.b64[i] = x->array.self.b64[j];
x->array.self.b64[j] = y;
}
break;
#endif
#ifdef ECL_UNICODE
case ecl_aet_ch:
for (i = i0, j = i1-1; i < j; i++, --j) {
ecl_character y = x->array.self.c[i];
x->array.self.c[i] = x->array.self.c[j];
x->array.self.c[j] = y;
}
break;
#endif
case ecl_aet_bit:
for (i = i0 + x->vector.offset,
j = i1 + x->vector.offset - 1;
i < j;
i++, --j) {
int k = x->array.self.bit[i/CHAR_BIT]&(0200>>i%CHAR_BIT);
if (x->array.self.bit[j/CHAR_BIT]&(0200>>j%CHAR_BIT))
x->array.self.bit[i/CHAR_BIT]
|= 0200>>i%CHAR_BIT;
else
x->array.self.bit[i/CHAR_BIT]
&= ~(0200>>i%CHAR_BIT);
if (k)
x->array.self.bit[j/CHAR_BIT]
|= 0200>>j%CHAR_BIT;
else
x->array.self.bit[j/CHAR_BIT]
&= ~(0200>>j%CHAR_BIT);
}
break;
default:
FEbad_aet();
}
}
cl_object
si_copy_subarray(cl_object dest, cl_object start0,
cl_object orig, cl_object start1, cl_object length)
{
ecl_copy_subarray(dest, ecl_to_size(start0),
orig, ecl_to_size(start1),
ecl_to_size(length));
@(return dest);
}
cl_object
si_fill_array_with_elt(cl_object x, cl_object elt, cl_object start, cl_object end)
{
cl_elttype t = ecl_array_elttype(x);
cl_index first = ecl_to_size(start);
cl_index last = Null(end)? x->array.dim : ecl_to_size(end);
if (first >= last) {
goto END;
}
switch (t) {
case ecl_aet_object: {
cl_object *p = x->vector.self.t + first;
for (first = last - first; first; --first, ++p) { *p = elt; }
break;
}
case ecl_aet_bc: {
ecl_base_char e = ecl_char_code(elt);
ecl_base_char *p = x->vector.self.bc + first;
for (first = last - first; first; --first, ++p) { *p = e; }
break;
}
#ifdef ECL_UNICODE
case ecl_aet_ch: {
ecl_character e = ecl_char_code(elt);
ecl_character *p = x->vector.self.c + first;
for (first = last - first; first; --first, ++p) { *p = e; }
break;
}
#endif
case ecl_aet_fix: {
cl_fixnum e = ecl_to_fix(elt);
cl_fixnum *p = x->vector.self.fix + first;
for (first = last - first; first; --first, ++p) { *p = e; }
break;
}
case ecl_aet_index: {
cl_index e = ecl_to_size(elt);
cl_index *p = x->vector.self.index + first;
for (first = last - first; first; --first, ++p) { *p = e; }
break;
}
case ecl_aet_sf: {
float e = ecl_to_float(elt);
float *p = x->vector.self.sf + first;
for (first = last - first; first; --first, ++p) { *p = e; }
break;
}
case ecl_aet_df: {
double e = ecl_to_double(elt);
double *p = x->vector.self.df + first;
for (first = last - first; first; --first, ++p) { *p = e; }
break;
}
case ecl_aet_b8: {
uint8_t e = ecl_to_uint8_t(elt);
uint8_t *p = x->vector.self.b8 + first;
for (first = last - first; first; --first, ++p) { *p = e; }
break;
}
case ecl_aet_i8: {
int8_t e = ecl_to_int8_t(elt);
int8_t *p = x->vector.self.i8 + first;
for (first = last - first; first; --first, ++p) { *p = e; }
break;
}
#ifdef ecl_uint16_t
case ecl_aet_b16: {
ecl_uint16_t e = ecl_to_uint16_t(elt);
ecl_uint16_t *p = x->vector.self.b16 + first;
for (first = last - first; first; --first, ++p) { *p = e; }
break;
}
case ecl_aet_i16: {
ecl_int16_t e = ecl_to_int16_t(elt);
ecl_int16_t *p = x->vector.self.i16 + first;
for (first = last - first; first; --first, ++p) { *p = e; }
break;
}
#endif
#ifdef ecl_uint32_t
case ecl_aet_b32: {
ecl_uint32_t e = ecl_to_uint32_t(elt);
ecl_uint32_t *p = x->vector.self.b32 + first;
for (first = last - first; first; --first, ++p) { *p = e; }
break;
}
case ecl_aet_i32: {
ecl_int32_t e = ecl_to_int32_t(elt);
ecl_int32_t *p = x->vector.self.i32 + first;
for (first = last - first; first; --first, ++p) { *p = e; }
break;
}
#endif
#ifdef ecl_uint64_t
case ecl_aet_b64: {
ecl_uint64_t e = ecl_to_uint64_t(elt);
ecl_uint64_t *p = x->vector.self.b64 + first;
for (first = last - first; first; --first, ++p) { *p = e; }
break;
}
case ecl_aet_i64: {
ecl_int64_t e = ecl_to_int64_t(elt);
ecl_int64_t *p = x->vector.self.i64 + first;
for (first = last - first; first; --first, ++p) { *p = e; }
break;
}
#endif
case ecl_aet_bit: {
int i = ecl_to_bit(elt);
for (last -= first, first += x->vector.offset; last; --last, ++first) {
int mask = 0200>>first%CHAR_BIT;
if (i == 0)
x->vector.self.bit[first/CHAR_BIT] &= ~mask;
else
x->vector.self.bit[first/CHAR_BIT] |= mask;
}
break;
}
default:
FEbad_aet();
}
END:
@(return x);
}
Reference in a new issue View git blame Copy permalink