static
int
ar_convert_to_pointer
(ar_data *result, const AR_TYPE *resulttype,
const ar_data *opnd, const AR_TYPE *opndtype) {
AR_TYPE unsigned_word_type = AR_Int_64_U;
if (AR_CLASS (*opndtype) == AR_CLASS_INT)
/* for some reason, we don't sign extend when converting to a
word pointer, but we do if converting to other pointers... */
if (AR_POINTER_FORMAT (*resulttype) != AR_POINTER_WORD) {
ar_convert_to_integral (result, &unsigned_word_type,
opnd, opndtype);
}
else {
result->ar_i64 = opnd->ar_i64;
}
else if (AR_CLASS (*opndtype) == AR_CLASS_POINTER) {
result->ar_i64 = opnd->ar_i64;
if (*resulttype == *opndtype)
return AR_STAT_OK;
/* if either the result or the operand is a byte pointer
(and the other isn't from the previous test): ERROR */
if (*resulttype == AR_Pointer_Byte ||
*opndtype == AR_Pointer_Byte)
return AR_STAT_INVALID_TYPE;
if (AR_POINTER_FORMAT (*resulttype) == AR_POINTER_WORD) {
if (AR_POINTER_FORMAT (*opndtype) == AR_POINTER_FCTN) {
/* convert parcel address to word address */
ar_dblshift(result, &unsigned_word_type,
(const ar_data*)&AR_const_zero, result, 2);
}
} else if (AR_POINTER_FORMAT (*resulttype) == AR_POINTER_FCTN) {
if (AR_POINTER_FORMAT (*opndtype) == AR_POINTER_WORD) {
/* convert word address to parcel address */
ar_dblshift(result, &unsigned_word_type,
(const ar_data*)&AR_const_zero, result, 126);
}
}
} else
return AR_STAT_INVALID_TYPE;
ar_clear_unused_bits (result, resulttype);
return AR_STAT_OK;
}
/* Exponentiation */
int
AR_power(AR_DATA *result, const AR_TYPE *resulttype,
const AR_DATA *base, const AR_TYPE *basetype,
const AR_DATA *power, const AR_TYPE *powertype)
{
int status;
if (AR_CLASS(*basetype) == AR_CLASS_INT &&
AR_CLASS(*powertype) == AR_CLASS_INT &&
*basetype != *powertype)
status = AR_STAT_INVALID_TYPE;
else
status = ar_power((ar_data*)result, resulttype,
(const ar_data*)base, basetype,
(const ar_data*)power, powertype);
if(IS_ERROR_STATUS(status))
ar_set_invalid_result((ar_data*)result, resulttype);
return status;
}
/* General dispatch routine for numeric conversions. */
int
AR_convert
(AR_DATA *res, const AR_TYPE *resulttype,
const AR_DATA *opd, const AR_TYPE *opndtype) {
ar_data* result = (ar_data*)res;
ar_data* opnd = (ar_data*)opd;
if (AR_CLASS (*resulttype) == AR_CLASS_INT)
return ar_convert_to_integral (result, resulttype, opnd, opndtype);
if (AR_CLASS (*resulttype) == AR_CLASS_POINTER)
return ar_convert_to_pointer (result, resulttype, opnd, opndtype);
if (AR_CLASS (*resulttype) == AR_CLASS_FLOAT)
if (AR_FLOAT_IS_COMPLEX (*resulttype) == AR_FLOAT_COMPLEX)
return ar_convert_to_complex (result, resulttype, opnd, opndtype);
else
return ar_convert_to_float (result, resulttype, opnd, opndtype);
return AR_STAT_INVALID_TYPE;
}
/* string -> floating point */
int
AR_convert_str_to_float (AR_DATA *result, const AR_TYPE *resulttype,
const char *str)
{
int status;
if(AR_CLASS(*resulttype) != AR_CLASS_FLOAT ||
AR_FLOAT_IS_COMPLEX(*resulttype) == AR_FLOAT_COMPLEX)
status = AR_STAT_INVALID_TYPE;
else
status = ar_convert_str_to_float ((ar_data*)result, resulttype, str);
if(IS_ERROR_STATUS(status))
ar_set_invalid_result((ar_data*)result, resulttype);
return status;
}
/* Complex absolute value */
int
AR_cabs (AR_DATA *result, const AR_TYPE *resulttype,
const AR_DATA *opnd, const AR_TYPE *opndtype)
{
int status;
if (AR_CLASS (*opndtype) != AR_CLASS_FLOAT ||
AR_FLOAT_IS_COMPLEX (*opndtype) != AR_FLOAT_COMPLEX ||
AR_FLOAT_IS_COMPLEX (*resulttype) == AR_FLOAT_COMPLEX)
status = AR_STAT_INVALID_TYPE;
else if(!((status = AR_status (opnd, opndtype)) & AR_STAT_OVERFLOW))
status = ar_cabs((ar_data*)result, resulttype,
(const ar_data*)opnd, opndtype);
if(IS_ERROR_STATUS(status))
ar_set_invalid_result((ar_data*)result, resulttype);
return status;
}
/* Exponential ("e" ** x) function */
int
AR_exp (AR_DATA *result, const AR_TYPE *resulttype,
const AR_DATA *opnd, const AR_TYPE *opndtype)
{
int status;
if (*resulttype != *opndtype ||
(AR_CLASS (*resulttype) != AR_CLASS_FLOAT) ||
(AR_status(opnd, opndtype) & AR_STAT_INVALID_TYPE))
status = AR_STAT_INVALID_TYPE;
else
status = ar_exp((ar_data*)result, resulttype,
(const ar_data*)opnd, opndtype);
if(IS_ERROR_STATUS(status))
ar_set_invalid_result((ar_data*)result, resulttype);
return status;
}
/* Fortran character scan function */
int
AR_scan(AR_DATA *result, const AR_TYPE *resulttype,
const char* str1, const AR_DATA *str1len, const AR_TYPE *str1lentype,
const char* str2, const AR_DATA *str2len, const AR_TYPE *str2lentype,
const AR_DATA *backward, const AR_TYPE *backwardtype)
{
int status;
long len1 = str1len->ar_internal_data_item1;
long len2 = str2len->ar_internal_data_item1;
long back;
if (AR_CLASS(*resulttype) != AR_CLASS_INT ||
AR_INT_SIZE(*resulttype) != AR_Int_8_S &&
AR_INT_SIZE(*resulttype) != AR_Int_16_S &&
AR_INT_SIZE(*resulttype) != AR_Int_32_S &&
AR_INT_SIZE(*resulttype) != AR_Int_64_S ||
*resulttype != *str1lentype ||
*resulttype != *str2lentype ||
(backward != NULL && *backwardtype != AR_Logical))
status = AR_STAT_INVALID_TYPE;
else if(len1 < 0 || len2 < 0)
status = AR_STAT_UNDEFINED;
else {
if(backward == NULL || (AR_status(backward, backwardtype)&AR_STAT_ZERO))
back = 0;
else
back = 1;
status = ar_scan((ar_data*)result, resulttype,
str1, len1, str2, len2, back);
}
if (IS_ERROR_STATUS(status))
ar_set_invalid_result((ar_data*)result, resulttype);
return status;
}
/* Selected_real_kind */
int
AR_selected_real_kind (AR_DATA *result, const AR_TYPE *resulttype,
const AR_DATA *opnd1, const AR_TYPE *opnd1type,
const AR_DATA *opnd2, const AR_TYPE *opnd2type)
{
int status;
if (*resulttype != *opnd1type || *resulttype != *opnd2type ||
AR_CLASS(*resulttype) != AR_CLASS_INT ||
AR_INT_SIZE(*resulttype) != AR_Int_8_S &&
AR_INT_SIZE(*resulttype) != AR_Int_16_S &&
AR_INT_SIZE(*resulttype) != AR_Int_32_S &&
AR_INT_SIZE(*resulttype) != AR_Int_64_S)
status = AR_STAT_INVALID_TYPE;
else
status = ar_selected_real_kind((ar_data*)result, resulttype,
(const ar_data*)opnd1, opnd1type,
(const ar_data*)opnd2, opnd2type);
if (IS_ERROR_STATUS(status))
ar_set_invalid_result((ar_data*)result, resulttype);
return status;
}
int
ar_convert_to_integral
(ar_data *result, const AR_TYPE *resulttype,
const ar_data *opnd, const AR_TYPE *opndtype) {
int status = AR_STAT_OK;
int maxnegint;
int rsltsz, opndsz;
if (AR_CLASS (*opndtype) == AR_CLASS_FLOAT) {
switch (*opndtype) {
case AR_Float_Cray1_64:
case AR_Float_Cray1_64_F:
status = ar_cfix64 (&result->ar_i64, &opnd->ar_f64, 64);
break;
case AR_Float_Cray1_128:
status = ar_cfix128 (&result->ar_i64,
&opnd->ar_f128, 64);
break;
case AR_Float_IEEE_NR_32:
case AR_Float_IEEE_ZE_32:
case AR_Float_IEEE_UP_32:
case AR_Float_IEEE_DN_32:
status = ar_ifix32 (&result->ar_i64, &opnd->ar_ieee32,
64, ROUND_MODE (*opndtype));
break;
case AR_Float_IEEE_NR_64:
case AR_Float_IEEE_ZE_64:
case AR_Float_IEEE_UP_64:
case AR_Float_IEEE_DN_64:
status = ar_ifix64 (&result->ar_i64, &opnd->ar_ieee64,
64, ROUND_MODE (*opndtype));
break;
case AR_Float_IEEE_NR_128:
case AR_Float_IEEE_ZE_128:
case AR_Float_IEEE_UP_128:
case AR_Float_IEEE_DN_128:
status = ar_ifix128 (&result->ar_i64, &opnd->ar_ieee128,
64, ROUND_MODE (*opndtype));
break;
case AR_Complex_Cray1_64:
case AR_Complex_Cray1_64_F:
status = ar_cfix64 (&result->ar_i64,
&opnd->ar_cplx_f64.real, 64);
break;
case AR_Complex_Cray1_128:
status = ar_cfix128 (&result->ar_i64,
&opnd->ar_cplx_f128.real, 64);
break;
case AR_Complex_IEEE_NR_32:
case AR_Complex_IEEE_ZE_32:
case AR_Complex_IEEE_UP_32:
case AR_Complex_IEEE_DN_32:
{
AR_IEEE_32 realpart;
CPLX32_REAL_TO_IEEE32(realpart, opnd->ar_cplx_ieee32);
status = ar_ifix32 (&result->ar_i64, &realpart,
64, ROUND_MODE (*opndtype));
break;
}
case AR_Complex_IEEE_NR_64:
case AR_Complex_IEEE_ZE_64:
case AR_Complex_IEEE_UP_64:
case AR_Complex_IEEE_DN_64:
status = ar_ifix64 (&result->ar_i64,
&opnd->ar_cplx_ieee64.real,
64, ROUND_MODE (*opndtype));
break;
case AR_Complex_IEEE_NR_128:
case AR_Complex_IEEE_ZE_128:
case AR_Complex_IEEE_UP_128:
case AR_Complex_IEEE_DN_128:
status = ar_ifix128(&result->ar_i64,
&opnd->ar_cplx_ieee128.real,
64, ROUND_MODE (*opndtype));
break;
default:
return AR_STAT_INVALID_TYPE;
}
}
else if (AR_CLASS (*opndtype) == AR_CLASS_POINTER) {
result->ar_i64 = opnd->ar_i64;
}
else if (AR_CLASS (*opndtype) == AR_CLASS_INT) {
if (*opndtype != AR_Int_8_S && *resulttype == AR_Int_8_S) {
result->ar_i8.part1 = opnd->ar_i64.part1;
result->ar_i8.part2 = opnd->ar_i64.part2;
result->ar_i8.part3 = opnd->ar_i64.part3;
result->ar_i8.part4 = opnd->ar_i64.part4 >> 8;
result->ar_i8.part5 = opnd->ar_i64.part4;
} else if (*opndtype == AR_Int_8_S && *resulttype != AR_Int_8_S) {
int
ar_convert_to_complex
(ar_data *result, const AR_TYPE *resulttype,
const ar_data *opnd, const AR_TYPE *opndtype) {
ar_data from, re, im, cre, cim;
AR_TYPE reimtype, parttype, temptype;
int status = AR_STAT_OK, restat, imstat;
parttype = (AR_TYPE) (*resulttype ^ AR_FLOAT_COMPLEX);
if (AR_CLASS (*opndtype) == AR_CLASS_FLOAT &&
AR_FLOAT_IS_COMPLEX (*opndtype) == AR_FLOAT_COMPLEX) {
status |= ar_decompose_complex (&re, &im, &reimtype,
opnd, opndtype);
restat = ar_convert_to_float (&cre, &parttype, &re, &reimtype);
imstat = ar_convert_to_float (&cim, &parttype, &im, &reimtype);
status |= ar_compose_complex (result, &temptype,
&cre, &cim, &parttype);
status &= ~(AR_STAT_ZERO | AR_STAT_NEGATIVE);
status |= restat & imstat & AR_STAT_ZERO;
return status;
}
status |= ar_convert_to_float (&cre, &parttype, opnd, opndtype);
switch (*resulttype) {
case AR_Complex_Cray1_64:
case AR_Complex_Cray1_64_F:
result->ar_cplx_f64.real = cre.ar_f64;
ZEROCRAY64 (result->ar_cplx_f64.imag);
break;
case AR_Complex_Cray1_128:
result->ar_cplx_f128.real = cre.ar_f128;
ZEROCRAY128 (result->ar_cplx_f128.imag);
break;
case AR_Complex_IEEE_NR_32:
case AR_Complex_IEEE_ZE_32:
case AR_Complex_IEEE_UP_32:
case AR_Complex_IEEE_DN_32:
IEEE32_TO_CPLX32_REAL(result->ar_cplx_ieee32, cre.ar_ieee32);
result->ar_cplx_ieee32.isign = 0;
result->ar_cplx_ieee32.iexpo = 0;
result->ar_cplx_ieee32.icoeff0 = 0;
result->ar_cplx_ieee32.icoeff1 = 0;
break;
case AR_Complex_IEEE_NR_64:
case AR_Complex_IEEE_ZE_64:
case AR_Complex_IEEE_UP_64:
case AR_Complex_IEEE_DN_64:
result->ar_cplx_ieee64.real = cre.ar_ieee64;
ZEROIEEE64 (result->ar_cplx_ieee64.imag);
break;
case AR_Complex_IEEE_NR_128:
case AR_Complex_IEEE_ZE_128:
case AR_Complex_IEEE_UP_128:
case AR_Complex_IEEE_DN_128:
result->ar_cplx_ieee128.real = cre.ar_ieee128;
ZEROIEEE128 (result->ar_cplx_ieee128.imag);
break;
default:
return AR_STAT_INVALID_TYPE;
}
return status;
}
int
ar_convert_to_float
(ar_data *result, const AR_TYPE *resulttype,
const ar_data *opnd, const AR_TYPE *opndtype) {
ar_data re, im, sint64;
AR_TYPE reimtype, sint64type = AR_Int_64_S;
int status = AR_STAT_OK;
if (AR_CLASS (*opndtype) == AR_CLASS_FLOAT) {
if (AR_FLOAT_IS_COMPLEX (*opndtype) == AR_FLOAT_COMPLEX)
status |= ar_decompose_complex (&re, &im, &reimtype,
opnd, opndtype);
else {
re = *opnd;
reimtype = *opndtype;
}
if (AR_FLOAT_FORMAT (*resulttype) == AR_FLOAT_CRAY)
if (AR_FLOAT_SIZE (*resulttype) == AR_FLOAT_64)
if (AR_FLOAT_FORMAT (reimtype) == AR_FLOAT_IEEE)
if (AR_FLOAT_SIZE (reimtype) == AR_FLOAT_64)
status |= ar_itoc64 (&result->ar_f64, &re.ar_ieee64, AR_ROUND_NEAREST);
else if (AR_FLOAT_SIZE (reimtype) == AR_FLOAT_32) {
status |= ar_i32to64 (&im.ar_ieee64, &re.ar_ieee32);
status |= ar_itoc64 (&result->ar_f64, &im.ar_ieee64, AR_ROUND_NEAREST);
} else
return AR_STAT_INVALID_TYPE;
else if (AR_FLOAT_SIZE (reimtype) == AR_FLOAT_64) {
result->ar_f64 = re.ar_f64;
status = AR_status ((AR_DATA*)result, resulttype);
} else if (AR_FLOAT_SIZE (reimtype) == AR_FLOAT_128)
status |= ar_c128to64 (&result->ar_f64,
&re.ar_f128);
else
return AR_STAT_INVALID_TYPE;
else if (AR_FLOAT_SIZE (*resulttype) == AR_FLOAT_128)
if (AR_FLOAT_FORMAT (reimtype) == AR_FLOAT_IEEE)
if (AR_FLOAT_SIZE (reimtype) == AR_FLOAT_64)
status |= ar_i64toc128 (&result->ar_f128, &re.ar_ieee64);
else if (AR_FLOAT_SIZE (reimtype) == AR_FLOAT_32) {
status |= ar_i32to64 (&im.ar_ieee64, &re.ar_ieee32);
status |= ar_i64toc128 (&result->ar_f128, &im.ar_ieee64);
} else
return AR_STAT_INVALID_TYPE;
else if (AR_FLOAT_SIZE (reimtype) == AR_FLOAT_128) {
result->ar_f128 = re.ar_f128;
status = AR_status ((AR_DATA*)result, resulttype);
} else if (AR_FLOAT_SIZE (reimtype) == AR_FLOAT_64)
status |= ar_c64to128 (&result->ar_f128,
&re.ar_f64);
else
return AR_STAT_INVALID_TYPE;
else
return AR_STAT_INVALID_TYPE;
else {
/* AR_FLOAT_FORMAT (*resulttype) == AR_FLOAT_IEEE */
if (AR_FLOAT_SIZE (*resulttype) == AR_FLOAT_32) {
if (AR_FLOAT_FORMAT (reimtype) == AR_FLOAT_IEEE) {
if (AR_FLOAT_SIZE (reimtype) == AR_FLOAT_32) {
result->ar_ieee32 = re.ar_ieee32;
status |= AR_status ((AR_DATA*)result, resulttype);
} else if (AR_FLOAT_SIZE (reimtype) == AR_FLOAT_64)
status |= ar_i64to32 (&result->ar_ieee32, &re.ar_ieee64, AR_ROUND_NEAREST);
else if (AR_FLOAT_SIZE (reimtype) == AR_FLOAT_128) {
status |= ar_i128to64 (&im.ar_ieee64, &re.ar_ieee128, AR_ROUND_NEAREST);
status |= ar_i64to32 (&result->ar_ieee32, &im.ar_ieee64, AR_ROUND_NEAREST);
}
else
return AR_STAT_INVALID_TYPE;
}
else if (AR_FLOAT_SIZE (reimtype) == AR_FLOAT_128) {
status |= ar_c128toi64 (&im.ar_ieee64, &re.ar_f128);
status |= ar_i64to32 (&result->ar_ieee32, &im.ar_ieee64, AR_ROUND_NEAREST);
} else {
status |= ar_ctoi64 (&im.ar_ieee64, &re.ar_f64);
status |= ar_i64to32 (&result->ar_ieee32, &im.ar_ieee64, AR_ROUND_NEAREST);
}
}
else if (AR_FLOAT_SIZE (*resulttype) == AR_FLOAT_64) {
if (AR_FLOAT_FORMAT (reimtype) == AR_FLOAT_IEEE) {
if (AR_FLOAT_SIZE (reimtype) == AR_FLOAT_32)
status |= ar_i32to64 (&result->ar_ieee64, &re.ar_ieee32);
else if (AR_FLOAT_SIZE (reimtype) == AR_FLOAT_64) {
result->ar_ieee64 = re.ar_ieee64;
return AR_status ((AR_DATA*)result, resulttype);
}
else if (AR_FLOAT_SIZE (reimtype) == AR_FLOAT_128)
status |= ar_i128to64 (&result->ar_ieee64, &re.ar_ieee128, AR_ROUND_NEAREST);
else
return AR_STAT_INVALID_TYPE;
}
else if (AR_FLOAT_SIZE (reimtype) == AR_FLOAT_128) {
status |= ar_ctoi128 (&im.ar_ieee128, &re.ar_f128);
status |= ar_i128to64 (&result->ar_ieee64, &im.ar_ieee128, AR_ROUND_NEAREST);
}
else {
status |= ar_ctoi64 (&result->ar_ieee64, &re.ar_f64);
}
}
else if (AR_FLOAT_SIZE (*resulttype) == AR_FLOAT_128) {
if (AR_FLOAT_FORMAT (reimtype) == AR_FLOAT_IEEE) {
if (AR_FLOAT_SIZE (reimtype) == AR_FLOAT_32) {
status |= ar_i32to64 (&im.ar_ieee64, &re.ar_ieee32);
status |= ar_i64to128 (&result->ar_ieee128, &im.ar_ieee64);
}
else if (AR_FLOAT_SIZE (reimtype) == AR_FLOAT_64)
status |= ar_i64to128 (&result->ar_ieee128, &re.ar_ieee64);
else if (AR_FLOAT_SIZE (reimtype) == AR_FLOAT_128) {
result->ar_ieee128 = re.ar_ieee128;
return AR_status ((AR_DATA*)result, resulttype);
}
else
return AR_STAT_INVALID_TYPE;
}
else if (AR_FLOAT_SIZE (reimtype) == AR_FLOAT_128)
status |= ar_ctoi128 (&result->ar_ieee128, &re.ar_f128);
else {
status |= ar_ctoi64 (&im.ar_ieee64, &re.ar_f64);
status |= ar_i64to128(&result->ar_ieee128, &im.ar_ieee64);
}
}
else if (AR_FLOAT_FORMAT (reimtype) == AR_FLOAT_CRAY)
if (AR_FLOAT_SIZE (reimtype) == AR_FLOAT_128)
status |= ar_c128toi64 (&result->ar_ieee64, &re.ar_f128);
else if (AR_FLOAT_SIZE (reimtype) == AR_FLOAT_64)
status |= ar_ctoi64 (&result->ar_ieee64, &re.ar_f64);
else
return AR_STAT_INVALID_TYPE;
else if (AR_FLOAT_SIZE (reimtype) == AR_FLOAT_32)
status |= ar_i32to64 (&result->ar_ieee64, &re.ar_ieee32);
else {
result->ar_ieee64 = re.ar_ieee64;
status = AR_status ((AR_DATA*)result, resulttype);
}
}
} else if (AR_CLASS (*opndtype) == AR_CLASS_INT) {
/* Convert to signed 64-bit (ignoring status) */
ar_convert_to_integral (&sint64, &sint64type, opnd, opndtype);
switch (*resulttype) {
case AR_Float_Cray1_64:
case AR_Float_Cray1_64_F:
status |= ar_cflt64 (&result->ar_f64, &sint64.ar_i64,
AR_SIGNEDNESS (*opndtype) == AR_UNSIGNED);
break;
case AR_Float_Cray1_128:
status |= ar_cflt128 (&result->ar_f128, &sint64.ar_i64,
AR_SIGNEDNESS (*opndtype) == AR_UNSIGNED);
break;
case AR_Float_IEEE_NR_32:
case AR_Float_IEEE_ZE_32:
case AR_Float_IEEE_UP_32:
case AR_Float_IEEE_DN_32:
status |= ar_iflt32 (&result->ar_ieee32, &sint64.ar_i64,
AR_SIGNEDNESS (*opndtype) == AR_UNSIGNED,
ROUND_MODE (*resulttype));
break;
case AR_Float_IEEE_NR_64:
case AR_Float_IEEE_ZE_64:
case AR_Float_IEEE_UP_64:
case AR_Float_IEEE_DN_64:
status |= ar_iflt64 (&result->ar_ieee64, &sint64.ar_i64,
AR_SIGNEDNESS (*opndtype) == AR_UNSIGNED,
ROUND_MODE (*resulttype));
break;
case AR_Float_IEEE_NR_128:
case AR_Float_IEEE_ZE_128:
case AR_Float_IEEE_UP_128:
case AR_Float_IEEE_DN_128:
status |= ar_iflt128 (&result->ar_ieee128, &sint64.ar_i64,
AR_SIGNEDNESS (*opndtype) == AR_UNSIGNED,
ROUND_MODE (*resulttype));
break;
default:
return AR_STAT_INVALID_TYPE;
}
} else
return AR_STAT_INVALID_TYPE;
return status;
}
int
ar_convert_to_integral
(ar_data *result, const AR_TYPE *resulttype,
const ar_data *opnd, const AR_TYPE *opndtype) {
int status = AR_STAT_OK;
int maxnegint;
int rsltsz, opndsz;
if (AR_CLASS (*opndtype) == AR_CLASS_FLOAT) {
switch (*opndtype) {
case AR_Float_Cray1_64:
case AR_Float_Cray1_64_F:
status = ar_cfix64 (&result->ar_i64, &opnd->ar_f64, 64);
break;
case AR_Float_Cray1_128:
status = ar_cfix128 (&result->ar_i64,
&opnd->ar_f128, 64);
break;
case AR_Float_IEEE_NR_32:
case AR_Float_IEEE_ZE_32:
case AR_Float_IEEE_UP_32:
case AR_Float_IEEE_DN_32:
status = ar_ifix32 (&result->ar_i64, &opnd->ar_ieee32,
64, ROUND_MODE (*opndtype));
break;
case AR_Float_IEEE_NR_64:
case AR_Float_IEEE_ZE_64:
case AR_Float_IEEE_UP_64:
case AR_Float_IEEE_DN_64:
status = ar_ifix64 (&result->ar_i64, &opnd->ar_ieee64,
64, ROUND_MODE (*opndtype));
break;
case AR_Float_IEEE_NR_128:
case AR_Float_IEEE_ZE_128:
case AR_Float_IEEE_UP_128:
case AR_Float_IEEE_DN_128:
status = ar_ifix128 (&result->ar_i64, &opnd->ar_ieee128,
64, ROUND_MODE (*opndtype));
break;
case AR_Complex_Cray1_64:
case AR_Complex_Cray1_64_F:
status = ar_cfix64 (&result->ar_i64,
&opnd->ar_cplx_f64.real, 64);
break;
case AR_Complex_Cray1_128:
status = ar_cfix128 (&result->ar_i64,
&opnd->ar_cplx_f128.real, 64);
break;
case AR_Complex_IEEE_NR_32:
case AR_Complex_IEEE_ZE_32:
case AR_Complex_IEEE_UP_32:
case AR_Complex_IEEE_DN_32:
{
AR_IEEE_32 realpart;
CPLX32_REAL_TO_IEEE32(realpart, opnd->ar_cplx_ieee32);
status = ar_ifix32 (&result->ar_i64, &realpart,
64, ROUND_MODE (*opndtype));
break;
}
case AR_Complex_IEEE_NR_64:
case AR_Complex_IEEE_ZE_64:
case AR_Complex_IEEE_UP_64:
case AR_Complex_IEEE_DN_64:
status = ar_ifix64 (&result->ar_i64,
&opnd->ar_cplx_ieee64.real,
64, ROUND_MODE (*opndtype));
break;
case AR_Complex_IEEE_NR_128:
case AR_Complex_IEEE_ZE_128:
case AR_Complex_IEEE_UP_128:
case AR_Complex_IEEE_DN_128:
status = ar_ifix128(&result->ar_i64,
&opnd->ar_cplx_ieee128.real,
64, ROUND_MODE (*opndtype));
break;
default:
return AR_STAT_INVALID_TYPE;
}
}
else if (AR_CLASS (*opndtype) == AR_CLASS_POINTER) {
result->ar_i64 = opnd->ar_i64;
}
else if (AR_CLASS (*opndtype) == AR_CLASS_INT) {
result->ar_i64 = opnd->ar_i64;
opndsz = AR_INT_SIZE(*opndtype);
if(opndsz == AR_INT_SIZE_46) opndsz = AR_INT_SIZE_64;
rsltsz = AR_INT_SIZE(*resulttype);
if(rsltsz == AR_INT_SIZE_46) rsltsz = AR_INT_SIZE_64;
if (AR_SIGNEDNESS (*opndtype) == AR_SIGNED) {
/* operand is signed; sign extend to 64-bit int */
if (opndsz == AR_INT_SIZE_8 && INT8_SIGN(opnd)) {
/* 8-bit operand is negative; extend the sign */
maxnegint = IS_INT8_UPPER_ZERO(opnd) &&
(opnd->ar_i8.part5 == 0x80);
result->ar_i8.part1 = 0xFFFF;
result->ar_i8.part2 = 0xFFFF;
result->ar_i8.part3 = 0xFFFF;
result->ar_i8.part4 = 0xFF;
}
else if (opndsz == AR_INT_SIZE_16 && INT16_SIGN(opnd)) {
maxnegint = IS_INT16_UPPER_ZERO(opnd) &&
(opnd->ar_i64.part4 == 0x8000);
/* 16-bit operand is negative; extend the sign*/
result->ar_i64.part1 = 0xFFFF;
result->ar_i64.part2 = 0xFFFF;
result->ar_i64.part3 = 0xFFFF;
}
else if (opndsz == AR_INT_SIZE_24 && INT24_SIGN(opnd)) {
maxnegint = IS_INT24_UPPER_ZERO(opnd) &&
(opnd->ar_i64.part3 == 0x80) &&
(opnd->ar_i64.part4 == 0x0);
/* 24-bit operand is negative; extend the sign*/
result->ar_i64.part1 = 0xFFFF;
result->ar_i64.part2 = 0xFFFF;
result->ar_i64.part3 |= 0xFF00;
}
else if (opndsz == AR_INT_SIZE_32 && INT32_SIGN(opnd)) {
maxnegint = IS_INT32_UPPER_ZERO(opnd) &&
(opnd->ar_i64.part3 == 0x8000) &&
(opnd->ar_i64.part4 == 0);
/* 32-bit operand is negative; extend the sign*/
result->ar_i64.part1 = 0xFFFF;
result->ar_i64.part2 = 0xFFFF;
}
else
maxnegint = (opnd->ar_i64.part1 == 0x8000) &&
(opnd->ar_i64.part2 == 0) &&
(opnd->ar_i64.part3 == 0) &&
(opnd->ar_i64.part4 == 0);
if ((result->ar_i64.part1 & 0x8000) &&
(AR_SIGNEDNESS (*resulttype) == AR_UNSIGNED)) {
/* operand is negative and result is unsigned;
original value cannot be preserved */
if(opndsz == rsltsz)
status |= AR_STAT_SEMIVALID;
if(opndsz != rsltsz || !maxnegint)
status |= AR_STAT_OVERFLOW;
}
}
else if (AR_SIGNEDNESS(*resulttype) == AR_SIGNED && rsltsz == opndsz) {
/* operand is unsigned, same size result is signed */
switch (AR_INT_SIZE (*opndtype)) {
case AR_INT_SIZE_8:
if (INT8_SIGN(opnd)) {
status |= AR_STAT_SEMIVALID;
if(opnd->ar_i8.part5 != 0x80)
status |= AR_STAT_OVERFLOW;
}
break;
case AR_INT_SIZE_16:
if (INT16_SIGN(opnd)) {
status |= AR_STAT_SEMIVALID;
if(opnd->ar_i64.part4 != 0x8000)
status |= AR_STAT_OVERFLOW;
}
break;
case AR_INT_SIZE_24:
if (INT24_SIGN(opnd)) {
status |= AR_STAT_SEMIVALID;
if(opnd->ar_i64.part3 != 0x80 ||
opnd->ar_i64.part4 != 0)
status |= AR_STAT_OVERFLOW;
}
break;
case AR_INT_SIZE_32:
if (INT32_SIGN(opnd)) {
status |= AR_STAT_SEMIVALID;
if(opnd->ar_i64.part3 != 0x8000 ||
opnd->ar_i64.part4 != 0)
status |= AR_STAT_OVERFLOW;
}
break;
case AR_INT_SIZE_46:
case AR_INT_SIZE_64:
if(INT64_SIGN(opnd)) {
status |= AR_STAT_SEMIVALID;
if(opnd->ar_i64.part1 != 0x8000 ||
opnd->ar_i64.part2 != 0 ||
opnd->ar_i64.part3 != 0 ||
opnd->ar_i64.part4 != 0)
status |= AR_STAT_OVERFLOW;
}
break;
default:
return (AR_STAT_INVALID_TYPE);
}
if(status & (AR_STAT_SEMIVALID | AR_STAT_OVERFLOW))
status |= AR_STAT_NEGATIVE;
}
else {
/* operand is unsigned and result is different size */
if (INT64_SIGN(result) &&
(AR_SIGNEDNESS(*resulttype) == AR_SIGNED)) {
/* result is negative; we have overflow */
status |= AR_STAT_OVERFLOW;
}
}
}
else
return AR_STAT_INVALID_TYPE;
/* At this point, regardless of the original operand type, we've converted
it to a 64-bit int. Now, check for overflow, negative. */
if(!(status & AR_STAT_SEMIVALID))
switch (*resulttype) {
case AR_Int_8_S:
if (!(result->ar_i8.part1 == 0xffff &&
result->ar_i8.part2 == 0xffff &&
result->ar_i8.part3 == 0xffff &&
result->ar_i8.part4 == 0xff &&
INT8_SIGN(result) == 0x80)&&
!(IS_INT8_UPPER_ZERO(result) &&
INT8_SIGN(result) == 0)) {
status |= AR_STAT_OVERFLOW;
}
if (INT8_SIGN(result))
status |= AR_STAT_NEGATIVE;
break;
case AR_Int_8_U:
if (!IS_INT8_UPPER_ZERO(result)) {
status |= AR_STAT_OVERFLOW;
}
break;
case AR_Int_16_S:
if (!(result->ar_i64.part1 == 0xffff &&
result->ar_i64.part2 == 0xffff &&
result->ar_i64.part3 == 0xffff &&
INT16_SIGN(result) == 0x8000)&&
!(IS_INT16_UPPER_ZERO(result) &&
INT16_SIGN(result) == 0)) {
status |= AR_STAT_OVERFLOW;
}
if (INT16_SIGN(result))
status |= AR_STAT_NEGATIVE;
break;
case AR_Int_16_U:
if (!IS_INT16_UPPER_ZERO(result)) {
status |= AR_STAT_OVERFLOW;
}
break;
case AR_Int_24_S:
if (!(result->ar_i64.part1 == 0xffff &&
result->ar_i64.part2 == 0xffff &&
(result->ar_i64.part3&0xff00) == 0xff00 &&
INT24_SIGN(result) == 0x0080)&&
!(IS_INT24_UPPER_ZERO(result) &&
INT24_SIGN(result) == 0)) {
status |= AR_STAT_OVERFLOW;
}
if (INT24_SIGN(result))
status |= AR_STAT_NEGATIVE;
break;
case AR_Int_24_U:
if (!IS_INT24_UPPER_ZERO(result)) {
status |= AR_STAT_OVERFLOW;
}
break;
case AR_Int_32_S:
if (!(result->ar_i64.part1 == 0xffff &&
result->ar_i64.part2 == 0xffff &&
INT32_SIGN(result) == 0x8000)&&
!(IS_INT32_UPPER_ZERO(result) &&
INT32_SIGN(result) == 0)) {
status |= AR_STAT_OVERFLOW;
}
if (INT32_SIGN(result))
status |= AR_STAT_NEGATIVE;
break;
case AR_Int_32_U:
if (!IS_INT32_UPPER_ZERO(result)) {
status |= AR_STAT_OVERFLOW;
}
break;
case AR_Int_46_S:
if (INT_OVERFLOWS_46_BITS(*result))
status |= AR_STAT_OVERFLOW;
if (INT64_SIGN(result))
status |= AR_STAT_NEGATIVE;
break;
case AR_Int_64_S:
if (INT64_SIGN(result))
status |= AR_STAT_NEGATIVE;
break;
}
ar_clear_unused_bits(result, resulttype);
if (IS_INT64_ZERO(result))
status |= AR_STAT_ZERO;
return status;
}
/* Exponentiation */
int
ar_power(ar_data *result, const AR_TYPE *resulttype,
const ar_data *base, const AR_TYPE *basetype,
const ar_data *power, const AR_TYPE *powertype)
{
int status;
ar_data tbase, tpow;
AR_TYPE btype, ptype;
ar_data base_32;
ar_data tbase_32;
ar_data tpow_32;
ar_data result_32;
AR_TYPE int32type = AR_Int_32_S;
#if !defined _CRAYMPP
#define ARPOWGG arpowgg_
#define ARPOWHH arpowhh_
#define ARPOWII arpowii_
#define ARPOWJJ arpowjj_
#define ARPOWRG arpowrg_
#define ARPOWRH arpowrh_
#define ARPOWRI arpowri_
#define ARPOWRJ arpowrj_
#define ARPOWDG arpowdg_
#define ARPOWDH arpowdh_
#define ARPOWDI arpowdi_
#define ARPOWDJ arpowdj_
#define ARPOWXDG arpowxdg_
#define ARPOWXDH arpowxdh_
#define ARPOWXDI arpowxdi_
#define ARPOWXDJ arpowxdj_
#define ARPOWCG arpowcg_
#define ARPOWCH arpowch_
#define ARPOWCI arpowci_
#define ARPOWCJ arpowcj_
#define ARPOWGR arpowgr_
#define ARPOWHR arpowhr_
#define ARPOWIR arpowir_
#define ARPOWJR arpowjr_
#define ARPOWRR arpowrr_
#define ARPOWDR arpowdr_
#define ARPOWXDR arpowxdr_
#define ARPOWCR arpowcr_
#define ARPOWDD arpowdd_
#define ARPOWXDXD arpowxdxd_
#define ARPOWCC arpowcc_
#define ARPOWCDG arpowcdg_
#define ARPOWCDH arpowcdh_
#define ARPOWCDI arpowcdi_
#define ARPOWCDJ arpowcdj_
#define ARPOWCXDG arpowcxdg_
#define ARPOWCXDH arpowcxdh_
#define ARPOWCXDI arpowcxdi_
#define ARPOWCXDJ arpowcxdj_
#define ARPOWCDCD arpowcdcd_
#define ARPOWCXDCXD arpowcxdcxd_
#endif
extern void ARPOWGG (ar_data *res, const ar_data *base,
const ar_data *power);
extern void ARPOWHH (ar_data *res, const ar_data *base,
const ar_data *power);
extern void ARPOWII (ar_data *res, const ar_data *base,
const ar_data *power);
extern void ARPOWJJ (ar_data *res, const ar_data *base,
const ar_data *power);
extern void ARPOWRG (ar_data *res, const ar_data *base,
const ar_data *power);
extern void ARPOWRH (ar_data *res, const ar_data *base,
const ar_data *power);
extern void ARPOWRI (ar_data *res, const ar_data *base,
const ar_data *power);
extern void ARPOWRJ (ar_data *res, const ar_data *base,
const ar_data *power);
extern void ARPOWDG (ar_data *res, const ar_data *base,
const ar_data *power);
extern void ARPOWDH (ar_data *res, const ar_data *base,
const ar_data *power);
extern void ARPOWDI (ar_data *res, const ar_data *base,
const ar_data *power);
extern void ARPOWDJ (ar_data *res, const ar_data *base,
const ar_data *power);
extern void ARPOWXDG (ar_data *res, const ar_data *base,
const ar_data *power);
extern void ARPOWXDH (ar_data *res, const ar_data *base,
const ar_data *power);
extern void ARPOWXDI (ar_data *res, const ar_data *base,
const ar_data *power);
extern void ARPOWXDJ (ar_data *res, const ar_data *base,
const ar_data *power);
extern void ARPOWCG (ar_data *res, const ar_data *base,
const ar_data *power);
extern void ARPOWCH (ar_data *res, const ar_data *base,
const ar_data *power);
extern void ARPOWCI (ar_data *res, const ar_data *base,
const ar_data *power);
extern void ARPOWCJ (ar_data *res, const ar_data *base,
const ar_data *power);
extern void ARPOWGR (ar_data *res, const ar_data *base,
const ar_data *power);
extern void ARPOWHR (ar_data *res, const ar_data *base,
const ar_data *power);
extern void ARPOWIR (ar_data *res, const ar_data *base,
const ar_data *power);
extern void ARPOWJR (ar_data *res, const ar_data *base,
const ar_data *power);
extern void ARPOWRR (ar_data *res, const ar_data *base,
const ar_data *power);
extern void ARPOWDR (ar_data *res, const ar_data *base,
const ar_data *power);
extern void ARPOWXDR (ar_data *res, const ar_data *base,
const ar_data *power);
extern void ARPOWCR (ar_data *res, const ar_data *base,
const ar_data *power);
extern void ARPOWDD (ar_data *res, const ar_data *base,
const ar_data *power);
extern void ARPOWXDXD (ar_data *res, const ar_data *base,
const ar_data *power);
extern void ARPOWCC (ar_data *res, const ar_data *base,
const ar_data *power);
extern void ARPOWCDG (ar_data *res, const ar_data *base,
const ar_data *power);
extern void ARPOWCDH (ar_data *res, const ar_data *base,
const ar_data *power);
extern void ARPOWCDI (ar_data *res, const ar_data *base,
const ar_data *power);
extern void ARPOWCDJ (ar_data *res, const ar_data *base,
const ar_data *power);
extern void ARPOWCXDG (ar_data *res, const ar_data *base,
const ar_data *power);
extern void ARPOWCXDH (ar_data *res, const ar_data *base,
const ar_data *power);
extern void ARPOWCXDI (ar_data *res, const ar_data *base,
const ar_data *power);
extern void ARPOWCXDJ (ar_data *res, const ar_data *base,
const ar_data *power);
extern void ARPOWCDCD (ar_data *res, const ar_data *base,
const ar_data *power);
extern void ARPOWCXDCXD (ar_data *res, const ar_data *base,
const ar_data *power);
/* Prepare for power function evalution by converting
* base and power operand types to values supported by
* the native power functions.
*/
if(AR_CLASS(*basetype) == AR_CLASS_INT) {
if(UNROUNDED_TYPE(*powertype) == IEEE_FLOAT_32) {
if(*resulttype == *powertype) {
switch (*basetype) {
case AR_Int_8_S:
case AR_Int_16_S:
ZERO_INT32_ALL(&base_32);
(void) AR_convert((AR_DATA*) &base_32,
&int32type,
(AR_DATA*)base,
basetype);
return ar_native2(ARPOWIR,
result, resulttype,
&base_32, power);
case AR_Int_32_S:
return ar_native2(ARPOWIR,
result, resulttype,
base, power);
case AR_Int_64_S:
return ar_native2(ARPOWJR,
result, resulttype,
base, power);
default:
return AR_STAT_INVALID_TYPE;
}
}
else
return AR_STAT_INVALID_TYPE;
}
btype = ptype = *powertype;
}
else if(AR_CLASS(*powertype) == AR_CLASS_INT ||
(AR_FLOAT_SIZE(*powertype) == AR_FLOAT_32 &&
AR_FLOAT_IS_COMPLEX(*powertype) != AR_FLOAT_COMPLEX)) {
/* base**I or base**R power functions */
btype = *basetype;
ptype = *powertype;
}
/* Otherwise, process arg types to simulate power function with
* base type == power type using the greatest precision and/or
* generality required.
*/
else {
/* Convert to base type == power type using the greatest
* precision and/or generality required.
*/
if(AR_FLOAT_SIZE(*basetype) >= AR_FLOAT_SIZE(*powertype))
btype = (AR_TYPE)
(*basetype | AR_FLOAT_IS_COMPLEX(*powertype));
else
btype = (AR_TYPE)
(*powertype | AR_FLOAT_IS_COMPLEX(*basetype));
ptype = btype;
}
/*
* Verify that the resulttype matches the simulated function's
* return type given by the expanded base type.
*/
if(*resulttype != btype)
return AR_STAT_INVALID_TYPE;
/*
* Setup the operands to the power function converting to the
* correct (expanded) type if necessary.
*/
status = AR_STAT_OK;
if(*basetype != btype)
status = AR_convert((AR_DATA*)&tbase, &btype,
(AR_DATA*)base, basetype);
else
tbase = *base;
if(*powertype != ptype)
status = AR_convert((AR_DATA*)&tpow, &ptype,
(AR_DATA*)power, powertype);
else
tpow = *power;
if (IS_ERROR_STATUS(status))
return status;
/*
* Call the correct native power function determined by
* the (expanded) base and power types.
*/
switch (UNROUNDED_TYPE(btype)) {
case IEEE_FLOAT_32:
if(AR_CLASS(ptype) == AR_CLASS_INT)
switch (ptype) {
case AR_Int_8_S:
case AR_Int_16_S:
ZERO_INT32_ALL(&tpow_32);
(void) AR_convert((AR_DATA*) &tpow_32,
&int32type,
(AR_DATA*) &tpow,
&ptype);
return ar_native2(ARPOWRI,
result, resulttype,
&tbase, &tpow_32);
case AR_Int_32_S:
return ar_native2(ARPOWRI,
result, resulttype,
&tbase, &tpow);
case AR_Int_64_S:
return ar_native2(ARPOWRJ,
result, resulttype,
&tbase, &tpow);
default:
return AR_STAT_INVALID_TYPE;
}
else
return ar_native2(ARPOWRR,
result, resulttype,
&tbase, &tpow);
case IEEE_FLOAT_64:
if(AR_CLASS(ptype) == AR_CLASS_INT)
switch (ptype) {
case AR_Int_8_S:
case AR_Int_16_S:
ZERO_INT32_ALL(&tpow_32);
(void) AR_convert((AR_DATA*) &tpow_32,
&int32type,
(AR_DATA*) &tpow,
&ptype);
return ar_native2(ARPOWDI,
result, resulttype,
&tbase, &tpow_32);
case AR_Int_32_S:
return ar_native2(ARPOWDI,
result, resulttype,
&tbase, &tpow);
case AR_Int_64_S:
return ar_native2(ARPOWDJ,
result, resulttype,
&tbase, &tpow);
default:
return AR_STAT_INVALID_TYPE;
}
else if(AR_FLOAT_SIZE(ptype) == AR_FLOAT_32)
return ar_native2(ARPOWDR,
result, resulttype,
&tbase, &tpow);
else
return ar_native2(ARPOWDD,
result, resulttype,
&tbase, &tpow);
case IEEE_FLOAT_128:
if(AR_CLASS(ptype) == AR_CLASS_INT)
switch (ptype) {
case AR_Int_8_S:
case AR_Int_16_S:
ZERO_INT32_ALL(&tpow_32);
(void) AR_convert((AR_DATA*) &tpow_32,
&int32type,
(AR_DATA*) &tpow,
&ptype);
return ar_native2(ARPOWXDI,
result, resulttype,
&tbase, &tpow_32);
case AR_Int_32_S:
return ar_native2(ARPOWXDI,
result, resulttype,
&tbase, &tpow);
case AR_Int_64_S:
return ar_native2(ARPOWXDJ,
result, resulttype,
&tbase, &tpow);
default:
return AR_STAT_INVALID_TYPE;
}
else if(AR_FLOAT_SIZE(ptype) == AR_FLOAT_32)
return ar_native2(ARPOWXDR,
result, resulttype,
&tbase, &tpow);
else
return ar_native2(ARPOWXDXD,
result, resulttype,
&tbase, &tpow);
case IEEE_COMPLEX_32:
if(AR_CLASS(ptype) == AR_CLASS_INT)
switch (ptype) {
case AR_Int_8_S:
case AR_Int_16_S:
ZERO_INT32_ALL(&tpow_32);
(void) AR_convert((AR_DATA*) &tpow_32,
&int32type,
(AR_DATA*) &tpow,
&ptype);
return ar_native2(ARPOWCI,
result, resulttype,
&tbase, &tpow_32);
case AR_Int_32_S:
return ar_native2(ARPOWCI,
result, resulttype,
&tbase, &tpow);
case AR_Int_64_S:
return ar_native2(ARPOWCJ,
result, resulttype,
&tbase, &tpow);
default:
return AR_STAT_INVALID_TYPE;
}
else if(AR_FLOAT_IS_COMPLEX(ptype) != AR_FLOAT_COMPLEX)
return ar_native2(ARPOWCR,
result, resulttype,
&tbase, &tpow);
else
return ar_native2(ARPOWCC,
result, resulttype,
&tbase, &tpow);
case IEEE_COMPLEX_64:
if(AR_CLASS(ptype) == AR_CLASS_INT)
switch (ptype) {
case AR_Int_8_S:
case AR_Int_16_S:
ZERO_INT32_ALL(&tpow_32);
(void) AR_convert((AR_DATA*) &tpow_32,
&int32type,
(AR_DATA*) &tpow,
&ptype);
return ar_native2(ARPOWCDI,
result, resulttype,
&tbase, &tpow_32);
case AR_Int_32_S:
return ar_native2(ARPOWCDI,
result, resulttype,
&tbase, &tpow);
case AR_Int_64_S:
return ar_native2(ARPOWCDJ,
result, resulttype,
&tbase, &tpow);
default:
return AR_STAT_INVALID_TYPE;
}
else
return ar_native2(ARPOWCDCD,
result, resulttype,
&tbase, &tpow);
case IEEE_COMPLEX_128:
if(AR_CLASS(ptype) == AR_CLASS_INT)
switch (ptype) {
case AR_Int_8_S:
case AR_Int_16_S:
ZERO_INT32_ALL(&tpow_32);
(void) AR_convert((AR_DATA*) &tpow_32,
&int32type,
(AR_DATA*) &tpow,
&ptype);
return ar_native2(ARPOWCXDI,
result, resulttype,
&tbase, &tpow_32);
case AR_Int_32_S:
return ar_native2(ARPOWCXDI,
result, resulttype,
&tbase, &tpow);
case AR_Int_64_S:
return ar_native2(ARPOWCXDJ,
result, resulttype,
&tbase, &tpow);
default:
return AR_STAT_INVALID_TYPE;
}
else
return ar_native2(ARPOWCXDCXD,
result, resulttype,
&tbase, &tpow);
default:
switch (btype) {
case AR_Int_8_S:
case AR_Int_16_S:
ZERO_INT32_ALL(&tbase_32);
ZERO_INT32_ALL(&tpow_32);
ZERO_INT32_ALL(&result_32);
(void) AR_convert((AR_DATA*) &tbase_32,
&int32type,
(AR_DATA*) &tbase,
&btype);
(void) AR_convert((AR_DATA*) &tpow_32,
&int32type,
(AR_DATA*) &tpow,
&ptype);
status = ar_native2(ARPOWII,
&result_32, &int32type,
&tbase_32, &tpow_32);
if (IS_ERROR_STATUS(status))
return status;
return AR_convert((AR_DATA*) result, resulttype,
(AR_DATA*) &result_32, &int32type);
case AR_Int_32_S:
ZERO_INT32_UPPER(result);
return ar_native2(ARPOWII,
result, resulttype,
&tbase, &tpow);
case AR_Int_64_S:
return ar_native2(ARPOWJJ,
result, resulttype,
&tbase, &tpow);
default:
return AR_STAT_INVALID_TYPE;
}
}
}
/* Exponentiation */
int
ar_power(ar_data *result, const AR_TYPE *resulttype,
const ar_data *base, const AR_TYPE *basetype,
const ar_data *power, const AR_TYPE *powertype)
{
int i;
int status;
int status2;
ar_data tbase, tpow, tpow2, temp, one;
AR_TYPE inttype = AR_Int_64_S;
static int loopchk = 0;
#ifdef complex_t
if (*basetype == native_complex || *powertype == native_complex) {
if (*resulttype != native_complex)
return AR_STAT_INVALID_TYPE;
if (*basetype != native_complex) {
status = AR_convert ((AR_DATA*)&tbase, &native_complex,
(AR_DATA*)base, basetype);
if (IS_ERROR_STATUS(status))
return AR_STAT_INVALID_TYPE;
} else
tbase = *base;
if (*powertype != native_complex) {
status = AR_convert ((AR_DATA*)&tpow, &native_complex,
(AR_DATA*)power, powertype);
if (IS_ERROR_STATUS(status))
return AR_STAT_INVALID_TYPE;
} else
tpow = *power;
*(complex_t *) result = (cpow) (*(complex_t *) &tbase,
*(complex_t *) &tpow);
return AR_status((AR_DATA*)result, resulttype);
}
#endif
if (*basetype == native_double ||
*powertype == native_double) {
if (*resulttype != native_double)
return AR_STAT_INVALID_TYPE;
if (*basetype != native_double) {
status = AR_convert ((AR_DATA*)&tbase, &native_double,
(AR_DATA*)base, basetype);
if (IS_ERROR_STATUS(status))
return AR_STAT_INVALID_TYPE;
} else
tbase = *base;
if (*powertype != native_double) {
status = AR_convert ((AR_DATA*)&tpow, &native_double,
(AR_DATA*)power, powertype);
if (IS_ERROR_STATUS(status))
return AR_STAT_INVALID_TYPE;
} else
tpow = *power;
*(double_t *) result = (pow) (*(double_t *) &tbase,
*(double_t *) &tpow);
return AR_status((AR_DATA*)result, resulttype);
}
/* The operation is not a native library operation.
* Convert, approximate with native arithmetic, and convert back.
*/
/* Use native exponentiation routines if appropriate. */
/*
* Native routines will not be used directly.
*/
/* Get "1" of the proper type */
if (AR_one ((AR_DATA*)&one, basetype) & AR_STAT_INVALID_TYPE)
return AR_STAT_INVALID_TYPE;
status = AR_status ((AR_DATA*)base, basetype);
/* 0 ** 0 and 0 ** (neg) are invalid; 0 ** (pos) == 0. */
if (status & AR_STAT_ZERO) {
status = AR_status ((AR_DATA*)power, powertype);
if (status & (AR_STAT_ZERO | AR_STAT_NEGATIVE))
return AR_STAT_UNDEFINED;
return AR_convert ((AR_DATA*)result, resulttype, (AR_DATA*)base, basetype);
}
/* 1 ** (anything) == 1 */
if (AR_compare ((AR_DATA*)base, basetype, (AR_DATA*)&one, basetype) == AR_Compare_EQ)
return AR_convert ((AR_DATA*)result, resulttype, (AR_DATA*)&one, basetype);
/* Exponentiation by integer powers */
if (AR_CLASS (*powertype) == AR_CLASS_INT) {
if (*resulttype != *basetype)
return AR_STAT_INVALID_TYPE;
/* (integer) ** 1 == (integer) */
if (AR_CLASS (*basetype) == AR_CLASS_INT &&
AR_compare ((AR_DATA*)power, powertype, (AR_DATA*)&one, powertype) ==
AR_Compare_EQ)
return AR_convert ((AR_DATA*)result, resulttype, (AR_DATA*)base, basetype);
/* (-1) ** (even) == 1, (-1) ** (odd) == -1 */
AR_negate ((AR_DATA*)&tbase, basetype, (AR_DATA*)&one, basetype);
if (AR_compare ((AR_DATA*)base, basetype, (AR_DATA*)&tbase, basetype) ==
AR_Compare_EQ) {
if (power->ar_i64.part4 & 1)
return AR_convert ((AR_DATA*)result, resulttype,
(AR_DATA*)base, basetype);
return AR_convert ((AR_DATA*)result, resulttype,
(AR_DATA*)&one, basetype);
}
/* Compute negative integer powers by computing a power
* of a reciprocal.
*/
if (INT_SIGN(*powertype, power)) {
/* (int other than 0, 1, -1) ** (negative) == 0 */
if (AR_CLASS (*basetype) == AR_CLASS_INT)
return AR_convert ((AR_DATA*)result, resulttype,
(AR_DATA*)&AR_const_zero, &inttype);
status = AR_divide ((AR_DATA*)&tbase, basetype,
(AR_DATA*)&one, basetype,
(AR_DATA*)base, basetype);
status &= AR_ERROR_STATUS;
if (status) {
AR_convert ((AR_DATA*)result, resulttype,
&AR_const_zero, &inttype);
return status;
}
AR_negate ((AR_DATA*)&tpow, powertype, (AR_DATA*)power, powertype);
} else {
tbase = *base;
tpow = *power;
}
/* Perform exponentiation by repeated multiplication */
status = AR_convert ((AR_DATA*)result, resulttype, (AR_DATA*)&one, basetype);
status2 = AR_STAT_OK;
switch (AR_INT_SIZE (*opnd1type)) {
case AR_INT_SIZE_8:
AR_convert ((AR_DATA*) &tpow2, &inttype,
(AR_DATA*) &tpow, opnd1type);
break;
case AR_INT_SIZE_16:
AR_convert ((AR_DATA*) &tpow2, &inttype,
(AR_DATA*) &tpow, opnd1type);
break;
case AR_INT_SIZE_32:
AR_convert ((AR_DATA*) &tpow2, &inttype,
(AR_DATA*) &tpow, opnd1type);
break;
case AR_INT_SIZE_46:
case AR_INT_SIZE_64:
tpow2 = tpow;
break;
default:
return (AR_STAT_INVALID_TYPE);
}
while (!IS_INT64_ZERO(&tpow2)) {
if (IS_ERROR_STATUS(status2)) {
AR_convert ((AR_DATA*)result, resulttype,
&AR_const_zero, &inttype);
return status2 & AR_ERROR_STATUS;
}
if (tpow2.ar_i64.part4 & 1) {
status = AR_multiply ((AR_DATA*)result,
resulttype,
(AR_DATA*)result,
resulttype,
(AR_DATA*)&tbase,
basetype);
if (IS_ERROR_STATUS(status)) {
AR_convert ((AR_DATA*)result,
resulttype,
&AR_const_zero,
&inttype);
return status & AR_ERROR_STATUS;
}
}
status2 = AR_multiply ((AR_DATA*)&tbase, basetype,
(AR_DATA*)&tbase, basetype,
(AR_DATA*)&tbase, basetype);
SHRIGHT64 (tpow2.ar_i64);
}
return status;
}
/*
* Exponentiation by non-native floating powers
*/
if(loopchk > 0)
return AR_STAT_INVALID_TYPE;
if (AR_CLASS (*basetype) == AR_CLASS_FLOAT &&
AR_FLOAT_IS_COMPLEX (*basetype) == AR_FLOAT_COMPLEX ||
AR_CLASS (*powertype) == AR_CLASS_FLOAT &&
AR_FLOAT_IS_COMPLEX (*powertype) == AR_FLOAT_COMPLEX) {
#ifndef complex_t
return AR_STAT_INVALID_TYPE;
#else
/* Compute (native complex) ** (native complex) */
status = AR_convert ((AR_DATA*)&tbase, &native_complex, (AR_DATA*)base, basetype);
status |= AR_convert ((AR_DATA*)&tpow, &native_complex, (AR_DATA*)power, powertype);
if (!IS_ERROR_STATUS(status)) {
loopchk++;
status = ar_power (&temp, &native_complex,
&tbase, &native_complex,
&tpow, &native_complex);
loopchk--;
if (!IS_ERROR_STATUS(status))
status = AR_convert ((AR_DATA*)result, resulttype,
(AR_DATA*)&temp, &native_complex);
}
return status;
#endif
}
/* Compute as (native double prec) ** (native double prec) */
status = AR_convert ((AR_DATA*)&tbase, &native_long_double, (AR_DATA*)base, basetype);
status |= AR_convert ((AR_DATA*)&tpow, &native_long_double, (AR_DATA*)power, powertype);
if (!IS_ERROR_STATUS(status)) {
loopchk++;
status = ar_power (&temp, &native_long_double,
&tbase, &native_long_double,
&tpow, &native_long_double);
loopchk--;
if (!IS_ERROR_STATUS(status))
status = AR_convert ((AR_DATA*)result, resulttype,
(AR_DATA*)&temp, &native_long_double);
}
return status;
}
