#line 1 "/build/ecl/src/ecl-26.3.27/src/c/array.d"
/* -*- 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 */
  ECL_SYM("SINGLE-FLOAT",781),      /* ecl_aet_sf */
  ECL_SYM("DOUBLE-FLOAT",317),      /* ecl_aet_df */
  ECL_SYM("LONG-FLOAT",510),        /* ecl_aet_lf */
#ifdef ECL_COMPLEX_FLOAT
  ECL_SYM("SI::COMPLEX-SINGLE-FLOAT",1899),  /* ecl_aet_csf */
  ECL_SYM("SI::COMPLEX-DOUBLE-FLOAT",1900),  /* ecl_aet_cdf */
  ECL_SYM("SI::COMPLEX-LONG-FLOAT",1901),    /* ecl_aet_clf */
#endif
  ECL_SYM("BIT",125),               /* ecl_aet_bit */
  ECL_SYM("EXT::CL-FIXNUM",1658),    /* ecl_aet_fix */
  ECL_SYM("EXT::CL-INDEX",1659),     /* ecl_aet_index */
  ECL_SYM("EXT::BYTE8",1368),        /* ecl_aet_b8 */
  ECL_SYM("EXT::INTEGER8",1373),     /* ecl_aet_i8 */
#ifdef ecl_uint16_t
  ECL_SYM("EXT::BYTE16",1369),
  ECL_SYM("EXT::INTEGER16",1374),
#endif
#ifdef ecl_uint32_t
  ECL_SYM("EXT::BYTE32",1370),
  ECL_SYM("EXT::INTEGER32",1375),
#endif
#ifdef ecl_uint64_t
  ECL_SYM("EXT::BYTE64",1371),
  ECL_SYM("EXT::INTEGER64",1376),
#endif
#ifdef ECL_UNICODE
  ECL_SYM("CHARACTER",224),         /* ecl_aet_ch */
#endif
  ECL_SYM("BASE-CHAR",122)          /* 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, ECL_SYM("INTEGER",439), 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),
                                ECL_SYM(":INITIAL-ELEMENT",1286), ECL_SYM("*",20));
  cl_object type = cl_list(3, ECL_SYM("ARRAY",98), ECL_SYM("*",20), 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(ecl_make_fixnum(/*COERCE*/233), n, ecl_make_fixnum(/*FIXNUM*/374));
  }
}

cl_object
cl_row_major_aref(cl_object x, cl_object indx)
{
  cl_index j = ecl_to_size(indx);
  {
#line 115
	const cl_env_ptr the_env = ecl_process_env();
#line 115
	#line 115
	cl_object __value0 = ecl_aref(x, j);
#line 115
	the_env->nvalues = 1;
#line 115
	the_env->values[0] = __value0;
#line 115
	#line 115
	return __value0;
#line 115
}
;
}

cl_object
si_row_major_aset(cl_object x, cl_object indx, cl_object val)
{
  cl_index j = ecl_to_size(indx);
  {
#line 122
	const cl_env_ptr the_env = ecl_process_env();
#line 122
	#line 122
	cl_object __value0 = ecl_aset(x, j, val);
#line 122
	the_env->nvalues = 1;
#line 122
	the_env->values[0] = __value0;
#line 122
	#line 122
	return __value0;
#line 122
}
;
}

