/* Compare type to descriptor type at
* offset position in format_list
*/
bool ofc_sema_io_compare_types(
const ofc_sema_stmt_t* stmt,
const ofc_sema_lhs_t* lhs,
ofc_sema_expr_t** expr,
const ofc_sema_type_t* type,
ofc_parse_format_desc_t* desc)
{
if (!type || !desc || (!lhs && !expr))
return false;
if (!ofc_sema_compare_desc_expr_type(desc->type, type->type))
{
if (!expr)
{
ofc_sparse_ref_warning(lhs->src,
"Trying to format a %s output with a %s FORMAT descriptor",
ofc_sema_format_str_rep(desc->type),
ofc_sema_type_str_rep(type));
}
else
{
const ofc_sema_type_t* dtype
= ofc_sema_format_desc_type(desc);
ofc_sema_expr_t* cast
= ofc_sema_expr_cast(*expr, dtype);
if (!cast)
{
ofc_sparse_ref_warning((*expr)->src,
"Trying to format a %s output with a %s FORMAT descriptor",
ofc_sema_format_str_rep(desc->type),
ofc_sema_type_str_rep(type));
}
else
{
*expr = cast;
}
}
}
else if (desc->type == OFC_PARSE_FORMAT_DESC_CHARACTER)
{
unsigned csize;
if (!ofc_sema_type_base_size(type, &csize)
|| (csize != 1))
{
ofc_sparse_ref_t src = (lhs ? lhs->src : (*expr)->src);
ofc_sparse_ref_error(src,
"CHARACTER type KIND not supported in %s",
(stmt->type == OFC_SEMA_STMT_IO_WRITE ? "WRITE" : "PRINT"));
}
}
return true;
}
static bool ofc_sema_stmt__loop_control(
ofc_sema_scope_t* scope,
const ofc_parse_assign_t* parse_init,
const ofc_parse_expr_t* parse_last,
const ofc_parse_expr_t* parse_step,
ofc_sema_lhs_t** sema_iter,
ofc_sema_expr_t** sema_init,
ofc_sema_expr_t** sema_last,
ofc_sema_expr_t** sema_step)
{
*sema_iter = ofc_sema_lhs(
scope, parse_init->name);
if (!*sema_iter) return false;
const ofc_sema_type_t* dtype
= ofc_sema_lhs_type(*sema_iter);
if (!ofc_sema_type_is_scalar(dtype))
{
ofc_sparse_ref_error(parse_init->name->src,
"DO loop iterator must be a scalar type.");
ofc_sema_lhs_delete(*sema_iter);
return false;
}
if (!ofc_sema_type_is_integer(dtype))
{
ofc_sparse_ref_warning(parse_init->name->src,
"Using REAL in DO loop iterator.");
}
*sema_init = ofc_sema_expr(
scope, parse_init->init);
if (!*sema_init)
{
ofc_sema_lhs_delete(*sema_iter);
return false;
}
if (!ofc_sema_type_compatible(dtype,
ofc_sema_expr_type(*sema_init)))
{
ofc_sema_expr_t* cast
= ofc_sema_expr_cast(*sema_init, dtype);
if (!cast)
{
const ofc_sema_type_t* expr_type
= ofc_sema_expr_type(*sema_init);
ofc_sparse_ref_error(parse_init->init->src,
"Expression type %s doesn't match lhs type %s",
ofc_sema_type_str_rep(expr_type),
ofc_sema_type_str_rep(dtype));
ofc_sema_expr_delete(*sema_init);
ofc_sema_lhs_delete(*sema_iter);
return false;
}
*sema_init = cast;
}
*sema_last = ofc_sema_expr(
scope, parse_last);
if (!*sema_last)
{
ofc_sema_expr_delete(*sema_init);
ofc_sema_lhs_delete(*sema_iter);
return false;
}
if (!ofc_sema_type_compatible(dtype,
ofc_sema_expr_type(*sema_last)))
{
ofc_sema_expr_t* cast
= ofc_sema_expr_cast(*sema_last, dtype);
if (!cast)
{
const ofc_sema_type_t* expr_type =
ofc_sema_expr_type(*sema_last);
ofc_sparse_ref_error(parse_last->src,
"Expression type %s doesn't match lhs type %s",
ofc_sema_type_str_rep(expr_type),
ofc_sema_type_str_rep(dtype));
ofc_sema_expr_delete(*sema_init);
ofc_sema_expr_delete(*sema_last);
ofc_sema_lhs_delete(*sema_iter);
return false;
}
*sema_last = cast;
}
*sema_step = NULL;
if (parse_step)
{
*sema_step = ofc_sema_expr(
scope, parse_step);
if (!*sema_step)
{
ofc_sema_expr_delete(*sema_init);
ofc_sema_expr_delete(*sema_last);
ofc_sema_lhs_delete(*sema_iter);
return false;
}
if (!ofc_sema_type_compatible(dtype,
ofc_sema_expr_type(*sema_step)))
{
ofc_sema_expr_t* cast
= ofc_sema_expr_cast(*sema_step, dtype);
if (!cast)
{
const ofc_sema_type_t* expr_type =
ofc_sema_expr_type(*sema_step);
ofc_sparse_ref_error(parse_step->src,
"Expression type %s doesn't match lhs type %s",
ofc_sema_type_str_rep(expr_type),
ofc_sema_type_str_rep(dtype));
ofc_sema_expr_delete(*sema_step);
ofc_sema_expr_delete(*sema_init);
ofc_sema_expr_delete(*sema_last);
ofc_sema_lhs_delete(*sema_iter);
return false;
}
*sema_step = cast;
}
}
return true;
}
static ofc_sema_lhs_t* ofc_sema_lhs__implicit_do(
ofc_sema_scope_t* scope,
ofc_sparse_ref_t src,
const ofc_parse_lhs_implicit_do_t* id)
{
if (!id || !id->init)
return NULL;
ofc_sema_lhs_t* lhs
= (ofc_sema_lhs_t*)malloc(
sizeof(ofc_sema_lhs_t));
if (!lhs) return NULL;
lhs->type = OFC_SEMA_LHS_IMPLICIT_DO;
lhs->src = src;
lhs->implicit_do.lhs = NULL;
lhs->implicit_do.iter = NULL;
lhs->implicit_do.init = NULL;
lhs->implicit_do.last = NULL;
lhs->implicit_do.step = NULL;
lhs->implicit_do.count_var = true;
lhs->implicit_do.count = 0;
lhs->data_type = NULL;
lhs->refcnt = 0;
ofc_sema_lhs_t* iter_lhs = ofc_sema_lhs_from_expr(
scope, id->iter);
if (!iter_lhs)
{
ofc_sema_lhs_delete(lhs);
return NULL;
}
if (!ofc_sema_lhs_mark_used(
iter_lhs, true, true))
{
ofc_sema_lhs_delete(iter_lhs);
ofc_sema_lhs_delete(lhs);
return NULL;
}
if (iter_lhs->type != OFC_SEMA_LHS_DECL)
{
ofc_sparse_ref_error(id->iter->src,
"Implicit do loop iterator must be a variable");
ofc_sema_lhs_delete(iter_lhs);
ofc_sema_lhs_delete(lhs);
return NULL;
}
if (!ofc_sema_decl_reference(iter_lhs->decl))
{
ofc_sema_lhs_delete(iter_lhs);
ofc_sema_lhs_delete(lhs);
return NULL;
}
lhs->implicit_do.iter = iter_lhs->decl;
ofc_sema_lhs_delete(iter_lhs);
const ofc_sema_type_t* iter_type
= ofc_sema_decl_type(lhs->implicit_do.iter);
if (!iter_type)
{
ofc_sema_lhs_delete(lhs);
return NULL;
}
if (!ofc_sema_type_is_scalar(iter_type))
{
ofc_sparse_ref_error(id->iter->src,
"Implicit do loop iterator must be a scalar type");
ofc_sema_lhs_delete(lhs);
return NULL;
}
if (!ofc_sema_type_is_integer(iter_type))
{
ofc_sparse_ref_warning(id->iter->src,
"Using REAL in implicit do loop iterator");
}
lhs->implicit_do.init = ofc_sema_expr(
scope, id->init);
if (!lhs->implicit_do.init)
{
ofc_sema_lhs_delete(lhs);
return NULL;
}
const ofc_sema_type_t* init_type
= ofc_sema_expr_type(lhs->implicit_do.init);
if (!init_type)
{
ofc_sema_lhs_delete(lhs);
return NULL;
}
else if (!ofc_sema_type_compatible(
iter_type, init_type))
{
ofc_sema_expr_t* cast
= ofc_sema_expr_cast(
lhs->implicit_do.init, iter_type);
if (!cast)
{
ofc_sema_lhs_delete(lhs);
return NULL;
}
lhs->implicit_do.init = cast;
}
lhs->implicit_do.last = ofc_sema_expr(
scope, id->limit);
if (!lhs->implicit_do.last)
{
ofc_sema_lhs_delete(lhs);
return NULL;
}
const ofc_sema_type_t* last_type
= ofc_sema_expr_type(lhs->implicit_do.last);
if (!last_type)
{
ofc_sema_lhs_delete(lhs);
return NULL;
}
else if (!ofc_sema_type_compatible(
iter_type, last_type))
{
ofc_sema_expr_t* cast
= ofc_sema_expr_cast(
lhs->implicit_do.last, iter_type);
if (!cast)
{
ofc_sparse_ref_error(id->limit->src,
"Expression type '%s' doesn't match iterator type '%s'",
ofc_sema_type_str_rep(last_type),
ofc_sema_type_str_rep(iter_type));
ofc_sema_lhs_delete(lhs);
return NULL;
}
lhs->implicit_do.last = cast;
}
if (id->step)
{
lhs->implicit_do.step
= ofc_sema_expr(scope, id->step);
if (!lhs->implicit_do.step)
{
ofc_sema_lhs_delete(lhs);
return NULL;
}
const ofc_sema_type_t* step_type
= ofc_sema_expr_type(lhs->implicit_do.step);
if (!step_type)
{
ofc_sema_lhs_delete(lhs);
return NULL;
}
else if (!ofc_sema_type_compatible(
iter_type, step_type))
{
ofc_sema_expr_t* cast
= ofc_sema_expr_cast(
lhs->implicit_do.step, iter_type);
if (!cast)
{
ofc_sparse_ref_error(id->step->src,
"Expression type '%s' doesn't match iterator type '%s'",
ofc_sema_type_str_rep(step_type),
ofc_sema_type_str_rep(iter_type));
ofc_sema_lhs_delete(lhs);
return NULL;
}
lhs->implicit_do.step = cast;
}
}
if (id->dlist && (id->dlist->count > 0))
{
lhs->implicit_do.lhs
= ofc_sema_lhs_list_id(scope, id->dlist);
if (!lhs->implicit_do.lhs)
{
ofc_sema_lhs_delete(lhs);
return NULL;
}
}
else
{
ofc_sema_lhs_delete(lhs);
return NULL;
}
const ofc_sema_typeval_t* ctv[3];
ctv[0] = ofc_sema_expr_constant(
lhs->implicit_do.init);
ctv[1] = ofc_sema_expr_constant(
lhs->implicit_do.last);
ctv[2] = ofc_sema_expr_constant(
lhs->implicit_do.step);
long double first, last, step = 1.0;
if (ofc_sema_typeval_get_real(ctv[0], &first)
&& ofc_sema_typeval_get_real(ctv[1], &last)
&& (!ctv[2] || ofc_sema_typeval_get_real(ctv[2], &step)))
{
long double dcount = floor((last - first) / step);
if (dcount < 0.0)
{
ofc_sparse_ref_error(src,
"Loop iterates away from limit");
ofc_sema_lhs_delete(lhs);
return NULL;
}
dcount += 1.0;
lhs->implicit_do.count = (unsigned)dcount;
if ((long double)lhs->implicit_do.count != dcount)
{
ofc_sema_lhs_delete(lhs);
return NULL;
}
lhs->implicit_do.count_var = false;
}
else
{
lhs->implicit_do.count_var = true;
lhs->implicit_do.count = 0;
}
return lhs;
}
