view release on metacpan or  search on metacpan

lib/PDL/Core/pdlcore.c  view on Meta::CPAN

      } else if ( (PDL_Indx)SvIV(*svp) == 0) {
        sv_setiv(*svp, (IV)1);
      }
    }
  }

  return depth;
}

/* helper function used in pdl_from_array */
static pdl_datatypes _detect_datatype(AV *av) {
  SV **item;
  AV *array;
  PDL_Indx count, i;
  if (!av) return PDL_D;
  count = av_len(av);
  for (i = 0; i < count; i++) {
    item = av_fetch(av, i, 0);
    if (*item) {
      if (SvROK(*item)) {
        array = (AV*)SvRV(*item);
        if (_detect_datatype(array) == PDL_D) {
          return PDL_D;
        }
      }
      if (SvOK(*item) && !SvIOK(*item)) {
        return PDL_D;
      }
    }
  }
#if IVSIZE == 8
  return PDL_LL;
#else
  return PDL_L;
#endif
}

/**********************************************************************
 * pdl_from_array - dispatcher gets called only by pdl_avref (defined in
 * Core.xs) - it breaks out to pdl_setav_<type>, below, based on the
 * type of the destination PDL.
 */
pdl* pdl_from_array(AV* av, AV* dims, pdl_datatypes dtype, pdl* dest_pdl)
{
  PDL_Indx ndims, i, level=0;
  PDL_Anyval undefval = { PDL_INVALID, {0} };
  ndims = av_len(dims)+1;
  PDL_Indx dest_dims[ndims];
  for (i=0; i<ndims; i++) {
     dest_dims[i] = SvIV(*(av_fetch(dims, ndims-1-i, 0))); /* reverse order */
  }
  if (dest_pdl == NULL)
     dest_pdl = pdl_pdlnew();
  if (!dest_pdl) return dest_pdl;
  pdl_error err = pdl_setdims (dest_pdl, dest_dims, ndims);
  if (err.error) return NULL;
  if (dtype == -1) {
    dtype = _detect_datatype(av);
  }
  dest_pdl->datatype = dtype;
  err = pdl_allocdata (dest_pdl);
  if (err.error) return NULL;
  err = pdl_make_physical(dest_pdl);
  if (err.error) return NULL;
  /******
   * Copy the undefval to fill empty spots in the ndarray...
   */
  PDLDEBUG_f(printf("pdl_from_array type: %d\n", dtype));
  ANYVAL_FROM_SV(undefval, NULL, TRUE, dtype, FALSE);
#define X(dtype_dest, ctype_dest, ppsym_dest, ...) \
    pdl_setav_ ## ppsym_dest(dest_pdl->data,av,dest_dims,ndims,level, undefval.value.ppsym_dest, dest_pdl);
  PDL_GENERICSWITCH(PDL_TYPELIST_ALL, dtype, X, return NULL)
#undef X
  if (dest_pdl->has_badvalue && dest_pdl->badvalue.type != dtype)
    barf("Badvalue has type=%d != pdltype=%d", dest_pdl->badvalue.type, dtype);
  return dest_pdl;
}

/* Compute offset of (x,y,z,...) position in row-major list */
PDL_Indx pdl_get_offset(PDL_Indx* pos, PDL_Indx* dims, PDL_Indx *incs, PDL_Indx offset, PDL_Indx ndims) {
   PDL_Indx i;
   PDL_Indx result;
   for (i=0; i<ndims; i++) { /* Check */
      if (pos[i]<-dims[i] || pos[i]>=dims[i])
         return -1;
   }
   result = offset;
   for (i=0; i<ndims; i++) {
       result += (pos[i]+((pos[i]<0)?dims[i]:0))*incs[i];
   }
   return result;
}

/*CORE21 unused*/
PDL_Anyval pdl_at0( pdl* it ) {
  PDL_Anyval result = { PDL_INVALID, {0} };
  if (it->nvals != 1) { return result; }
  ANYVAL_FROM_CTYPE_OFFSET(result, it->datatype, PDL_REPRP(it), PDL_REPROFFS(it));
  return result;
}

/*CORE21 unused*/
PDL_Anyval pdl_at( void* x, pdl_datatypes datatype, PDL_Indx* pos, PDL_Indx* dims,
	PDL_Indx* incs, PDL_Indx offset, PDL_Indx ndims) {
  PDL_Anyval result = { PDL_INVALID, {0} };
  PDL_Indx ioff = pdl_get_offset(pos, dims, incs, offset, ndims);
  if (ioff < 0) return result;
  ANYVAL_FROM_CTYPE_OFFSET(result, datatype, x, ioff);
  return result;
}

/* Set value at position (x,y,z...) */
pdl_error pdl_set( void* x, pdl_datatypes datatype, PDL_Indx* pos, PDL_Indx* dims, PDL_Indx* incs, PDL_Indx offs, PDL_Indx ndims, PDL_Anyval value) {
  pdl_error PDL_err = {0, NULL, 0};
  PDL_Indx ioff = pdl_get_offset(pos, dims, incs, offs, ndims);
  if (ioff < 0)
    return pdl_make_error_simple(PDL_EUSERERROR, "Position out of range");
  PDL_Anyval typedval;
  ANYVAL_TO_ANYVAL_NEWTYPE(value, typedval, datatype);
  if (typedval.type < 0)
    return pdl_make_error_simple(PDL_EUSERERROR, "Error making typedval");