#line 125
cl_object cl_aref(cl_narg narg, cl_object x, ...)
{
#line 125

#line 126
#if defined(__clang__) || defined(__GNUC__)
	__attribute__((unused)) const cl_env_ptr the_env = ecl_process_env();
#else
	const cl_env_ptr the_env = ecl_process_env();
#endif
#line 126
	ecl_va_list indx;
	ecl_va_start(indx, x, narg, 1);
#line 126
	if (ecl_unlikely(narg < 1)) FEwrong_num_arguments(ecl_make_fixnum(94));
#line 126
{
  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(ecl_make_fixnum(/*AREF*/94), 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(ecl_make_fixnum(/*AREF*/94), x, -1, ecl_va_arg(indx), x->vector.dim);
    break;
  default:
    FEwrong_type_nth_arg(ecl_make_fixnum(/*AREF*/94), 1, x, ecl_make_fixnum(/*ARRAY*/98));
  }
  {
#line 153
	#line 153
	cl_object __value0 = ecl_aref_unsafe(x, j);
#line 153
	the_env->nvalues = 1;
#line 153
	the_env->values[0] = __value0;
#line 153
	ecl_va_end(indx);
#line 153
	return __value0;
#line 153
}
;
} }

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(ecl_make_fixnum(/*AREF*/94), 1, x, ecl_make_fixnum(/*ARRAY*/98));
  }
  if (ecl_unlikely(index >= x->array.dim)) {
    FEwrong_index(ecl_make_fixnum(/*ROW-MAJOR-AREF*/734), 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(ecl_make_fixnum(/*AREF*/94), 1, x, ecl_make_fixnum(/*ARRAY*/98));
  }
  if (ecl_unlikely(index >= x->array.dim)) {
    FEwrong_index(ecl_make_fixnum(/*AREF*/94), 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(ecl_make_fixnum(/*AREF*/94), 1, x, ecl_make_fixnum(/*ARRAY*/98));
  }

  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(ecl_make_fixnum(/*ROW-MAJOR-AREF*/734), 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)
*/
#line 277
cl_object si_aset(cl_narg narg, cl_object x, ...)
{
#line 277

  #line 278
#if defined(__clang__) || defined(__GNUC__)
	__attribute__((unused)) const cl_env_ptr the_env = ecl_process_env();
#else
	const cl_env_ptr the_env = ecl_process_env();
#endif
#line 278
	ecl_va_list dims;
	ecl_va_start(dims, x, narg, 1);
#line 278
	if (ecl_unlikely(narg < 1)) FEwrong_num_arguments(ecl_make_fixnum(1045));
#line 278
{
    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(ecl_make_fixnum(/*SI::ASET*/1045), 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(ecl_make_fixnum(/*SI::ASET*/1045), x, -1, ecl_va_arg(dims),
                        x->vector.dim);
      break;
    default:
      FEwrong_type_nth_arg(ecl_make_fixnum(/*SI::ASET*/1045), 1, x, ecl_make_fixnum(/*ARRAY*/98));
    }
    v = ecl_va_arg(dims);
    {
#line 308
	#line 308
	cl_object __value0 = ecl_aset_unsafe(x, j, v);
#line 308
	the_env->nvalues = 1;
#line 308
	the_env->values[0] = __value0;
#line 308
	ecl_va_end(dims);
#line 308
	return __value0;
#line 308
}
;
} }

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(ecl_make_fixnum(/*SI::ASET*/1045), 1, x, ecl_make_fixnum(/*ARRAY*/98));
  }
  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(ecl_make_fixnum(/*SI::ASET*/1045), 1, x, ecl_make_fixnum(/*ARRAY*/98));
  }
  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(ecl_make_fixnum(/*MAKE-ARRAY*/524), 1, dims,
                         cl_list(3, ECL_SYM("OR",616), ECL_SYM("LIST",483), ECL_SYM("FIXNUM",374)));
  }
  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(ecl_make_fixnum(/*MAKE-ARRAY*/524), 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(ecl_make_fixnum(/*MAKE-ARRAY*/524), ecl_make_fixnum(/*ARRAY-TOTAL-SIZE*/109),
                           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);
  {
#line 482
	const cl_env_ptr the_env = ecl_process_env();
#line 482
	#line 482
	cl_object __value0 = x;
#line 482
	the_env->nvalues = 1;
#line 482
	the_env->values[0] = __value0;
#line 482
	#line 482
	return __value0;
#line 482
}
;
}

/* 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(ecl_make_fixnum(/*MAKE-ARRAY*/524), 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(ECL_SYM("MAKE-ARRAY",524),"fill pointer",fillp,
                           cl_list(3,ECL_SYM("OR",616),cl_list(3,ECL_SYM("MEMBER",554),ECL_NIL,ECL_T),
                                   cl_list(3,ECL_SYM("INTEGER",439),ecl_make_fixnum(0),
                                           dim)));
    goto AGAIN;
  }
  x->vector.fillp = f;

  if (Null(displ))
    ecl_array_allocself(x);
  else
    ecl_displace(x, displ, disploff);
  {
#line 565
	const cl_env_ptr the_env = ecl_process_env();
#line 565
	#line 565
	cl_object __value0 = x;
#line 565
	the_env->nvalues = 1;
#line 565
	the_env->values[0] = __value0;
#line 565
	#line 565
	return __value0;
#line 565
}
;
}

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 == ECL_SYM("BASE-CHAR",122))
    return(ecl_aet_bc);
#ifdef ECL_UNICODE
  if (x == ECL_SYM("CHARACTER",224))
    return(ecl_aet_ch);
