# vim: ft=perl
__DATA__
__C__

SEXPTYPE PDL_to_R_type( int pdl_type ) {
	switch(pdl_type) {
		case PDL_B:
			return CHARSXP;
		case PDL_S:
		case PDL_US:
		case PDL_L:
		case PDL_IND:
		case PDL_LL:
			return INTSXP;
		case PDL_F:
		case PDL_D:
			return REALSXP;
	}
  return -1; /* TODO exception */
}

int R_to_PDL_type(SEXPTYPE r_type) {
	switch(r_type) {
		case REALSXP: return PDL_D; break;

		case LGLSXP:
		case INTSXP: return PDL_L; /* TODO is this correct? should I check: .Machine$integer.max */

		case CPLXSXP: return -1; /* TODO map to PDL::Complex */

		case STRSXP: return -1; /* TODO map to string or PDL::Char */
  }
  return -1; /* TODO exception */
}


/* flat is used to make a vector rather than an array */
SEXP make_r_array( pdl* p, int flat, int matrix ) {
	SEXP r_dims, r_array;
	SV* ret;
	int dim_i, elem_i;
	size_t ndims;
{{{
	# TODO cover all types
	for my $type (qw(PDL_D PDL_L)) {
		$OUT .= qq{
		$pdl_to_r->{$type}{ctype} *datad_$type;
		$pdl_to_r->{$type}{ctype}  badv_$type;
		};
	}
}}}
	int r_type;
	PDL_Indx nelems;

	ndims = p->ndims;
	if( ndims == 0 ) {
		/* when the PDL is a simple scalar, then ndims == 0
		 * but there is still a value in the PDL
		 *
		 * see the "single scalar" case below
		 */
		ndims = 1;
	}

	r_type = PDL_to_R_type( p->datatype );

	PROTECT( r_dims = allocVector( INTSXP, ndims ) );

	if( matrix ) {
		/* TODO check if ndims == 2 */
		R_PreserveObject( r_array = allocMatrix( r_type, p->dims[0], p->dims[1] ) );
		nelems = p->dims[0] * p->dims[1];

	} else {
		nelems = 1;
		if( p->ndims == 0 && p->dims[0] == 0 ) {
			/* for pdl(1): single scalar */
			nelems = 1;
			INTEGER(r_dims)[dim_i] = 1;
		} else if( p->ndims == 1 && p->dims[0] == 0 ) {
			/* for pdl([]): Empty */
			nelems = 0;
			INTEGER(r_dims)[dim_i] = 0;
		} else {
			/* n-d array */
			for( dim_i = 0; dim_i < ndims; dim_i++ ) {
				INTEGER(r_dims)[dim_i] = p->dims[dim_i];
				nelems *= p->dims[dim_i];
			}
		}

		R_PreserveObject( r_array = allocVector(r_type, nelems) );

		if( !flat ) {
			/* creates data of R class 'array' */
			dimgets( r_array, r_dims ); /* set dimensions */
		}
	}

	/* TODO NOTE: on DESTROY, call R_ReleaseObject() */

	/* TODO support more types */
	switch(r_type) {
{{{
for my $type (qw(PDL_D PDL_L)) {
	$OUT .= qq%
	case $pdl_to_r->{$type}{sexptype}:
	datad_$type = ($pdl_to_r->{$type}{ctype} *) p->data;
	badv_$type = PDL->get_pdl_badvalue(p);
	memcpy( $pdl_to_r->{$type}{r_macro}(r_array), datad_$type, sizeof($pdl_to_r->{$type}{ctype}) * nelems );
	if( p->state & PDL_BADVAL ) {
		for( elem_i = 0; elem_i < nelems; elem_i++ ) {
			if(datad_${type}[elem_i] == badv_$type) {
				$pdl_to_r->{$type}{r_macro}(r_array)[elem_i] = $pdl_to_r->{$type}{r_NA};
			}
		}

	}
	break;
	%;
}
}}}
	}

	UNPROTECT(1); /* r_dims */

	return r_array;
}

