/**
* @brief convert octal to integer
*
* Standard C prohibits values outside the range of unsigned char for normal
* character constants, which is \377 or decimal 255
*
* @param s the matched octal
* node pointer to internal node representation
* @return none
*/
static inline void octal_to_decimal(char *s, struct node *node)
{
int i;
errno = 0;
i = strtol(s, NULL, 8);
if (errno == ERANGE || i > 255) {
node->data.number.overflow = true;
node->data.number.result.type = type_basic(false, TYPE_BASIC_INT);
return;
}
node->data.number.overflow = false;
node->data.number.result.type = type_basic(false, TYPE_BASIC_INT);
node->data.number.value = (char)i;
}
static TYPE_DESC
get_intrinsic_return_type(intrinsic_entry *ep, expv args, expv kindV) {
BASIC_DATA_TYPE bType = TYPE_UNKNOWN;
TYPE_DESC bTypeDsc = NULL;
TYPE_DESC ret = NULL;
expv a = NULL;
if (INTR_RETURN_TYPE(ep) == INTR_TYPE_NONE) {
return NULL;
}
if (INTR_RETURN_TYPE_SAME_AS(ep) >= 0) {
/* return type is in args. */
a = expr_list_get_n(args, INTR_RETURN_TYPE_SAME_AS(ep));
if (!(isValidTypedExpv(a))) {
return NULL;
}
ret = EXPV_TYPE(a);
} else {
switch (INTR_RETURN_TYPE_SAME_AS(ep)) {
case -1 /* if not dynamic return type,
argument is scalar/array and
return type is scalar/array */ :
case -6 /* if not dynamic return type,
argument is scalar/array, return
return type is scalar */ : {
if (!(INTR_IS_RETURN_TYPE_DYNAMIC(ep)) &&
(INTR_RETURN_TYPE(ep) != INTR_TYPE_ALL_NUMERICS &&
INTR_RETURN_TYPE(ep) != INTR_TYPE_NUMERICS)) {
bType = intr_type_to_basic_type(INTR_RETURN_TYPE(ep));
if (bType == TYPE_UNKNOWN) {
fatal("invalid intrinsic return type (case -1/-6).");
/* not reached. */
return NULL;
} else {
if (kindV == NULL) {
ret = (bType != TYPE_CHAR) ? type_basic(bType) :
type_char(1);
} else {
/*
* Don't use BASIC_TYPE_DESC(bType) very
* here, since we need to set a kind to
* the TYPE_DESC.
*/
ret = type_basic(bType);
TYPE_KIND(ret) = kindV;
}
}
ret = intr_convert_to_dimension_ifneeded(
ep, args, ret);
} else {
expv shape = list0(LIST);
TYPE_DESC tp;
switch (INTR_OP(ep)) {
case INTR_ALL:
case INTR_ANY:
case INTR_MAXVAL:
case INTR_MINVAL:
case INTR_PRODUCT:
case INTR_SUM:
case INTR_COUNT:
{
/* intrinsic arguments */
expv array, dim;
array = expr_list_get_n(args, 0);
if (!(isValidTypedExpv(array))) {
return NULL;
}
tp = EXPV_TYPE(array);
dim = expr_list_get_n(args, 1);
if (!(isValidTypedExpv(dim))) {
return NULL;
}
/* set basic type of array type */
switch (INTR_OP(ep)) {
case INTR_ALL:
case INTR_ANY:
bType = TYPE_LOGICAL;
break;
case INTR_COUNT:
bType = TYPE_INT;
break;
default:
bType = get_basic_type(tp);
break;
}
if (kindV == NULL) {
bTypeDsc = BASIC_TYPE_DESC(bType);
} else {
bTypeDsc = type_basic(bType);
TYPE_KIND(bTypeDsc) = kindV;
}
dim = expv_reduce(dim, FALSE);
if(EXPV_CODE(dim) == INT_CONSTANT) {
int nDim;
nDim = (int)EXPV_INT_VALUE(dim);
if(nDim > TYPE_N_DIM(tp) || nDim <= 0) {
error("value DIM of intrinsic %s "
"out of range.", INTR_NAME(ep));
return NULL;
}
generate_contracted_shape_expr(
tp, shape, TYPE_N_DIM(tp) - nDim);
} else {
generate_assumed_shape_expr(
shape, TYPE_N_DIM(tp) - 1);
}
}
break;
case INTR_SPREAD:
{
/* intrinsic arguments */
expv array, dim, ncopies;
array = expr_list_get_n(args, 0);
if (!(isValidTypedExpv(array))) {
return NULL;
}
dim = expr_list_get_n(args, 1);
if (!(isValidTypedExpv(dim))) {
return NULL;
}
ncopies = expr_list_get_n(args, 2);
if (!(isValidTypedExpv(ncopies))) {
return NULL;
}
tp = EXPV_TYPE(array);
bType = get_basic_type(tp);
if (kindV == NULL) {
bTypeDsc = BASIC_TYPE_DESC(bType);
} else {
bTypeDsc = type_basic(bType);
TYPE_KIND(bTypeDsc) = kindV;
}
dim = expv_reduce(dim, FALSE);
if(EXPR_CODE(dim) == INT_CONSTANT) {
int nDim;
nDim = (int)EXPV_INT_VALUE(dim);
if(nDim > (TYPE_N_DIM(tp) + 1) || nDim <= 0) {
error("value DIM of intrinsic %s "
"out of range.", INTR_NAME(ep));
return NULL;
}
generate_expand_shape_expr(
tp, shape, ncopies, TYPE_N_DIM(tp) + 1 - nDim);
} else {
generate_assumed_shape_expr(
shape, TYPE_N_DIM(tp) - 1);
}
}
break;
case INTR_RESHAPE:
{
/* intrinsic arguments */
expv source, arg_shape;
source = expr_list_get_n(args, 0);
if (!(isValidTypedExpv(source))) {
return NULL;
}
arg_shape = expr_list_get_n(args, 1);
if (!(isValidTypedExpv(arg_shape))) {
return NULL;
}
tp = EXPV_TYPE(source);
bType = get_basic_type(tp);
if (kindV == NULL) {
bTypeDsc = BASIC_TYPE_DESC(bType);
} else {
bTypeDsc = type_basic(bType);
TYPE_KIND(bTypeDsc) = kindV;
}
tp = EXPV_TYPE(arg_shape);
if (TYPE_N_DIM(tp) != 1) {
error("SHAPE argument of intrinsic "
"RESHAPE is not vector.");
return NULL;
}
/*
* We can't determine # of the elements in
* this array that represents dimension of the
* return type, which is identical to the
* reshaped array. In order to express this,
* we introduce a special TYPE_DESC, which is
* having a flag to specify that the type is
* generated by the reshape() intrinsic.
*/
/*
* dummy one dimensional assumed array.
*/
generate_assumed_shape_expr(shape, 2);
ret = compile_dimensions(bTypeDsc, shape);
fix_array_dimensions(ret);
TYPE_IS_RESHAPED(ret) = TRUE;
return ret;
}
break;
case INTR_MATMUL:
{
expv m1 = expr_list_get_n(args, 0);
expv m2 = expr_list_get_n(args, 1);
TYPE_DESC t1 = EXPV_TYPE(m1);
TYPE_DESC t2 = EXPV_TYPE(m2);
expv s1 = list0(LIST);
expv s2 = list0(LIST);
/*
* FIXME:
* Should we use
* get_binary_numeric_intrinsic_operation_type()
* instead of max_type()? I think so but
* not sure at this moment.
*/
bType = get_basic_type(max_type(t1, t2));
if (kindV == NULL) {
bTypeDsc = BASIC_TYPE_DESC(bType);
} else {
bTypeDsc = type_basic(bType);
TYPE_KIND(bTypeDsc) = kindV;
}
generate_shape_expr(t1, s1);
generate_shape_expr(t2, s2);
if (TYPE_N_DIM(t1) == 2 &&
TYPE_N_DIM(t2) == 2) {
/*
* (n, m) * (m, k) => (n, k).
*/
shape = list2(LIST,
EXPR_ARG1(s1), EXPR_ARG2(s2));
} else if (TYPE_N_DIM(t1) == 2 &&
TYPE_N_DIM(t2) == 1) {
/*
* (n, m) * (m) => (n).
*/
shape = list1(LIST, EXPR_ARG1(s1));
} else if (TYPE_N_DIM(t1) == 1 &&
TYPE_N_DIM(t2) == 2) {
/*
* (m) * (m, k) => (k).
*/
shape = list1(LIST, EXPR_ARG2(s2));
} else {
error("an invalid dimension combination for "
"matmul(), %d and %d.",
TYPE_N_DIM(t1), TYPE_N_DIM(t2));
return NULL;
}
ret = compile_dimensions(bTypeDsc, shape);
fix_array_dimensions(ret);
return ret;
}
break;
case INTR_DOT_PRODUCT:
{
expv m1 = expr_list_get_n(args, 0);
expv m2 = expr_list_get_n(args, 1);
TYPE_DESC t1 = EXPV_TYPE(m1);
TYPE_DESC t2 = EXPV_TYPE(m2);
if (TYPE_N_DIM(t1) == 1 &&
TYPE_N_DIM(t2) == 1) {
TYPE_DESC tp =
get_binary_numeric_intrinsic_operation_type(
t1, t2);
return array_element_type(tp);
} else {
error("argument(s) is not a one-dimensional "
"array.");
return NULL;
}
}
break;
case INTR_PACK:
{
if (INTR_N_ARGS(ep) == 3){
expv v = expr_list_get_n(args, 2);
return EXPV_TYPE(v);
}
else {
a = expr_list_get_n(args, 0);
if (!(isValidTypedExpv(a))) {
return NULL;
}
bType = get_basic_type(EXPV_TYPE(a));
bTypeDsc = BASIC_TYPE_DESC(bType);
expr dims = list1(LIST, NULL);
ret = compile_dimensions(bTypeDsc, dims);
fix_array_dimensions(ret);
return ret;
}
}
break;
case INTR_UNPACK:
{
a = expr_list_get_n(args, 0);
if (!(isValidTypedExpv(a))) {
return NULL;
}
bType = get_basic_type(EXPV_TYPE(a));
bTypeDsc = BASIC_TYPE_DESC(bType);
a = expr_list_get_n(args, 1);
if (!(isValidTypedExpv(a))) {
return NULL;
}
TYPE_DESC tp = EXPV_TYPE(a);
ret = copy_dimension(tp, bTypeDsc);
fix_array_dimensions(ret);
return ret;
}
break;
default:
{
/* not reached ! */
ret = BASIC_TYPE_DESC(TYPE_GNUMERIC_ALL);
}
}
ret = compile_dimensions(bTypeDsc, shape);
fix_array_dimensions(ret);
}
break;
}
case -2: {
/*
* Returns BASIC_TYPE of the first arg.
*/
a = expr_list_get_n(args, 0);
if (!(isValidTypedExpv(a))) {
return NULL;
}
bType = get_basic_type(EXPV_TYPE(a));
if (kindV == NULL) {
ret = BASIC_TYPE_DESC(bType);
} else {
ret = type_basic(bType);
TYPE_KIND(ret) = kindV;
}
break;
}
case -3: {
/*
* Returns single dimension array of integer having
* elemnets that equals to the first arg's dimension.
*/
/*
* FIXME:
* No need to check kindV?? I believe we don't, though.
*/
bTypeDsc = BASIC_TYPE_DESC(TYPE_INT);
TYPE_DESC tp = NULL;
expr dims = NULL;
int nDims = 0;
a = expr_list_get_n(args, 0);
if (!(isValidTypedExpv(a))) {
return NULL;
}
bTypeDsc = BASIC_TYPE_DESC(TYPE_INT);
tp = EXPV_TYPE(a);
nDims = TYPE_N_DIM(tp);
dims = list1(LIST, make_int_enode(nDims));
ret = compile_dimensions(bTypeDsc, dims);
fix_array_dimensions(ret);
break;
}
case -4:{
/*
* Returns transpose of the first arg (matrix).
*/
TYPE_DESC tp = NULL;
expr dims = list0(LIST);
a = expr_list_get_n(args, 0);
if (!(isValidTypedExpv(a))) {
return NULL;
}
tp = EXPV_TYPE(a);
bType = get_basic_type(tp);
if (kindV == NULL) {
bTypeDsc = BASIC_TYPE_DESC(bType);
} else {
bTypeDsc = type_basic(bType);
TYPE_KIND(bTypeDsc) = kindV;
}
if (TYPE_N_DIM(tp) != 2) {
error("Dimension is not two.");
return NULL;
}
generate_reverse_dimension_expr(tp, dims);
ret = compile_dimensions(bTypeDsc, dims);
fix_array_dimensions(ret);
break;
}
case -5: {
/*
* -5 : BASIC_TYPE of return type is 'returnType' and
* kind of return type is same as first arg.
*/
int nDims = 0;
TYPE_DESC tp = NULL;
a = expr_list_get_n(args, 0);
if (!(isValidTypedExpv(a))) {
return NULL;
}
tp = EXPV_TYPE(a);
switch (INTR_OP(ep)) {
case INTR_AIMAG: case INTR_DIMAG: {
bType = get_basic_type(tp);
if (bType != TYPE_COMPLEX &&
bType != TYPE_DCOMPLEX) {
error("argument is not a complex type.");
return NULL;
}
bType = (bType == TYPE_COMPLEX) ?
TYPE_REAL : TYPE_DREAL;
break;
}
default: {
bType = intr_type_to_basic_type(INTR_RETURN_TYPE(ep));
break;
}
}
if (bType == TYPE_UNKNOWN) {
fatal("invalid intrinsic return type (case -5).");
/* not reached. */
return NULL;
}
bTypeDsc = type_basic(bType);
TYPE_KIND(bTypeDsc) = TYPE_KIND(tp);
if ((nDims = TYPE_N_DIM(tp)) > 0) {
ret = copy_dimension(tp, bTypeDsc);
fix_array_dimensions(ret);
} else {
ret = bTypeDsc;
}
break;
}
case -7: {
TYPE_DESC lhsTp = new_type_desc();
TYPE_BASIC_TYPE(lhsTp) = TYPE_LHS;
TYPE_ATTR_FLAGS(lhsTp) |= TYPE_ATTR_TARGET;
ret = lhsTp;
break;
}
case -8: {
bType = intr_type_to_basic_type(INTR_RETURN_TYPE(ep));
if (bType == TYPE_UNKNOWN) {
fatal("invalid intrinsic return type (case -8).");
return NULL;
} else {
ret = type_basic(bType);
}
TYPE_SET_EXTERNAL(ret);
break;
}
case -9: {
bType = intr_type_to_basic_type(INTR_RETURN_TYPE(ep));
ret = type_basic(bType);
break;
}
default: {
fatal("%s: Unknown return type specification.", __func__);
break;
}
}
}
return ret;
}
/**
* @brief allocate a node to represent a number
*
* A lot of the logic is based on H&S table 2.6. This module understands numbers
* and character constants
*
* @param text contains the numeric literal
* @return pointer to the node structure defined in node.h
*/
struct node *node_number(char *text)
{
struct node *node = node_create(NODE_NUMBER);
unsigned long buf;
errno = 0;
/* is a number, if not a character, if not octal */
if ( text[0] != '\'' ) {
buf = node->data.number.value = strtoul(text, NULL, 10);
/* strtoul indicated overflow. */
if (buf == ULONG_MAX && errno == ERANGE) {
node->data.number.result.type = type_basic(false, TYPE_BASIC_LONG);
node->data.number.overflow = true;
}
/* Value is too large for 32-bit unsigned int type. */
else if (buf > 0xFFFFFFFFul) {
node->data.number.result.type = type_basic(false, TYPE_BASIC_LONG);
node->data.number.overflow = true;
}
else {
/* signed int, no overflow */
if ( buf <= 0x7FFFFFFF )
node->data.number.result.type = type_basic(false, TYPE_BASIC_INT);
/* unsigned long, no overflow */
else if ( buf <= 0xFFFFFFFFul )
node->data.number.result.type = type_basic(true, TYPE_BASIC_LONG);
node->data.number.overflow = false;
}
return node;
}
else { /* single character or octal or escape character*/
if ( strlen(text) == 3 )
node->data.number.value = text[1];
else {
int ch;
switch ( text[2] ) {
case 'n':
ch = '\n';
break;
case 't':
ch = '\t';
break;
case 'b':
ch = '\b';
break;
case 'r':
ch = '\r';
break;
case 'f':
ch = '\f';
break;
case 'v':
ch = '\v';
break;
case '\\':
ch = '\\';
break;
case '\'':
ch = '\'';
break;
case '\"':
ch = '\"';
break;
case 'a':
ch = '\a';
break;
case '\?':
ch = '\?';
break;
default:
octal_to_decimal(text + 2, node);
return node;
}
node->data.number.value = ch;
}
}
if (strlen(text) == 2)
node->data.number.value = 0;
node->data.number.overflow = false;
node->data.number.result.type = type_basic(false, TYPE_BASIC_INT);
return node;
}