mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-15 13:52:16 -08:00
Code Issues Projects Releases Packages Wiki Activity
ecl/src/c/array.d

1325 lines
34 KiB
C
Raw Blame History

/* -*- mode: c; c-basic-offset: 8 -*- */
/*
array.c -- Array routines
*/
/*
Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
Copyright (c) 1990, Giuseppe Attardi.
Copyright (c) 2001, Juan Jose Garcia Ripoll.
ECL is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
See file '../Copyright' for full details.
*/
#include <limits.h>
#include <string.h>
#include <ecl/ecl.h>
#include <ecl/internal.h>
static const cl_index ecl_aet_size[] = {
sizeof(cl_object), /* aet_object */
sizeof(float), /* aet_sf */
sizeof(double), /* aet_df */
0, /* aet_bit: cannot be handled with this code */
sizeof(cl_fixnum), /* aet_fix */
sizeof(cl_index), /* aet_index */
sizeof(uint8_t), /* aet_b8 */
sizeof(int8_t), /* aet_i8 */
#ifdef ecl_uint16_t
sizeof(ecl_uint16_t),
sizeof(ecl_int16_t),
#endif
#ifdef ecl_uint32_t
sizeof(ecl_uint32_t),
sizeof(ecl_int32_t),
#endif
#ifdef ecl_uint64_t
sizeof(ecl_uint64_t),
sizeof(ecl_int64_t),
#endif
#ifdef ECL_UNICODE
sizeof(ecl_character), /* aet_ch */
#endif
sizeof(unsigned char) /* aet_bc */
};
static const cl_object ecl_aet_name[] = {
Ct, /* aet_object */
@'single-float', /* aet_sf */
@'double-float', /* aet_df */
@'bit', /* aet_bit: cannot be handled with this code */
@'ext::cl-fixnum', /* aet_fix */
@'ext::cl-index', /* aet_index */
@'ext::byte8', /* aet_b8 */
@'ext::integer8', /* 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', /* aet_ch */
#endif
@'base-char' /* aet_bc */
};
static void displace (cl_object from, cl_object to, cl_object offset);
static void check_displaced (cl_object dlist, cl_object orig, cl_index newdim);
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', MAKE_FIXNUM(0),
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(rank, @':initial-element', @'*');
cl_object type = cl_list(3, @'array', @'*', list);
FEwrong_type_argument(type, a);
}
void
FEwrong_index(cl_object a, cl_index ndx, cl_index upper)
{
const char *message =
"~D is not a valid index into object ~A.~%"
"It should be non-negative and < ~D.";
cl_object type = cl_list(3, @'integer', MAKE_FIXNUM(0),
ecl_make_integer(upper));
cl_error(5, @'simple-type-error',
@':format-control',
make_constant_base_string(message),
@':format-arguments',
cl_list(3, ecl_make_integer(ndx), a, ecl_make_integer(upper)));
}
cl_index
ecl_to_index(cl_object n)
{
switch (type_of(n)) {
case t_fixnum: {
cl_fixnum out = fix(n);
if (out < 0 || out >= ADIMLIM)
FEtype_error_index(Cnil, n);
return out;
}
case t_bignum:
FEtype_error_index(Cnil, n);
default:
FEtype_error_integer(n);
}
}
cl_object
cl_row_major_aref(cl_object x, cl_object indx)
{
cl_index j = fixnnint(indx);
@(return ecl_aref(x, j))
}
cl_object
si_row_major_aset(cl_object x, cl_object indx, cl_object val)
{
cl_index j = fixnnint(indx);
@(return ecl_aset(x, j, val))
}
@(defun aref (x &rest indx)
@ {
cl_index i, j;
cl_index r = narg - 1;
AGAIN:
switch (type_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 =
ecl_fixnum_in_range(@'aref',"index",cl_va_arg(indx),
0, (cl_fixnum)x->array.dims[i]-1);
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 = ecl_fixnum_in_range(@'aref',"index",cl_va_arg(indx),
0, (cl_fixnum)x->vector.dim-1);
break;
default:
x = ecl_type_error(@'aref',"argument",x,@'array');
goto AGAIN;
}
@(return ecl_aref_unsafe(x, j));
} @)
cl_object
ecl_aref_unsafe(cl_object x, cl_index index)
{
switch (x->array.elttype) {
case aet_object:
return x->array.self.t[index];
case aet_bc:
return CODE_CHAR(x->base_string.self[index]);
#ifdef ECL_UNICODE
case aet_ch:
return CODE_CHAR(x->string.self[index]);
#endif
case aet_bit:
index += x->vector.offset;
if (x->vector.self.bit[index/CHAR_BIT] & (0200>>index%CHAR_BIT))
return(MAKE_FIXNUM(1));
else
return(MAKE_FIXNUM(0));
case aet_fix:
return ecl_make_integer(x->array.self.fix[index]);
case aet_index:
return ecl_make_unsigned_integer(x->array.self.index[index]);
case aet_sf:
return(ecl_make_singlefloat(x->array.self.sf[index]));
case aet_df:
return(ecl_make_doublefloat(x->array.self.df[index]));
case aet_b8:
return ecl_make_uint8_t(x->array.self.b8[index]);
case aet_i8:
return ecl_make_int8_t(x->array.self.i8[index]);
#ifdef ecl_uint16_t
case aet_b16:
return ecl_make_uint16_t(x->array.self.b16[index]);
case aet_i16:
return ecl_make_int16_t(x->array.self.i16[index]);
#endif
#ifdef ecl_uint32_t
case aet_b32:
return ecl_make_uint32_t(x->array.self.b32[index]);
case aet_i32:
return ecl_make_int32_t(x->array.self.i32[index]);
#endif
#ifdef ecl_uint64_t
case aet_b64:
return ecl_make_uint64_t(x->array.self.b64[index]);
case 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_ARRAYP(x)) {
if (index < x->array.dim) {
return ecl_aref_unsafe(x, index);
}
out_of_bounds_error(index, x);
}
FEtype_error_array(x);
}
cl_object
ecl_aref1(cl_object x, cl_index index)
{
if (ECL_VECTORP(x)) {
if (index < x->array.dim) {
return ecl_aref_unsafe(x, index);
}
out_of_bounds_error(index, x);
}
FEtype_error_array(x);
}
/*
Internal function for setting array elements:
(si:aset value array dim0 ... dimN)
*/
@(defun si::aset (v x &rest dims)
@ {
cl_index i, j;
cl_index r = narg - 2;
AGAIN:
switch (type_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 =
ecl_fixnum_in_range(@'si::aset',"index",cl_va_arg(dims),
0, (cl_fixnum)x->array.dims[i]-1);
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 = ecl_fixnum_in_range(@'si::aset',"index",cl_va_arg(dims),
0, (cl_fixnum)x->vector.dim - 1);
break;
default:
x = ecl_type_error(@'si::aset',"destination",v,@'array');
goto AGAIN;
}
@(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 aet_object:
x->array.self.t[index] = value;
break;
case 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 aet_ch:
x->string.self[index] = ecl_char_code(value);
break;
#endif
case aet_bit: {
cl_fixnum i = ecl_fixnum_in_range(Cnil,"ASET value",value,0,1);
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 aet_fix:
x->array.self.fix[index] = fixint(value);
break;
case aet_index:
x->array.self.index[index] = fixnnint(value);
break;
case aet_sf:
x->array.self.sf[index] = ecl_to_float(value);
break;
case aet_df:
x->array.self.df[index] = ecl_to_double(value);
break;
case aet_b8:
x->array.self.b8[index] = ecl_to_uint8_t(value);
break;
case aet_i8:
x->array.self.i8[index] = ecl_to_int8_t(value);
break;
#ifdef ecl_uint16_t
case aet_b16:
x->array.self.b16[index] = ecl_to_uint16_t(value);
break;
case aet_i16:
x->array.self.i16[index] = ecl_to_int16_t(value);
break;
#endif
#ifdef ecl_uint32_t
case aet_b32:
x->array.self.b32[index] = ecl_to_uint32_t(value);
break;
case aet_i32:
x->array.self.i32[index] = ecl_to_int32_t(value);
break;
#endif
#ifdef ecl_uint64_t
case aet_b64:
x->array.self.b64[index] = ecl_to_uint64_t(value);
break;
case 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_ARRAYP(x)) {
if (index < x->array.dim)
return ecl_aset_unsafe(x, index, value);
out_of_bounds_error(index, x);
}
FEtype_error_array(x);
}
cl_object
ecl_aset1(cl_object x, cl_index index, cl_object value)
{
if (ECL_VECTORP(x)) {
if (index < x->array.dim)
return ecl_aset_unsafe(x, index, value);
out_of_bounds_error(index, x);
}
FEtype_error_array(x);
}
/*
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 (FIXNUMP(dims)) {
return si_make_vector(etype, dims, adj, fillp, displ, disploff);
}
r = ecl_length(dims);
if (r >= ARANKLIM) {
FEerror("The array rank, ~R, is too large.", 1, MAKE_FIXNUM(r));
} else if (r == 1) {
return si_make_vector(etype, ECL_CONS_CAR(dims), adj, fillp,
displ, disploff);
} else if (!Null(fillp)) {
FEerror(":FILL-POINTER may not be specified for an array of rank ~D",
1, MAKE_FIXNUM(r));
}
x = ecl_alloc_object(t_array);
x->array.displaced = Cnil;
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)) {
j = ecl_fixnum_in_range(@'make-array', "dimension",
ECL_CONS_CAR(dims), 0, ADIMLIM);
s *= (x->array.dims[i] = j);
if (s > ATOTLIM)
FEerror("The array total size, ~D, is too large.", 1, MAKE_FIXNUM(s));
}
x->array.dim = s;
if (adj != Cnil) {
x->array.flags |= ECL_FLAG_ADJUSTABLE;
}
if (Null(displ))
ecl_array_allocself(x);
else
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);
d = ecl_fixnum_in_range(@'make-array',"dimension",dim,0,ADIMLIM);
if (aet == aet_bc) {
x = ecl_alloc_object(t_base_string);
x->base_string.elttype = (short)aet;
} else if (aet == aet_bit) {
x = ecl_alloc_object(t_bitvector);
x->vector.elttype = (short)aet;
#ifdef ECL_UNICODE
} else if (aet == 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 = Cnil;
x->vector.dim = d;
x->vector.flags = 0;
if (adj != Cnil) {
x->vector.flags |= ECL_FLAG_ADJUSTABLE;
}
if (Null(fillp)) {
f = d;
} else if (fillp == Ct) {
x->vector.flags |= ECL_FLAG_HAS_FILL_POINTER;
f = d;
} else if (FIXNUMP(fillp) && ((f = fix(fillp)) <= d) && (f >= 0)) {
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',Cnil,Ct),
cl_list(3,@'integer',MAKE_FIXNUM(0),
dim)));
goto AGAIN;
}
x->vector.fillp = f;
if (Null(displ))
ecl_array_allocself(x);
else
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++] = Cnil;
return p;
}
void
ecl_array_allocself(cl_object x)
{
cl_elttype t = x->array.elttype;
cl_index i, d = x->array.dim;
switch (t) {
/* assign self field only after it has been filled, for GC sake */
case aet_object:
x->array.self.t = alloc_pointerfull_memory(d);
return;
#ifdef ECL_UNICODE
case 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 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 aet_bc:
x = ecl_alloc_compact_object(t_base_string, l+1);
x->base_string.self = ECL_COMPACT_OBJECT_EXTRA(x);
memset(x->base_string.self, 0, l+1);
break;
#ifdef ECL_UNICODE
case 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 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 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 = Cnil;
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(aet_bc);
#ifdef ECL_UNICODE
if (x == @'character')
return(aet_ch);
#endif
else if (x == @'bit')
return(aet_bit);
else if (x == @'ext::cl-fixnum')
return(aet_fix);
else if (x == @'ext::cl-index')
return(aet_index);
else if (x == @'single-float' || x == @'short-float')
return(aet_sf);
else if (x == @'double-float')
return(aet_df);
else if (x == @'long-float') {
#ifdef ECL_LONG_FLOAT
return(aet_object);
#else
return(aet_df);
#endif
} else if (x == @'ext::byte8')
return(aet_b8);
else if (x == @'ext::integer8')
return(aet_i8);
#ifdef ecl_uint16_t
else if (x == @'ext::byte16')
return(aet_b16);
else if (x == @'ext::integer16')
return(aet_i16);
#endif
#ifdef ecl_uint32_t
else if (x == @'ext::byte32')
return(aet_b32);
else if (x == @'ext::integer32')
return(aet_i32);
#endif
#ifdef ecl_uint64_t
else if (x == @'ext::byte64')
return(aet_b64);
else if (x == @'ext::integer64')
return(aet_i64);
#endif
else if (x == @'t')
return(aet_object);
else if (x == Cnil) {
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];
}
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 aet_object:
return aux.t + inc;
case aet_fix:
return aux.fix + inc;
case aet_index:
return aux.fix + inc;
case aet_sf:
return aux.sf + inc;
case aet_bc:
return aux.bc + inc;
#ifdef ECL_UNICODE
case aet_ch:
return aux.c + inc;
#endif
case aet_df:
return aux.df + inc;
case aet_b8:
case aet_i8:
return aux.b8 + inc;
#ifdef ecl_uint16_t
case aet_b16:
case aet_i16:
return aux.b16 + inc;
#endif
#ifdef ecl_uint32_t
case aet_b32:
case aet_i32:
return aux.b32 + inc;
#endif
#ifdef ecl_uint64_t
case aet_b64:
case aet_i64:
return aux.b64 + inc;
#endif
default:
FEbad_aet();
}
}
static void *
array_address(cl_object x, cl_index inc)
{
return address_inc(x->array.self.t, inc, x->array.elttype);
}
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.
*/
static void
displace(cl_object from, cl_object to, cl_object offset)
{
cl_index j;
void *base;
cl_elttype totype, fromtype;
fromtype = from->array.elttype;
if (type_of(to) == t_foreign) {
if (fromtype == aet_bit || fromtype == aet_object) {
FEerror("Cannot displace arrays with element type T or BIT onto foreign data",0);
}
base = to->foreign.data;
j = ecl_fixnum_in_range(@'adjust-array',"array displacement", offset,
0, MOST_POSITIVE_FIXNUM);
from->array.displaced = to;
} else {
totype = to->array.elttype;
if (totype != fromtype)
FEerror("Cannot displace the array,~%\
because the element types don't match.", 0);
if (from->array.dim > to->array.dim)
FEerror("Cannot displace the array,~%\
because the total size of the to-array is too small.", 0);
j = ecl_fixnum_in_range(@'adjust-array',"array displacement",offset,
0, to->array.dim - from->array.dim);
from->array.displaced = ecl_list1(to);
if (Null(to->array.displaced))
to->array.displaced = ecl_list1(Cnil);
ECL_RPLACD(to->array.displaced, CONS(from, CDR(to->array.displaced)));
if (fromtype == 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 == 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 == Cnil || ((to_array = ECL_CONS_CAR(to_array)) == Cnil)) {
output = ecl_alloc_object(t_vector);
output->vector.elttype = aet_b8;
output->vector.self.b8 = data;
output->vector.dim = output->vector.fillp = total_size;
output->vector.flags = 0; /* no fill pointer, not adjustable */
output->vector.displaced = Cnil;
} else {
cl_index displ = data - to_array->vector.self.b8;
output = si_make_vector(@'ext::byte8',
MAKE_FIXNUM(total_size),
Cnil,
Cnil,
si_array_raw_data(to_array),
MAKE_FIXNUM(displ));
}
@(return output)
}
cl_elttype
ecl_array_elttype(cl_object x)
{
if (!ECL_ARRAYP(x))
FEwrong_type_argument(@'array', x);
return x->array.elttype;
}
cl_object
cl_array_rank(cl_object a)
{
assert_type_array(a);
@(return ((type_of(a) == t_array) ? MAKE_FIXNUM(a->array.rank)
: MAKE_FIXNUM(1)))
}
cl_object
cl_array_dimension(cl_object a, cl_object index)
{
@(return MAKE_FIXNUM(ecl_array_dimension(a, fixnnint(index))))
}
cl_index
ecl_array_dimension(cl_object a, cl_index index)
{
switch (type_of(a)) {
case t_array: {
if (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 (index) FEwrong_dimensions(a, index+1);
return a->vector.dim;
default:
FEtype_error_array(a);
}
}
cl_object
cl_array_total_size(cl_object a)
{
assert_type_array(a);
@(return MAKE_FIXNUM(a->array.dim))
}
cl_object
cl_adjustable_array_p(cl_object a)
{
assert_type_array(a);
@(return (ECL_ADJUSTABLE_ARRAY_P(a) ? Ct : Cnil))
}
/*
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;
assert_type_array(a);
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 aet_object:
offset = a->array.self.t - to_array->array.self.t;
break;
case aet_bc:
offset = a->array.self.bc - to_array->array.self.bc;
break;
#ifdef ECL_UNICODE
case aet_ch:
offset = a->array.self.c - to_array->array.self.c;
break;
#endif
case 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 aet_fix:
offset = a->array.self.fix - to_array->array.self.fix;
break;
case aet_index:
offset = a->array.self.fix - to_array->array.self.fix;
break;
case aet_sf:
offset = a->array.self.sf - to_array->array.self.sf;
break;
case aet_df:
offset = a->array.self.df - to_array->array.self.df;
break;
case aet_b8:
case aet_i8:
offset = a->array.self.b8 - to_array->array.self.b8;
break;
#ifdef ecl_uint16_t
case aet_b16:
case aet_i16:
offset = a->array.self.b16 - to_array->array.self.b16;
break;
#endif
#ifdef ecl_uint32_t
case aet_b32:
case aet_i32:
offset = a->array.self.b32 - to_array->array.self.b32;
break;
#endif
#ifdef ecl_uint64_t
case aet_b64:
case aet_i64:
offset = a->array.self.b64 - to_array->array.self.b64;
break;
#endif
default:
FEbad_aet();
}
}
@(return to_array 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;
while (type_of(x) != t_vector ||
(x->vector.flags & (ECL_FLAG_ADJUSTABLE | ECL_FLAG_HAS_FILL_POINTER)) ||
CAR(x->vector.displaced) != Cnil ||
(cl_elttype)x->vector.elttype != aet_object)
{
x = ecl_type_error(@'svref',"argument",x,@'simple-vector');
}
i = ecl_fixnum_in_range(@'svref',"index",index,0,(cl_fixnum)x->vector.dim-1);
@(return 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;
while (type_of(x) != t_vector ||
(x->vector.flags & (ECL_FLAG_ADJUSTABLE | ECL_FLAG_HAS_FILL_POINTER)) ||
CAR(x->vector.displaced) != Cnil ||
(cl_elttype)x->vector.elttype != aet_object)
{
x = ecl_type_error(@'si::svset',"argument",x,@'simple-vector');
}
i = ecl_fixnum_in_range(@'svref',"index",index,0,(cl_fixnum)x->vector.dim-1);
@(return (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;
AGAIN:
switch (type_of(a)) {
case t_array:
r = Cnil; 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)? Ct : Cnil;
break;
default:
a = ecl_type_error(@'array-has-fill-pointer-p',"argument",
a, @'array');
goto AGAIN;
}
@(return r)
}
cl_object
cl_fill_pointer(cl_object a)
{
const cl_env_ptr the_env = ecl_process_env();
assert_type_vector(a);
if (!ECL_ARRAY_HAS_FILL_POINTER_P(a)) {
a = ecl_type_error(@'fill-pointer', "argument",
a, ecl_read_from_cstring("(AND VECTOR (SATISFIES ARRAY-HAS-FILL-POINTER-P))"));
}
@(return 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();
assert_type_vector(a);
if (ECL_ARRAY_HAS_FILL_POINTER_P(a)) {
a->vector.fillp =
ecl_fixnum_in_range(@'adjust-array',"fill pointer",fp,
0,a->vector.dim);
} else {
FEerror("The vector ~S has no fill pointer.", 1, a);
}
@(return 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 (type_of(olda) != type_of(newa)
|| (type_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 != Cnil; dlist = CDR(dlist)) {
cl_object other_array = CAR(dlist);
cl_object offset;
cl_array_displacement(other_array);
offset = VALUES(1);
displace(other_array, newa, offset);
}
switch (type_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:
@(return 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 == aet_bit) {
while (l--) {
ecl_aset_unsafe(dest, i0++, ecl_aref_unsafe(orig, i1++));
}
} else if (t >= 0 && t <= aet_last_type) {
cl_index elt_size = ecl_aet_size[t];
memcpy(dest->array.self.bc + i0 * elt_size,
orig->array.self.bc + i1 * elt_size,
l * elt_size);
} else {
FEbad_aet();
}
}
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 aet_object:
case aet_fix:
case 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 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 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 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 aet_b8:
case 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 aet_b16:
case 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 aet_b32:
case 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 aet_b64:
case 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 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 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_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 = fixnnint(start);
cl_index last = Null(end)? x->array.dim : fixnnint(end);
if (first >= last) {
goto END;
}
switch (t) {
case aet_object: {
cl_object *p = x->vector.self.t + first;
for (first = last - first; first; --first, ++p) { *p = elt; }
break;
}
case 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 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 aet_fix: {
cl_fixnum e = fixint(elt);
cl_fixnum *p = x->vector.self.fix + first;
for (first = last - first; first; --first, ++p) { *p = e; }
break;
}
case aet_index: {
cl_index e = fixnnint(elt);
cl_index *p = x->vector.self.index + first;
for (first = last - first; first; --first, ++p) { *p = e; }
break;
}
case 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 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 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 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 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 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 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 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 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 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 aet_bit: {
int i = ecl_fixnum_in_range(@'si::aset',"bit",elt,0,1);
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