pdl* make_pdl_array( SEXP r_array ) {
	SEXP r_dims;
	size_t ndims;
	PDL_Indx* dims;
	pdl* p;
	int dim_i, elem_i;
	PDL_Indx nelems = 1;
{{{
	# TODO cover all types
	for my $type (qw(PDL_D PDL_L)) {
		$OUT .= qq%
		$pdl_to_r->{$type}{ctype} *datad_$type;
		$pdl_to_r->{$type}{ctype}  badv_$type;
		%;
	}
}}}
	int datatype;

	r_dims = getAttrib(r_array, R_DimSymbol);
	ndims = Rf_length(r_dims);

	Newx(dims, ndims, PDL_Indx);
	for( dim_i = 0; dim_i < ndims; dim_i++ ) {
		dims[dim_i] = INTEGER(r_dims)[dim_i];
		nelems *= dims[dim_i];
	}

	datatype = R_to_PDL_type(TYPEOF(r_array)); /* TODO : R_to_PDL_type */

	p = PDL->pdlnew();
	PDL->setdims (p, dims, ndims);  /* set dims */
	p->datatype = datatype;         /* and data type */
	PDL->allocdata (p);             /* allocate the data chunk */

	Safefree(dims);

	switch(datatype) {
{{{
for my $type (qw(PDL_D PDL_L)) {
	$OUT .= qq%
	case $type:
	datad_$type = ($pdl_to_r->{$type}{ctype} *) p->data;
	badv_$type = PDL->get_pdl_badvalue(p);
	memcpy( datad_$type, $pdl_to_r->{$type}{r_macro}(r_array), sizeof($pdl_to_r->{$type}{ctype}) * nelems );
	for( elem_i = 0; elem_i < nelems; elem_i++ ) {
		if( ISNA( $pdl_to_r->{$type}{r_macro}(r_array)[elem_i] ) ) {
			p->state |= PDL_BADVAL;
			datad_${type}[elem_i] = badv_$type;
		}
	}
	break;
	%;
}
}}}

	}

	return p;
}

pdl* make_pdl_vector( SEXP r_vector, int flat ) {
	size_t ndims;
	PDL_Indx* dims;
	pdl* p;
	int elem_i;
	PDL_Indx nelems = 1;
{{{
	# TODO cover all types
	for my $type (qw(PDL_D PDL_L)) {
		$OUT .= qq%
		$pdl_to_r->{$type}{ctype} *datad_$type;
		$pdl_to_r->{$type}{ctype}  badv_$type;
		%;
	}
}}}
	int datatype;

	ndims = 1;
	Newx(dims, ndims, PDL_Indx);
	dims[0] = nelems = Rf_length(r_vector);
	if( dims[0] == 1 && flat ) {
		/* if there is a single value, treat it as a scalar instead of
		 * as a vector.
		 */
		ndims = 0;
		dims[0] = 0;
	}

	datatype = R_to_PDL_type(TYPEOF(r_vector)); /* TODO : R_to_PDL_type */

	p = PDL->pdlnew();
	PDL->setdims (p, dims, ndims);  /* set dims */
	p->datatype = datatype;         /* and data type */
	PDL->allocdata (p);             /* allocate the data chunk */

	Safefree(dims);

	switch(datatype) {
{{{
for my $type (qw(PDL_D PDL_L)) {
	$OUT .= qq%
	case $type:
	datad_$type = ($pdl_to_r->{$type}{ctype} *) p->data;
	badv_$type = PDL->get_pdl_badvalue(p);
	memcpy( datad_$type, $pdl_to_r->{$type}{r_macro}(r_vector), sizeof($pdl_to_r->{$type}{ctype}) * nelems );
	for( elem_i = 0; elem_i < nelems; elem_i++ ) {
		if( ISNA( $pdl_to_r->{$type}{r_macro}(r_vector)[elem_i] ) ) {
			p->state |= PDL_BADVAL;
			datad_${type}[elem_i] = badv_$type;
		}
	}
	break;
	%;
}
}}}

	}

	return p;
}