/* -*- 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 */
  @'long-float',        /* ecl_aet_lf */
#ifdef ECL_COMPLEX_FLOAT
  @'si::complex-single-float',  /* ecl_aet_csf */
  @'si::complex-double-float',  /* ecl_aet_cdf */
  @'si::complex-long-float',    /* ecl_aet_clf */
#endif
  @'bit',               /* ecl_aet_bit */
  @'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_lf:
    return(ecl_make_long_float(x->array.self.lf[index]));
#ifdef ECL_COMPLEX_FLOAT
  case ecl_aet_csf:
    return(ecl_make_csfloat(x->array.self.csf[index]));
  case ecl_aet_cdf:
    return(ecl_make_cdfloat(x->array.self.cdf[index]));
  case ecl_aet_clf:
    return(ecl_make_clfloat(x->array.self.clf[index]));
#endif
  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_lf:
    x->array.self.lf[index] = ecl_to_long_double(value);
    break;
#ifdef ECL_COMPLEX_FLOAT
  case ecl_aet_csf:
    x->array.self.csf[index] = ecl_to_csfloat(value);
    break;
  case ecl_aet_cdf:
    x->array.self.cdf[index] = ecl_to_cdfloat(value);
    break;
  case ecl_aet_clf:
    x->array.self.clf[index] = ecl_to_clfloat(value);
    break;
#endif
  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 element-type dimension-list 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 internal function for making simple actually adjustable vectors. */
cl_object
ecl_make_vector(cl_index dim)
{
  cl_object x = ecl_alloc_object(t_vector);
  x->vector.elttype = ecl_aet_object;
  x->vector.self.t = NULL;
  x->vector.displaced = ECL_NIL;
  x->vector.dim = dim;
  x->vector.fillp = 0;
  x->vector.flags = ECL_FLAG_ADJUSTABLE | ECL_FLAG_HAS_FILL_POINTER;
  ecl_array_allocself(x);
  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
si_adjust_vector(cl_object vector, cl_object new_dim) {
  cl_object new_vector;
  if (!ECL_ADJUSTABLE_ARRAY_P(vector)) {
    FEerror("The vector is not adjustable.", 0);
  }
  new_vector = si_make_vector(ecl_elttype_to_symbol(ecl_array_elttype(vector)),
                              new_dim,
                              ECL_T,
                              ecl_make_fixnum(vector->vector.fillp),
                              ECL_NIL,
                              ECL_NIL);
  ecl_copy_subarray(new_vector, 0, vector, 0, vector->vector.dim);
  si_replace_array(vector, new_vector);
  return vector;
}

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: {
    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')
    return(ecl_aet_lf);
#ifdef ECL_COMPLEX_FLOAT
  else if (x == @'si::complex-single-float')
    return(ecl_aet_csf);
  else if (x == @'si::complex-double-float')
    return(ecl_aet_cdf);
  else if (x == @'si::complex-long-float')
    return(ecl_aet_clf);
#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 == ECL_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_lf:
    return aux.lf + inc;
#ifdef ECL_COMPLEX_FLOAT
  case ecl_aet_csf:
    return aux.csf + inc;
  case ecl_aet_cdf:
    return aux.cdf + inc;
  case ecl_aet_clf:
    return aux.clf + inc;
#endif
  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 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_fixnum 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_lf:
      offset = a->array.self.lf - to_array->array.self.lf;
      break;
#ifdef ECL_COMPLEX_FLOAT
    case ecl_aet_csf:
      offset = a->array.self.csf - to_array->array.self.csf;
      break;
    case ecl_aet_cdf:
      offset = a->array.self.cdf - to_array->array.self.cdf;
      break;
    case ecl_aet_clf:
      offset = a->array.self.clf - to_array->array.self.clf;
      break;
#endif
    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);
}

#ifdef ECL_THREADS
cl_object
mp_compare_and_swap_svref(cl_object x, cl_object index, cl_object old, cl_object new)
{
  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(@[mp::compare-and-swap-svref], 1, x, @[simple-vector]);
    }
  i = checked_index(@[mp::compare-and-swap-svref], x, -1, index, x->vector.dim);
  return ecl_compare_and_swap(x->vector.self.t + i, old, new);
}

cl_object
mp_atomic_incf_svref(cl_object x, cl_object index, cl_object increment)
{
  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(@[mp::atomic-incf-svref], 1, x, @[simple-vector]);
    }
  i = checked_index(@[mp::atomic-incf-svref], x, -1, index, x->vector.dim);
  return ecl_atomic_incf(x->vector.self.t + i, increment);
}
#endif /* ECL_THREADS */

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 and SI:ADJUST-VECTOR.
*/
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_lf:
    for (i = i0, j = i1-1;  i < j;  i++, --j) {
      long double y = x->array.self.lf[i];
      x->array.self.lf[i] = x->array.self.lf[j];
      x->array.self.lf[j] = y;
    }
    break;
#ifdef ECL_COMPLEX_FLOAT
  case ecl_aet_csf:
    for (i = i0, j = i1-1;  i < j;  i++, --j) {
      _Complex float y = x->array.self.csf[i];
      x->array.self.csf[i] = x->array.self.csf[j];
      x->array.self.csf[j] = y;
    }
    break;
  case ecl_aet_cdf:
    for (i = i0, j = i1-1;  i < j;  i++, --j) {
      _Complex double y = x->array.self.cdf[i];
      x->array.self.cdf[i] = x->array.self.cdf[j];
      x->array.self.cdf[j] = y;
    }
    break;
  case ecl_aet_clf:
    for (i = i0, j = i1-1;  i < j;  i++, --j) {
      _Complex long double y = x->array.self.clf[i];
      x->array.self.clf[i] = x->array.self.clf[j];
      x->array.self.clf[j] = y;
    }
    break;
#endif
  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_lf: {
    long double e = ecl_to_long_double(elt);
    long double *p = x->vector.self.lf + first;
    for (first = last - first; first; --first, ++p) { *p = e; }
    break;
  }
#ifdef ECL_COMPLEX_FLOAT
  case ecl_aet_csf: {
    _Complex float e = ecl_to_csfloat(elt);
    _Complex float *p = x->vector.self.csf + first;
    for (first = last - first; first; --first, ++p) { *p = e; }
    break;
  }
  case ecl_aet_cdf: {
    _Complex double e = ecl_to_cdfloat(elt);
    _Complex double *p = x->vector.self.cdf + first;
    for (first = last - first; first; --first, ++p) { *p = e; }
    break;
  }
  case ecl_aet_clf: {
    _Complex long double e = ecl_to_clfloat(elt);
    _Complex long double *p = x->vector.self.clf + first;
    for (first = last - first; first; --first, ++p) { *p = e; }
    break;
  }
#endif
  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);
}
