int OMP_output_st_pragma(expv v)
{
switch(OMP_st_flag){
case OMP_ST_ATOMIC:
output_statement(OMP_pragma_list(OMP_ATOMIC, list0(LIST),
list1(EXPR_STATEMENT, v)));
return TRUE;
default:
return FALSE;
}
}
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;
}
expv
compile_intrinsic_call(ID id, expv args) {
intrinsic_entry *ep = NULL;
int found = 0;
int nArgs = 0;
int nIntrArgs = 0;
int i;
expv ret = NULL;
expv a = NULL;
TYPE_DESC tp = NULL, ftp;
list lp;
INTR_OPS iOps = INTR_END;
const char *iName = NULL;
expv kindV = NULL;
int typeNotMatch = 0;
int isVarArgs = 0;
EXT_ID extid;
if (SYM_TYPE(ID_SYM(id)) != S_INTR) {
//fatal("%s: not intrinsic symbol", __func__);
// declarea as intrinsic but not defined in the intrinc table
SYM_TYPE(ID_SYM(id)) = S_INTR;
if (args == NULL) {
args = list0(LIST);
}
if (ID_TYPE(id) == NULL) implicit_declaration(id);
tp = ID_TYPE(id);
//tp = BASIC_TYPE_DESC(TYPE_SUBR);
expv symV = expv_sym_term(F_FUNC, NULL, ID_SYM(id));
ftp = function_type(tp);
TYPE_SET_INTRINSIC(ftp);
extid = new_external_id_for_external_decl(ID_SYM(id), ftp);
ID_TYPE(id) = ftp;
PROC_EXT_ID(id) = extid;
if (TYPE_IS_EXTERNAL(tp)){
ID_STORAGE(id) = STG_EXT;
}
else{
EXT_PROC_CLASS(extid) = EP_INTRINSIC;
}
ret = expv_cons(FUNCTION_CALL, tp, symV, args);
return ret;
}
ep = &(intrinsic_table[SYM_VAL(ID_SYM(id))]);
iOps = INTR_OP(ep);
iName = ID_NAME(id);
/* Count a number of argument, first. */
nArgs = 0;
if (args == NULL) {
args = list0(LIST);
}
FOR_ITEMS_IN_LIST(lp, args) {
nArgs++;
}
/* Search an intrinsic by checking argument types. */
found = 0;
for (;
((INTR_OP(ep) == iOps) &&
((strcasecmp(iName, INTR_NAME(ep)) == 0) ||
!(isValidString(INTR_NAME(ep)))));
ep++) {
kindV = NULL;
typeNotMatch = 0;
isVarArgs = 0;
/* Check a number of arguments. */
if (INTR_N_ARGS(ep) < 0 ||
INTR_N_ARGS(ep) == nArgs) {
/* varriable args or no kind arg. */
if (INTR_N_ARGS(ep) < 0) {
isVarArgs = 1;
}
nIntrArgs = nArgs;
} else if (INTR_HAS_KIND_ARG(ep) &&
((INTR_N_ARGS(ep) + 1) == nArgs)) {
/* could be intrinsic call with kind arg. */
expv lastV = expr_list_get_n(args, nArgs - 1);
if (lastV == NULL) {
return NULL; /* error recovery */
}
if (EXPV_KW_IS_KIND(lastV)) {
goto gotKind;
}
tp = EXPV_TYPE(lastV);
if (!(isValidType(tp))) {
return NULL; /* error recovery */
}
if (TYPE_BASIC_TYPE(tp) != TYPE_INT) {
/* kind arg must be integer type. */
continue;
}
gotKind:
nIntrArgs = INTR_N_ARGS(ep);
kindV = lastV;
} else {
continue;
}
/* The number of arguments matchs. Then check types. */
for (i = 0; i < nIntrArgs; i++) {
a = expr_list_get_n(args, i);
if (a == NULL) {
return NULL; /* error recovery */
}
tp = EXPV_TYPE(a);
if (!(isValidType(tp))) {
//return NULL; /* error recovery */
continue;
}
if (compare_intrinsic_arg_type(a, tp,
((isVarArgs == 0) ?
INTR_ARG_TYPE(ep)[i] :
INTR_ARG_TYPE(ep)[0])) != 0) {
/* Type mismatch. */
typeNotMatch = 1;
break;
}
}
if (typeNotMatch == 1) {
continue;
} else {
found = 1;
break;
}
}
if (found == 1) {
/* Yes we found an intrinsic to use. */
SYMBOL sp = NULL;
expv symV = NULL;
/* Then we have to determine return type. */
if (INTR_RETURN_TYPE(ep) != INTR_TYPE_NONE) {
tp = get_intrinsic_return_type(ep, args, kindV);
if (!(isValidType(tp))) {
//fatal("%s: can't determine return type.", __func__);
//return NULL;
tp = BASIC_TYPE_DESC(TYPE_GNUMERIC_ALL);
}
} else {
tp = BASIC_TYPE_DESC(TYPE_SUBR);
}
/* Finally find symbol for the intrinsic and make it expv. */
sp = find_symbol((char *)iName);
if (sp == NULL) {
fatal("%s: symbol '%s' is not created??",
__func__,
INTR_NAME(ep));
/* not reached */
return NULL;
}
symV = expv_sym_term(F_FUNC, NULL, sp);
if (symV == NULL) {
fatal("%s: symbol expv creation failure.", __func__);
/* not reached */
return NULL;
}
ftp = function_type(tp);
TYPE_SET_INTRINSIC(ftp);
/* set external id for functionType's type ID.
* dont call declare_external_id() */
extid = new_external_id_for_external_decl(ID_SYM(id), ftp);
ID_TYPE(id) = ftp;
PROC_EXT_ID(id) = extid;
if(TYPE_IS_EXTERNAL(tp)){
ID_STORAGE(id) = STG_EXT;
}else{
EXT_PROC_CLASS(extid) = EP_INTRINSIC;
}
ret = expv_cons(FUNCTION_CALL, tp, symV, args);
}
if (ret == NULL) {
error_at_node((expr)args,
"argument(s) mismatch for an intrinsic '%s()'.",
iName);
}
return ret;
}
void make_target_parser(
tgt::parsing_table& table,
std::map<std::string, size_t>& token_id_map,
action_map_type& actions,
const value_type& ast,
std::map<std::string, Type>& terminal_types,
std::map<std::string, Type>& nonterminal_types) {
auto doc = get_node<Document>(ast);
// 各種データ
// ...終端記号表(名前→terminal)
std::unordered_map<std::string, tgt::terminal> terminals;
// ...非終端記号表(名前→nonterminal)
std::unordered_map<std::string, tgt::nonterminal> nonterminals;
int error_token = -1;
// terminalsの作成
token_id_map["eof"] = 0;
int id_seed = 1;
for (const auto& x: terminal_types) {
if (x.second.name != "$error") { continue; }
token_id_map[x.first] = error_token = id_seed;
terminals[x.first] = tgt::terminal(x.first, id_seed++);
}
for (const auto& x: terminal_types) {
if (x.second.name == "$error") { continue; }
token_id_map[x.first] = id_seed;
terminals[x.first] = tgt::terminal(x.first, id_seed++);
}
// nonterminalsの作成
for (const auto& x: nonterminal_types) {
nonterminals[x.first] = tgt::nonterminal(x.first);
}
// pending(あとでまとめてEBNFを展開したルールを作成する
std::vector<Pending> pending;
// 規則
tgt::grammar g;
for (const auto& rule: doc->rules->rules) {
const tgt::nonterminal& rule_left = nonterminals[rule->name];
if (g.size() == 0) {
g << (tgt::rule(tgt::nonterminal("$implicit_root")) << rule_left);
}
for (const auto& choise: rule->choises->choises) {
make_target_rule(
actions,
g,
rule_left,
choise,
terminal_types,
nonterminal_types,
terminals,
nonterminals,
pending);
}
}
for (const auto& p: pending) {
tgt::nonterminal name(p.extended_name);
nonterminals[p.extended_name] = name;
nonterminal_types[p.extended_name] =
Type{p.source_name, p.extension};
if (p.extension == Extension::Question) {
tgt::rule list0(name);
tgt::rule list1(name); list1 << p.element;
g << list0;
g << list1;
actions[list0] = SemanticAction { "opt_nothing", true };
actions[list1] = SemanticAction { "opt_just", true };
} else if (p.extension == Extension::Slash) {
assert(!p.skip.is_epsilon());
tgt::rule list0(name); list0 << p.element;
tgt::rule list1(name); list1 << name << p.skip << p.element;
g << list0;
g << list1;
actions[list0] = SemanticAction { "seq_head", true };
actions[list1] = SemanticAction { "seq_trail2", true };
} else {
tgt::rule list0(name);
if (p.extension == Extension::Plus) {
list0 << p.element;
}
tgt::rule list1(name); list1 << name << p.element;
g << list0;
g << list1;
actions[list0] = SemanticAction { "seq_head", true };
actions[list1] = SemanticAction { "seq_trail", true };
}
}
zw::gr::make_lalr_table(
table,
g,
error_token,
sr_conflict_reporter(),
rr_conflict_reporter());
}
