mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-15 05:43:19 -08:00
Code Issues Projects Releases Packages Wiki Activity
ecl/src/c/array.d
Juan Jose Garcia Ripoll 5d59463fd9 Null terminate the base-strings created by make-array.
2012-12-17 22:37:00 +01:00

1427 lines
40 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>
#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-dimension], 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_nth_arg(@[array-has-fill-pointer-p],1,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_nth_arg(@[fill-pointer], 1, 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