#endif
  else if (x == ECL_SYM("BIT",125))
    return(ecl_aet_bit);
  else if (x == ECL_SYM("EXT::CL-FIXNUM",1658))
    return(ecl_aet_fix);
  else if (x == ECL_SYM("EXT::CL-INDEX",1659))
    return(ecl_aet_index);
  else if (x == ECL_SYM("SINGLE-FLOAT",781) || x == ECL_SYM("SHORT-FLOAT",759))
    return(ecl_aet_sf);
  else if (x == ECL_SYM("DOUBLE-FLOAT",317))
    return(ecl_aet_df);
  else if (x == ECL_SYM("LONG-FLOAT",510))
    return(ecl_aet_lf);
#ifdef ECL_COMPLEX_FLOAT
  else if (x == ECL_SYM("SI::COMPLEX-SINGLE-FLOAT",1899))
    return(ecl_aet_csf);
  else if (x == ECL_SYM("SI::COMPLEX-DOUBLE-FLOAT",1900))
    return(ecl_aet_cdf);
  else if (x == ECL_SYM("SI::COMPLEX-LONG-FLOAT",1901))
    return(ecl_aet_clf);
#endif
  else if (x == ECL_SYM("EXT::BYTE8",1368))
    return(ecl_aet_b8);
  else if (x == ECL_SYM("EXT::INTEGER8",1373))
    return(ecl_aet_i8);
#ifdef ecl_uint16_t
  else if (x == ECL_SYM("EXT::BYTE16",1369))
    return(ecl_aet_b16);
  else if (x == ECL_SYM("EXT::INTEGER16",1374))
    return(ecl_aet_i16);
#endif
#ifdef ecl_uint32_t
  else if (x == ECL_SYM("EXT::BYTE32",1370))
    return(ecl_aet_b32);
  else if (x == ECL_SYM("EXT::INTEGER32",1375))
    return(ecl_aet_i32);
#endif
#ifdef ecl_uint64_t
  else if (x == ECL_SYM("EXT::BYTE64",1371))
    return(ecl_aet_b64);
  else if (x == ECL_SYM("EXT::INTEGER64",1376))
    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));

  {
#line 754
	const cl_env_ptr the_env = ecl_process_env();
#line 754
	#line 754
	cl_object __value0 = size;
#line 754
	cl_object __value1 = ecl_elttype_to_symbol(aet);
#line 754
	the_env->nvalues = 2;
#line 754
	the_env->values[1] = __value1;
#line 754
	the_env->values[0] = __value0;
#line 754
	#line 754
	return __value0;
#line 754
}
;
}

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)
{
  {
#line 815
	const cl_env_ptr the_env = ecl_process_env();
#line 815
	#line 815
	cl_object __value0 = ecl_elttype_to_symbol(ecl_array_elttype(a));
#line 815
	the_env->nvalues = 1;
#line 815
	the_env->values[0] = __value0;
#line 815
	#line 815
	return __value0;
#line 815
}
;
}

/*
  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(ecl_make_fixnum(/*ADJUST-ARRAY*/85), ecl_make_fixnum(/*:DISPLACED-INDEX-OFFSET*/1251),
                         offset, ecl_make_fixnum(/*FIXNUM*/374));
  }
  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(ecl_make_fixnum(/*ADJUST-ARRAY*/85), ecl_make_fixnum(/*:DISPLACED-INDEX-OFFSET*/1251),
                           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(ECL_SYM("EXT::BYTE8",1368),
                            ecl_make_fixnum(total_size),
                            ECL_NIL,
                            fillp,
                            si_array_raw_data(to_array),
                            ecl_make_fixnum(displ));
  }
  {
#line 923
	const cl_env_ptr the_env = ecl_process_env();
#line 923
	#line 923
	cl_object __value0 = output;
#line 923
	the_env->nvalues = 1;
#line 923
	the_env->values[0] = __value0;
#line 923
	#line 923
	return __value0;
#line 923
}
;
}

cl_elttype
ecl_array_elttype(cl_object x)
{
  if (ecl_unlikely(!ECL_ARRAYP(x)))
    FEwrong_type_argument(ecl_make_fixnum(/*ARRAY*/98), x);
  return x->array.elttype;
}

cl_object
cl_array_rank(cl_object a)
{
  {
#line 937
	const cl_env_ptr the_env = ecl_process_env();
#line 937
	#line 937
	cl_object __value0 = ecl_make_fixnum(ecl_array_rank(a));
#line 937
	the_env->nvalues = 1;
#line 937
	the_env->values[0] = __value0;
#line 937
	#line 937
	return __value0;
#line 937
}
;
}

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(ecl_make_fixnum(/*ARRAY-RANK*/106), a, ecl_make_fixnum(/*ARRAY*/98));
  }
}

