/**
* check type is omissible, such that
* no attributes, no memebers, no indexRanage and so on.
*
* FIXME:
* shrink_type() and type_is_omissible() are quick-fix.
* see shrink_type().
*/
int
type_is_omissible(TYPE_DESC tp, uint32_t attr, uint32_t ext)
{
// NULL or a terminal type is not omissible.
if (tp == NULL || TYPE_REF(tp) == NULL)
return FALSE;
// The struct type is not omissible.
if (IS_STRUCT_TYPE(tp))
return FALSE;
// The array type is not omissible.
if (IS_ARRAY_TYPE(tp))
return FALSE;
// The function type is not omissible.
if (IS_FUNCTION_TYPE(tp))
return FALSE;
// Co-array is not omissible.
if (tp->codims != NULL)
return FALSE;
// The type has kind, leng, or size is not omissible.
if (TYPE_KIND(tp) != NULL ||
TYPE_LENG(tp) != NULL ||
TYPE_CHAR_LEN(tp) != 0) {
return FALSE;
}
#if 0
// The type has attributes is not omissible.
if (TYPE_ATTR_FLAGS(tp))
return FALSE;
if (TYPE_EXTATTR_FLAGS(tp))
return FALSE;
#else
/*
* not omissible if this type has any attributes that is not
* included in the given attrribute flags.
*/
if (TYPE_ATTR_FLAGS(tp) != 0) {
if ((attr != 0 && (attr & TYPE_ATTR_FLAGS(tp)) == 0) ||
(attr == 0)) {
return FALSE;
}
}
if (TYPE_EXTATTR_FLAGS(tp) != 0) {
if ((ext != 0 && (ext & TYPE_EXTATTR_FLAGS(tp)) == 0) ||
(ext == 0)) {
return FALSE;
}
}
#endif
return TRUE;
}
Variant::TypeId Variant::type() const
{
const std::type_info& info = self->var.type();
TYPE_KIND(std::string, STRING);
TYPE_KIND(int32_t, INT32);
TYPE_KIND(uint32_t, UINT32);
TYPE_KIND(int64_t, INT64);
TYPE_KIND(uint64_t, UINT64);
TYPE_KIND(float, FLOAT);
TYPE_KIND(double, DOUBLE);
TYPE_KIND(char, CHAR);
TYPE_KIND(unsigned char, UCHAR);
TYPE_KIND(bool, BOOL);
if(info == typeid(int)) {
if(self->size == 4) return INT32;
if(self->size == 8) return INT64;
}
if(info == typeid(long)) {
if(self->size == 4) return INT32;
if(self->size == 8) return INT64;
}
if(info == typeid(unsigned int)) {
if(self->size == 4) return UINT32;
if(self->size == 8) return UINT64;
}
if(info == typeid(unsigned long)) {
if(self->size == 4) return UINT32;
if(self->size == 8) return UINT64;
}
return EMPTY;
}
TYPE_DESC
wrap_type(TYPE_DESC tp)
{
TYPE_DESC tq = new_type_desc();
if (tp == tq) {
fatal("%s: must be an malloc() problem, "
"newly alloc'd TYPE_DESC has duplicated address.",
__func__);
/* not reached. */
return NULL;
}
TYPE_REF(tq) = tp;
if (IS_STRUCT_TYPE(tp)) {
TYPE_BASIC_TYPE(tq) = TYPE_STRUCT;
} else {
TYPE_BASIC_TYPE(tq) = TYPE_BASIC_TYPE(tp);
TYPE_CHAR_LEN(tq) = TYPE_CHAR_LEN(tp);
TYPE_KIND(tq) = TYPE_KIND(tp);
if (TYPE_IS_IMPLICIT(tp))
TYPE_SET_IMPLICIT(tq);
}
return tq;
}
static void sym_initg(Symbol sym, int tkind, int r1, int r2) /*;sym_initg*/
{
/* initialize the fields of a symbol used only by the code generator */
if (tkind<=0) { /* if want to indicate type_size not defined */
TYPE_SIZE(sym) = -1;
}
else {
TYPE_KIND(sym) = tkind; /* type kind */
TYPE_SIZE(sym) = su_size(tkind); /* storage units needed*/
}
S_SEGMENT(sym) = r1;
S_OFFSET(sym) = r2;
/* Note that the correct values of offsets for most of the standard
* symbols are set by procedure main_data_segment() in glib.c
*/
/* The following default value of MISC (happily) also corresponds to
* setting CONTAINS_TASK(sym) to FALSE.
*/
MISC(sym) = (char *) 0;
}
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;
}