cl_object
cl_array_dimension(cl_object a, cl_object index)
{
  {
#line 961
	const cl_env_ptr the_env = ecl_process_env();
#line 961
	#line 961
	cl_object __value0 = ecl_make_fixnum(ecl_array_dimension(a, ecl_to_size(index)));
#line 961
	the_env->nvalues = 1;
#line 961
	the_env->values[0] = __value0;
#line 961
	#line 961
	return __value0;
#line 961
}
;
}

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(ecl_make_fixnum(/*ARRAY-DIMENSION*/99), a, ecl_make_fixnum(/*ARRAY*/98));
  }
}

cl_object
cl_array_total_size(cl_object a)
{
  if (ecl_unlikely(!ECL_ARRAYP(a)))
    FEwrong_type_only_arg(ecl_make_fixnum(/*ARRAY-TOTAL-SIZE*/109), a, ecl_make_fixnum(/*ARRAY*/98));
  {
#line 992
	const cl_env_ptr the_env = ecl_process_env();
#line 992
	#line 992
	cl_object __value0 = ecl_make_fixnum(a->array.dim);
#line 992
	the_env->nvalues = 1;
#line 992
	the_env->values[0] = __value0;
#line 992
	#line 992
	return __value0;
#line 992
}
;
}

cl_object
cl_adjustable_array_p(cl_object a)
{
  if (ecl_unlikely(!ECL_ARRAYP(a)))
    FEwrong_type_only_arg(ecl_make_fixnum(/*ADJUSTABLE-ARRAY-P*/86), a, ecl_make_fixnum(/*ARRAY*/98));
  {
#line 1000
	const cl_env_ptr the_env = ecl_process_env();
#line 1000
	#line 1000
	cl_object __value0 = (ECL_ADJUSTABLE_ARRAY_P(a) ? ECL_T : ECL_NIL);
#line 1000
	the_env->nvalues = 1;
#line 1000
	the_env->values[0] = __value0;
#line 1000
	#line 1000
	return __value0;
#line 1000
}
;
}

/*
  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(ecl_make_fixnum(/*ARRAY-DISPLACEMENT*/102), a, ecl_make_fixnum(/*ARRAY*/98));
  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(ecl_make_fixnum(/*SVREF*/841),1,x,ecl_make_fixnum(/*SIMPLE-VECTOR*/777));
    }
  i = checked_index(ecl_make_fixnum(/*SVREF*/841), 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(ecl_make_fixnum(/*SI::SVSET*/1183),1,x,ecl_make_fixnum(/*SIMPLE-VECTOR*/777));
    }
  i = checked_index(ecl_make_fixnum(/*SVREF*/841), 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(ecl_make_fixnum(/*MP::COMPARE-AND-SWAP-SVREF*/1525), 1, x, ecl_make_fixnum(/*SIMPLE-VECTOR*/777));
    }
  i = checked_index(ecl_make_fixnum(/*MP::COMPARE-AND-SWAP-SVREF*/1525), 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(ecl_make_fixnum(/*MP::ATOMIC-INCF-SVREF*/1531), 1, x, ecl_make_fixnum(/*SIMPLE-VECTOR*/777));
    }
  i = checked_index(ecl_make_fixnum(/*MP::ATOMIC-INCF-SVREF*/1531), 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(ecl_make_fixnum(/*ARRAY-HAS-FILL-POINTER-P*/104),a,ecl_make_fixnum(/*ARRAY*/98));
  }
  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(ecl_make_fixnum(/*FILL-POINTER*/364), a, ecl_make_fixnum(/*VECTOR*/902));
  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(ecl_make_fixnum(/*FILL-POINTER*/364), 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(ecl_make_fixnum(/*ADJUST-ARRAY*/85), 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(ecl_make_fixnum(/*ADJUST-ARRAY*/85), ecl_make_fixnum(/*:FILL-POINTER*/1270), 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));
  {
#line 1450
	const cl_env_ptr the_env = ecl_process_env();
#line 1450
	#line 1450
	cl_object __value0 = dest;
#line 1450
	the_env->nvalues = 1;
#line 1450
	the_env->values[0] = __value0;
#line 1450
	#line 1450
	return __value0;
#line 1450
}
;
}

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:
  {
#line 1601
	const cl_env_ptr the_env = ecl_process_env();
#line 1601
	#line 1601
	cl_object __value0 = x;
#line 1601
	the_env->nvalues = 1;
#line 1601
	the_env->values[0] = __value0;
#line 1601
	#line 1601
	return __value0;
#line 1601
}
;
}
