static ofc_sema_stmt_t* ofc_sema_stmt_do_while__label(
ofc_sema_scope_t* scope,
const ofc_parse_stmt_t* stmt)
{
if (!stmt
|| (stmt->type != OFC_PARSE_STMT_DO_WHILE)
|| !stmt->do_while_block.cond)
return NULL;
ofc_sema_stmt_t s;
s.type = OFC_SEMA_STMT_DO_WHILE;
s.do_while.end_label = ofc_sema_expr(
scope, stmt->do_while.end_label);
if (!s.do_while.end_label)
return NULL;
s.do_while.cond = ofc_sema_expr(
scope, stmt->do_while.cond);
if (!s.do_while.cond)
return NULL;
const ofc_sema_type_t* type
= ofc_sema_expr_type(s.do_while.cond);
if (!ofc_sema_type_is_logical(type))
{
ofc_sparse_ref_error(stmt->do_while.cond->src,
"IF condition type must be LOGICAL.");
ofc_sema_expr_delete(s.do_while.cond);
return NULL;
}
ofc_sema_stmt_t* as = ofc_sema_stmt_alloc(s);
if (!as)
{
ofc_sema_expr_delete(s.do_while.cond);
return NULL;
}
return as;
}
ofc_sema_stmt_t* ofc_sema_stmt_io_read(
ofc_sema_scope_t* scope,
const ofc_parse_stmt_t* stmt)
{
if (!scope || !stmt
|| (stmt->type != OFC_PARSE_STMT_IO_READ)
|| !stmt->io_read.params)
return NULL;
ofc_sema_stmt_t s;
s.type = OFC_SEMA_STMT_IO_READ;
s.io_read.unit = NULL;
s.io_read.stdin = false;
s.io_read.format = NULL;
s.io_read.format_ldio = false;
s.io_read.formatted = false;
s.io_read.iostat = NULL;
s.io_read.rec = NULL;
s.io_read.err = NULL;
s.io_read.iolist = NULL;
s.io_read.advance = NULL;
s.io_read.end = NULL;
s.io_read.eor = NULL;
s.io_read.size = NULL;
ofc_parse_call_arg_t* ca_unit = NULL;
ofc_parse_call_arg_t* ca_format = NULL;
ofc_parse_call_arg_t* ca_iostat = NULL;
ofc_parse_call_arg_t* ca_rec = NULL;
ofc_parse_call_arg_t* ca_err = NULL;
ofc_parse_call_arg_t* ca_advance = NULL;
ofc_parse_call_arg_t* ca_end = NULL;
ofc_parse_call_arg_t* ca_eor = NULL;
ofc_parse_call_arg_t* ca_size = NULL;
if (stmt->io_read.has_brakets)
{
unsigned i;
for (i = 0; i < stmt->io_read.params->count; i++)
{
ofc_parse_call_arg_t* param
= stmt->io_read.params->call_arg[i];
if (!param) continue;
if (ofc_sparse_ref_empty(param->name))
{
if (i >= 2)
{
ofc_sparse_ref_error(param->src,
"Un-named parameter %u has no meaning in READ.", i);
return NULL;
}
if (i == 0)
{
ca_unit = param;
}
else
{
if (!ca_unit)
{
ofc_sparse_ref_error(param->src,
"Un-named format parameter only valid after UNIT in READ.");
return NULL;
}
ca_format = param;
}
}
else if (ofc_str_ref_equal_strz_ci(param->name.string, "UNIT"))
{
if (ca_unit)
{
ofc_sparse_ref_error(param->src,
"Re-definition of UNIT in READ.");
return NULL;
}
ca_unit = param;
}
else if (ofc_str_ref_equal_strz_ci(param->name.string, "FMT"))
{
if (ca_format)
{
ofc_sparse_ref_error(param->src,
"Re-definition of FMT in READ.");
return NULL;
}
ca_format = param;
}
else if (ofc_str_ref_equal_strz_ci(param->name.string, "IOSTAT"))
{
if (ca_iostat)
{
ofc_sparse_ref_error(param->src,
"Re-definition of IOSTAT in READ.");
return NULL;
}
ca_iostat = param;
}
else if (ofc_str_ref_equal_strz_ci(param->name.string, "REC"))
{
if (ca_rec)
{
ofc_sparse_ref_error(param->src,
"Re-definition of REC in READ.");
return NULL;
}
ca_rec = param;
}
else if (ofc_str_ref_equal_strz_ci(param->name.string, "ERR"))
{
if (ca_err)
{
ofc_sparse_ref_error(param->src,
"Re-definition of ERR in READ.");
return NULL;
}
ca_err = param;
}
else if (ofc_str_ref_equal_strz_ci(param->name.string, "ADVANCE"))
{
if (ca_advance)
{
ofc_sparse_ref_error(param->src,
"Re-definition of ADVANCE in READ.");
return NULL;
}
ca_advance = param;
}
else if (ofc_str_ref_equal_strz_ci(param->name.string, "END"))
{
if (ca_end)
{
ofc_sparse_ref_error(param->src,
"Re-definition of END in READ.");
return NULL;
}
ca_end = param;
}
else if (ofc_str_ref_equal_strz_ci(param->name.string, "SIZE"))
{
if (ca_size)
{
ofc_sparse_ref_error(param->src,
"Re-definition of SIZE in READ.");
return NULL;
}
ca_size = param;
}
else
{
ofc_sparse_ref_error(param->src,
"Unrecognized paramater %u name '%.*s' in READ.",
i, param->name.string.size, param->name.string.base);
return NULL;
}
}
if (!ca_unit)
{
ofc_sparse_ref_error(stmt->src,
"No UNIT defined in READ.");
return NULL;
}
}
else
{
ca_format = stmt->io_read.params->call_arg[0];
}
if (ca_unit && (ca_unit->type == OFC_PARSE_CALL_ARG_ASTERISK))
{
s.io_read.stdin = true;
}
else if (ca_unit && (ca_unit->type == OFC_PARSE_CALL_ARG_EXPR))
{
s.io_read.unit = ofc_sema_expr(
scope, ca_unit->expr);
if (!s.io_read.unit) return NULL;
const ofc_sema_type_t* etype
= ofc_sema_expr_type(s.io_read.unit);
if (!etype)
{
ofc_sema_stmt_io_read__cleanup(s);
return NULL;
}
if (!ofc_sema_type_is_character(etype)
&& (!ofc_sema_type_is_integer(etype)
|| !ofc_sema_expr_validate_uint(s.io_read.unit)))
{
ofc_sparse_ref_error(stmt->src,
"UNIT must be a positive INTEGER "
"or a CHARACTER expression in READ");
ofc_sema_stmt_io_read__cleanup(s);
return NULL;
}
}
else if (ca_unit)
{
ofc_sparse_ref_error(stmt->src,
"UNIT must be an INTEGER or CHARACTER "
"expression, or asterisk in READ");
return NULL;
}
else
{
s.io_read.stdin = true;
}
if (ca_format && (ca_format->type == OFC_PARSE_CALL_ARG_ASTERISK))
{
s.io_read.format_ldio = true;
s.io_read.formatted = true;
}
else if (ca_format && (ca_format->type == OFC_PARSE_CALL_ARG_EXPR))
{
s.io_read.formatted = true;
s.io_read.format = ofc_sema_expr(
scope, ca_format->expr);
if (!s.io_read.format)
{
ofc_sema_stmt_io_read__cleanup(s);
return NULL;
}
const ofc_sema_type_t* etype
= ofc_sema_expr_type(s.io_read.format);
if (!etype)
{
ofc_sema_stmt_io_read__cleanup(s);
return NULL;
}
if (ofc_sema_type_is_integer(etype))
{
s.io_read.format->is_label = true;
s.io_read.format->is_format = true;
}
else if (etype->type != OFC_SEMA_TYPE_CHARACTER)
{
/* TODO - Support INTEGER array formats. */
ofc_sparse_ref_error(stmt->src,
"Format (FMT) must be a label or character string in READ");
ofc_sema_stmt_io_read__cleanup(s);
return NULL;
}
}
else if (ca_format)
{
ofc_sparse_ref_error(stmt->src,
"Format (FMT) must be an INTEGER expression or asterisk in READ");
ofc_sema_stmt_io_read__cleanup(s);
return NULL;
}
bool is_nonadvance = false;
if (ca_advance && s.io_read.stdin)
{
ofc_sparse_ref_error(stmt->src,
"ADVANCE specifier can only be used with an external UNIT in READ");
ofc_sema_stmt_io_read__cleanup(s);
return NULL;
}
else if (ca_advance && (!ca_format || s.io_read.format_ldio))
{
ofc_sparse_ref_error(stmt->src,
"ADVANCE specifier can only be used with a formatted input in READ");
ofc_sema_stmt_io_read__cleanup(s);
return NULL;
}
else if (ca_advance)
{
s.io_read.advance = ofc_sema_expr(
scope, ca_advance->expr);
if (!s.io_read.advance)
{
ofc_sema_stmt_io_read__cleanup(s);
return NULL;
}
const ofc_sema_type_t* etype
= ofc_sema_expr_type(s.io_read.advance);
if (!etype)
{
ofc_sema_stmt_io_read__cleanup(s);
return NULL;
}
if (etype->type != OFC_SEMA_TYPE_CHARACTER)
{
ofc_sparse_ref_error(stmt->src,
"ADVANCE must be a CHARACTER expression in READ");
ofc_sema_stmt_io_read__cleanup(s);
return NULL;
}
else
{
const ofc_sema_typeval_t* constant
= ofc_sema_expr_constant(s.io_read.advance);
is_nonadvance = (constant
&& ofc_typeval_character_equal_strz_ci(constant, "NO"));
if (constant && !is_nonadvance
&& !ofc_typeval_character_equal_strz_ci(constant, "YES"))
{
ofc_sparse_ref_error(stmt->src,
"ADVANCE must be YES/NO in WRITE");
ofc_sema_stmt_io_read__cleanup(s);
return NULL;
}
}
}
if (ca_end)
{
s.io_read.end = ofc_sema_expr_label(
scope, ca_end->expr);
if (!s.io_read.end)
{
ofc_sema_stmt_io_read__cleanup(s);
return NULL;
}
}
if (ca_eor)
{
s.io_read.eor = ofc_sema_expr_label(
scope, ca_eor->expr);
if (!s.io_read.eor)
{
ofc_sema_stmt_io_read__cleanup(s);
return NULL;
}
}
if (ca_err)
{
s.io_read.err = ofc_sema_expr_label(
scope, ca_err->expr);
if (!s.io_read.err)
{
ofc_sema_stmt_io_read__cleanup(s);
return NULL;
}
}
if (ca_iostat)
{
s.io_read.iostat = ofc_sema_expr(
scope, ca_iostat->expr);
if (!s.io_read.iostat)
{
ofc_sema_stmt_io_read__cleanup(s);
return NULL;
}
if (s.io_read.iostat->type != OFC_SEMA_EXPR_LHS)
{
ofc_sparse_ref_error(stmt->src,
"IOSTAT must be a variable in READ");
ofc_sema_stmt_io_read__cleanup(s);
return NULL;
}
const ofc_sema_type_t* etype
= ofc_sema_expr_type(s.io_read.iostat);
if (!etype)
{
ofc_sema_stmt_io_read__cleanup(s);
return NULL;
}
if (!ofc_sema_type_is_integer(etype))
{
ofc_sparse_ref_error(stmt->src,
"IOSTAT must be of type INTEGER in READ");
ofc_sema_stmt_io_read__cleanup(s);
return NULL;
}
}
if (ca_rec && (s.io_read.format_ldio || ca_end))
{
ofc_sparse_ref_error(stmt->src,
"REC specifier not compatible with END,"
" NML or list-directed data transfer in READ");
ofc_sema_stmt_io_read__cleanup(s);
return NULL;
}
else if (ca_rec)
{
s.io_read.rec = ofc_sema_expr(
scope, ca_rec->expr);
if (!s.io_read.rec)
{
ofc_sema_stmt_io_read__cleanup(s);
return NULL;
}
const ofc_sema_type_t* etype
= ofc_sema_expr_type(s.io_read.rec);
if (!etype)
{
ofc_sema_stmt_io_read__cleanup(s);
return NULL;
}
if (!ofc_sema_type_is_integer(etype))
{
ofc_sparse_ref_error(stmt->src,
"REC must be of type INTEGER in READ");
ofc_sema_stmt_io_read__cleanup(s);
return NULL;
}
}
if (ca_size && !is_nonadvance)
{
ofc_sparse_ref_error(stmt->src,
"SIZE not compatible with advancing formatted "
"sequential data transfer in READ");
ofc_sema_stmt_io_read__cleanup(s);
return NULL;
}
else if (ca_size)
{
if (s.io_read.size->type != OFC_SEMA_EXPR_LHS)
{
ofc_sparse_ref_error(stmt->src,
"SIZE must be a variable in READ");
ofc_sema_stmt_io_read__cleanup(s);
return NULL;
}
/* TODO - The variable specified in SIZE must
not be the same as or associated with any
entity in the input/output item list or in
the namelist group or with the variable
specified in the IOSTAT= specifier */
const ofc_sema_type_t* etype
= ofc_sema_expr_type(s.io_read.size);
if (!etype)
{
ofc_sema_stmt_io_read__cleanup(s);
return NULL;
}
if (!ofc_sema_type_is_integer(etype))
{
ofc_sparse_ref_error(stmt->src,
"SIZE must be of type INTEGER in READ");
ofc_sema_stmt_io_read__cleanup(s);
return NULL;
}
}
/* Check iolist */
if (stmt->io_read.iolist)
{
s.io_read.iolist
= ofc_sema_lhs_list_id(
scope, stmt->io_read.iolist);
if (!s.io_read.iolist
|| !ofc_sema_lhs_list_mark_used(
s.io_read.iolist, true, false))
{
ofc_sema_stmt_io_read__cleanup(s);
return NULL;
}
}
ofc_sema_stmt_t* as
= ofc_sema_stmt_alloc(s);
if (!as)
{
ofc_sema_stmt_io_read__cleanup(s);
return NULL;
}
return as;
}
bool ofc_sema_io_list_has_complex(
ofc_sema_lhs_list_t* ilist,
ofc_sema_expr_list_t* olist,
unsigned* count)
{
if (!count) return false;
if (ilist)
{
unsigned i;
for (i = 0; i < ilist->count; i++)
{
ofc_sema_lhs_t* lhs
= ofc_sema_lhs_list_elem_get(ilist, i);
const ofc_sema_type_t* type
= ofc_sema_lhs_type(lhs);
ofc_sema_lhs_delete(lhs);
if (!type) return false;
if (ofc_sema_type_is_complex(type))
{
unsigned elem_count;
if (!ofc_sema_lhs_elem_count(
ilist->lhs[i], &elem_count))
return false;
*count += elem_count;
}
}
}
else if (olist)
{
unsigned i;
for (i = 0; i < olist->count; i++)
{
ofc_sema_expr_t* expr
= ofc_sema_expr_list_elem_get(olist, i);
const ofc_sema_type_t* type
= ofc_sema_expr_type(expr);
ofc_sema_expr_delete(expr);
if (!type) return false;
if (ofc_sema_type_is_complex(type))
{
unsigned elem_count;
if (!ofc_sema_expr_elem_count(
olist->expr[i], &elem_count))
return false;
*count += elem_count;
}
}
}
else
{
return false;
}
return true;
}
bool ofc_sema_io_format_iolist_compare(
const ofc_sema_stmt_t* stmt,
const ofc_parse_format_desc_list_t* format_list,
ofc_sema_expr_list_t* iolist)
{
if (!format_list || !iolist) return false;
/* This is to handle "forced reversion"
http://www.obliquity.com/computer/fortran/format.html */
unsigned repeat_from = 0;
unsigned offset = 0;
unsigned i, elem_count;
for (i = 0; i < format_list->count; i++)
{
if (format_list->desc[i]->type
== OFC_PARSE_FORMAT_DESC_REPEAT)
repeat_from = offset;
if (!ofc_parse_format_desc_elem_count(
format_list->desc[i], &elem_count))
return false;
offset += elem_count;
}
unsigned count;
if (!ofc_parse_format_desc_list_elem_count(
format_list, &count))
return false;
offset = 0;
for (i = 0; i < iolist->count; i++)
{
if (offset >= count)
offset = repeat_from;
ofc_sema_expr_t* pexpr
= ofc_sema_expr_list_elem_get(iolist, i);
const ofc_sema_type_t* type
= ofc_sema_expr_type(pexpr);
if (ofc_sema_type_is_complex(type))
{
unsigned j;
for (j = 0; j < 2; j++)
{
/* Find the next data descriptor */
ofc_parse_format_desc_t* desc;
while (true)
{
if (offset >= count)
offset = repeat_from;
desc = ofc_parse_format_desc_list_elem_get(
format_list, offset++);
if (!desc)
{
ofc_sema_expr_delete(pexpr);
return false;
}
if (ofc_parse_format_is_data_desc(desc))
break;
ofc_parse_format_desc_delete(desc);
}
if (!ofc_sema_io_compare_types(
stmt, NULL, &pexpr, type, desc))
{
ofc_sema_expr_delete(pexpr);
ofc_parse_format_desc_delete(desc);
return false;
}
ofc_parse_format_desc_delete(desc);
}
ofc_sema_expr_delete(pexpr);
continue;
}
/* Find the next data descriptor */
ofc_parse_format_desc_t* desc;
while (true)
{
if (offset >= count)
offset = repeat_from;
desc = ofc_parse_format_desc_list_elem_get(
format_list, offset++);
if (ofc_parse_format_is_data_desc(desc))
break;
ofc_parse_format_desc_delete(desc);
}
if (!ofc_sema_io_compare_types(
stmt, NULL, &pexpr, type, desc))
{
ofc_sema_expr_delete(pexpr);
ofc_parse_format_desc_delete(desc);
return false;
}
ofc_parse_format_desc_delete(desc);
ofc_sema_expr_delete(pexpr);
}
return true;
}
ofc_sema_stmt_t* ofc_sema_stmt_io_inquire(
ofc_sema_scope_t* scope,
const ofc_parse_stmt_t* stmt)
{
if (!scope || !stmt
|| (stmt->type != OFC_PARSE_STMT_IO_INQUIRE)
|| !stmt->io.params)
return NULL;
ofc_sema_stmt_t s;
s.type = OFC_SEMA_STMT_IO_INQUIRE;
s.io_inquire.unit = NULL;
s.io_inquire.access = NULL;
s.io_inquire.action = NULL;
s.io_inquire.blank = NULL;
s.io_inquire.delim = NULL;
s.io_inquire.direct = NULL;
s.io_inquire.err = NULL;
s.io_inquire.exist = NULL;
s.io_inquire.file = NULL;
s.io_inquire.form = NULL;
s.io_inquire.formatted = NULL;
s.io_inquire.iostat = NULL;
s.io_inquire.name = NULL;
s.io_inquire.named = NULL;
s.io_inquire.nextrec = NULL;
s.io_inquire.number = NULL;
s.io_inquire.opened = NULL;
s.io_inquire.pad = NULL;
s.io_inquire.position = NULL;
s.io_inquire.read = NULL;
s.io_inquire.readwrite = NULL;
s.io_inquire.recl = NULL;
s.io_inquire.sequential = NULL;
s.io_inquire.unformatted = NULL;
s.io_inquire.write = NULL;
ofc_parse_call_arg_t* ca_unit = NULL;
ofc_parse_call_arg_t* ca_access = NULL;
ofc_parse_call_arg_t* ca_action = NULL;
ofc_parse_call_arg_t* ca_blank = NULL;
ofc_parse_call_arg_t* ca_delim = NULL;
ofc_parse_call_arg_t* ca_direct = NULL;
ofc_parse_call_arg_t* ca_err = NULL;
ofc_parse_call_arg_t* ca_exist = NULL;
ofc_parse_call_arg_t* ca_file = NULL;
ofc_parse_call_arg_t* ca_form = NULL;
ofc_parse_call_arg_t* ca_formatted = NULL;
ofc_parse_call_arg_t* ca_iostat = NULL;
ofc_parse_call_arg_t* ca_name = NULL;
ofc_parse_call_arg_t* ca_named = NULL;
ofc_parse_call_arg_t* ca_nextrec = NULL;
ofc_parse_call_arg_t* ca_number = NULL;
ofc_parse_call_arg_t* ca_opened = NULL;
ofc_parse_call_arg_t* ca_pad = NULL;
ofc_parse_call_arg_t* ca_position = NULL;
ofc_parse_call_arg_t* ca_read = NULL;
ofc_parse_call_arg_t* ca_readwrite = NULL;
ofc_parse_call_arg_t* ca_recl = NULL;
ofc_parse_call_arg_t* ca_sequential = NULL;
ofc_parse_call_arg_t* ca_unformatted = NULL;
ofc_parse_call_arg_t* ca_write = NULL;
unsigned i;
for (i = 0; i < stmt->io.params->count; i++)
{
ofc_parse_call_arg_t* param
= stmt->io.params->call_arg[i];
if (!param) continue;
if (ofc_sparse_ref_empty(param->name))
{
if (i >= 1)
{
ofc_sparse_ref_error(param->src,
"Un-named parameter %u has no meaning in INQUIRE.", i);
return NULL;
}
if (i == 0)
{
ca_unit = param;
}
}
else if (ofc_str_ref_equal_strz_ci(param->name.string, "UNIT"))
{
if (ca_unit)
{
ofc_sparse_ref_error(param->src,
"Re-definition of UNIT in INQUIRE.");
return NULL;
}
ca_unit = param;
}
else if (ofc_str_ref_equal_strz_ci(param->name.string, "ACCESS"))
{
if (ca_access)
{
ofc_sparse_ref_error(param->src,
"Re-definition of ACCESS in INQUIRE.");
return NULL;
}
ca_access = param;
}
else if (ofc_str_ref_equal_strz_ci(param->name.string, "ACTION"))
{
if (ca_action)
{
ofc_sparse_ref_error(param->src,
"Re-definition of ACTION in INQUIRE.");
return NULL;
}
ca_action = param;
}
else if (ofc_str_ref_equal_strz_ci(param->name.string, "BLANK"))
{
if (ca_blank)
{
ofc_sparse_ref_error(param->src,
"Re-definition of BLANK in INQUIRE.");
return NULL;
}
ca_blank = param;
}
else if (ofc_str_ref_equal_strz_ci(param->name.string, "DELIM"))
{
if (ca_delim)
{
ofc_sparse_ref_error(param->src,
"Re-definition of DELIM in INQUIRE.");
return NULL;
}
ca_delim = param;
}
else if (ofc_str_ref_equal_strz_ci(param->name.string, "DIRECT"))
{
if (ca_direct)
{
ofc_sparse_ref_error(param->src,
"Re-definition of DIRECT in INQUIRE.");
return NULL;
}
ca_direct = param;
}
else if (ofc_str_ref_equal_strz_ci(param->name.string, "ERR"))
{
if (ca_err)
{
ofc_sparse_ref_error(param->src,
"Re-definition of ERR in INQUIRE.");
return NULL;
}
ca_err = param;
}
else if (ofc_str_ref_equal_strz_ci(param->name.string, "EXIST"))
{
if (ca_exist)
{
ofc_sparse_ref_error(param->src,
"Re-definition of EXIST in INQUIRE.");
return NULL;
}
ca_exist = param;
}
else if (ofc_str_ref_equal_strz_ci(param->name.string, "FILE"))
{
if (ca_file)
{
ofc_sparse_ref_error(param->src,
"Re-definition of FILE in INQUIRE.");
return NULL;
}
ca_file = param;
}
else if (ofc_str_ref_equal_strz_ci(param->name.string, "FORM"))
{
if (ca_form)
{
ofc_sparse_ref_error(param->src,
"Re-definition of FORM in INQUIRE.");
return NULL;
}
ca_form = param;
}
else if (ofc_str_ref_equal_strz_ci(param->name.string, "FORMATTED"))
{
if (ca_formatted)
{
ofc_sparse_ref_error(param->src,
"Re-definition of FORMATTED in INQUIRE.");
return NULL;
}
ca_formatted = param;
}
else if (ofc_str_ref_equal_strz_ci(param->name.string, "IOSTAT"))
{
if (ca_iostat)
{
ofc_sparse_ref_error(param->src,
"Re-definition of IOSTAT in INQUIRE.");
return NULL;
}
ca_iostat = param;
}
else if (ofc_str_ref_equal_strz_ci(param->name.string, "NAME"))
{
if (ca_name)
{
ofc_sparse_ref_error(param->src,
"Re-definition of NAME in INQUIRE.");
return NULL;
}
ca_name = param;
}
else if (ofc_str_ref_equal_strz_ci(param->name.string, "NAMED"))
{
if (ca_named)
{
ofc_sparse_ref_error(param->src,
"Re-definition of NAMED in INQUIRE.");
return NULL;
}
ca_named = param;
}
else if (ofc_str_ref_equal_strz_ci(param->name.string, "NEXTREC"))
{
if (ca_nextrec)
{
ofc_sparse_ref_error(param->src,
"Re-definition of NEXTREC in INQUIRE.");
return NULL;
}
ca_nextrec = param;
}
else if (ofc_str_ref_equal_strz_ci(param->name.string, "NUMBER"))
{
if (ca_number)
{
ofc_sparse_ref_error(param->src,
"Re-definition of NUMBER in INQUIRE.");
return NULL;
}
ca_number = param;
}
else if (ofc_str_ref_equal_strz_ci(param->name.string, "OPENED"))
{
if (ca_opened)
{
ofc_sparse_ref_error(param->src,
"Re-definition of OPENED in INQUIRE.");
return NULL;
}
ca_opened = param;
}
else if (ofc_str_ref_equal_strz_ci(param->name.string, "PAD"))
{
if (ca_pad)
{
ofc_sparse_ref_error(param->src,
"Re-definition of PAD in INQUIRE.");
return NULL;
}
ca_pad = param;
}
else if (ofc_str_ref_equal_strz_ci(param->name.string, "POSITION"))
{
if (ca_position)
{
ofc_sparse_ref_error(param->src,
"Re-definition of POSITION in INQUIRE.");
return NULL;
}
ca_position = param;
}
else if (ofc_str_ref_equal_strz_ci(param->name.string, "READ"))
{
if (ca_read)
{
ofc_sparse_ref_error(param->src,
"Re-definition of READ in INQUIRE.");
return NULL;
}
ca_read = param;
}
else if (ofc_str_ref_equal_strz_ci(param->name.string, "READWRITE"))
{
if (ca_readwrite)
{
ofc_sparse_ref_error(param->src,
"Re-definition of READWRITE in INQUIRE.");
return NULL;
}
ca_readwrite = param;
}
else if (ofc_str_ref_equal_strz_ci(param->name.string, "RECL"))
{
if (ca_recl)
{
ofc_sparse_ref_error(param->src,
"Re-definition of RECL in INQUIRE.");
return NULL;
}
ca_recl = param;
}
else if (ofc_str_ref_equal_strz_ci(param->name.string, "SEQUENTIAL"))
{
if (ca_sequential)
{
ofc_sparse_ref_error(param->src,
"Re-definition of SEQUENTIAL in INQUIRE.");
return NULL;
}
ca_sequential = param;
}
else if (ofc_str_ref_equal_strz_ci(param->name.string, "UNFORMATTED"))
{
if (ca_unformatted)
{
ofc_sparse_ref_error(param->src,
"Re-definition of UNFORMATTED in INQUIRE.");
return NULL;
}
ca_unformatted = param;
}
else if (ofc_str_ref_equal_strz_ci(param->name.string, "WRITE"))
{
if (ca_write)
{
ofc_sparse_ref_error(param->src,
"Re-definition of WRITE in INQUIRE.");
return NULL;
}
ca_write = param;
}
else
{
ofc_sparse_ref_error(param->src,
"Unrecognized paramater %u name '%.*s' in INQUIRE.",
i, param->name.string.size, param->name.string.base);
return NULL;
}
}
if (!ca_unit && !ca_file)
{
ofc_sparse_ref_error(stmt->src,
"No UNIT or FILE defined in INQUIRE.");
return NULL;
}
else if (ca_unit && ca_file)
{
ofc_sparse_ref_error(stmt->src,
"UNIT and FILE can't be specified at the same time in INQUIRE.");
return NULL;
}
if (ca_unit && (ca_unit->type == OFC_PARSE_CALL_ARG_EXPR))
{
s.io_inquire.unit = ofc_sema_expr(
scope, ca_unit->expr);
if (!s.io_inquire.unit) return NULL;
const ofc_sema_type_t* etype
= ofc_sema_expr_type(s.io_inquire.unit);
if (!etype)
{
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
if (!ofc_sema_type_is_integer(etype))
{
ofc_sparse_ref_error(stmt->src,
"UNIT must be of type INTEGER in INQUIRE");
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
if (!ofc_sema_expr_validate_uint(s.io_inquire.unit))
{
ofc_sparse_ref_error(stmt->src,
"UNIT must be a positive INTEGER in INQUIRE");
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
}
else if (ca_unit)
{
ofc_sparse_ref_error(stmt->src,
"UNIT must be an INTEGER expression in INQUIRE");
return NULL;
}
if (ca_access)
{
s.io_inquire.access = ofc_sema_lhs_from_expr(
scope, ca_access->expr);
if (!s.io_inquire.access)
{
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
const ofc_sema_type_t* etype
= ofc_sema_lhs_type(s.io_inquire.access);
if (!etype)
{
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
if (!ofc_sema_type_is_character(etype))
{
ofc_sparse_ref_error(stmt->src,
"ACCESS must be a CHARACTER variable in INQUIRE");
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
}
if (ca_action)
{
s.io_inquire.action = ofc_sema_lhs_from_expr(
scope, ca_action->expr);
if (!s.io_inquire.action)
{
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
const ofc_sema_type_t* etype
= ofc_sema_lhs_type(s.io_inquire.action);
if (!etype)
{
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
if (!ofc_sema_type_is_character(etype))
{
ofc_sparse_ref_error(stmt->src,
"ACTION must be a CHARACTER variable in INQUIRE");
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
}
if (ca_blank)
{
s.io_inquire.blank = ofc_sema_lhs_from_expr(
scope, ca_blank->expr);
if (!s.io_inquire.blank)
{
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
const ofc_sema_type_t* etype
= ofc_sema_lhs_type(s.io_inquire.blank);
if (!etype)
{
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
if (!ofc_sema_type_is_character(etype))
{
ofc_sparse_ref_error(stmt->src,
"BLANK must be a CHARACTER variable in INQUIRE");
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
}
if (ca_delim)
{
s.io_inquire.delim = ofc_sema_lhs_from_expr(
scope, ca_delim->expr);
if (!s.io_inquire.delim)
{
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
const ofc_sema_type_t* etype
= ofc_sema_lhs_type(s.io_inquire.delim);
if (!etype)
{
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
if (!ofc_sema_type_is_character(etype))
{
ofc_sparse_ref_error(stmt->src,
"DELIM must be a CHARACTER variable in INQUIRE");
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
}
if (ca_direct)
{
s.io_inquire.direct = ofc_sema_lhs_from_expr(
scope, ca_direct->expr);
if (!s.io_inquire.direct)
{
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
const ofc_sema_type_t* etype
= ofc_sema_lhs_type(s.io_inquire.direct);
if (!etype)
{
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
if (!ofc_sema_type_is_character(etype))
{
ofc_sparse_ref_error(stmt->src,
"DIRECT must be a CHARACTER variable in INQUIRE");
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
}
if (ca_err)
{
s.io_inquire.err = ofc_sema_expr(
scope, ca_err->expr);
if (!s.io_inquire.err)
{
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
if (!ofc_sema_io_check_label(
scope, stmt, false,
s.io_inquire.err, NULL))
{
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
}
if (ca_exist)
{
s.io_inquire.exist = ofc_sema_lhs_from_expr(
scope, ca_exist->expr);
if (!s.io_inquire.exist)
{
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
const ofc_sema_type_t* etype
= ofc_sema_lhs_type(s.io_inquire.exist);
if (!etype)
{
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
if (!ofc_sema_type_is_logical(etype))
{
ofc_sparse_ref_error(stmt->src,
"EXIST must be a LOGICAL variable in INQUIRE");
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
}
if (ca_file)
{
s.io_inquire.file = ofc_sema_expr(
scope, ca_file->expr);
if (!s.io_inquire.file)
{
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
const ofc_sema_type_t* etype
= ofc_sema_expr_type(s.io_inquire.file);
if (!etype)
{
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
if (!ofc_sema_type_is_character(etype))
{
ofc_sparse_ref_error(stmt->src,
"FILE must be a CHARACTER expression in INQUIRE");
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
}
if (ca_form)
{
s.io_inquire.form = ofc_sema_lhs_from_expr(
scope, ca_form->expr);
if (!s.io_inquire.form)
{
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
const ofc_sema_type_t* etype
= ofc_sema_lhs_type(s.io_inquire.form);
if (!etype)
{
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
if (!ofc_sema_type_is_character(etype))
{
ofc_sparse_ref_error(stmt->src,
"FORM must be a CHARACTER variable in INQUIRE");
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
}
if (ca_formatted)
{
s.io_inquire.formatted = ofc_sema_lhs_from_expr(
scope, ca_formatted->expr);
if (!s.io_inquire.formatted)
{
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
const ofc_sema_type_t* etype
= ofc_sema_lhs_type(s.io_inquire.formatted);
if (!etype)
{
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
if (!ofc_sema_type_is_character(etype))
{
ofc_sparse_ref_error(stmt->src,
"FORMATTED must be a CHARACTER variable in INQUIRE");
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
}
if (ca_iostat)
{
s.io_inquire.iostat = ofc_sema_lhs_from_expr(
scope, ca_iostat->expr);
if (!s.io_inquire.iostat)
{
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
const ofc_sema_type_t* etype
= ofc_sema_lhs_type(s.io_inquire.iostat);
if (!etype)
{
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
if (!ofc_sema_type_is_integer(etype))
{
ofc_sparse_ref_error(stmt->src,
"IOSTAT must be of type INTEGER in INQUIRE");
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
}
if (ca_name)
{
s.io_inquire.name = ofc_sema_lhs_from_expr(
scope, ca_name->expr);
if (!s.io_inquire.name)
{
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
const ofc_sema_type_t* etype
= ofc_sema_lhs_type(s.io_inquire.name);
if (!etype)
{
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
if (!ofc_sema_type_is_character(etype))
{
ofc_sparse_ref_error(stmt->src,
"NAME must be a CHARACTER variable in INQUIRE");
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
}
if (ca_named)
{
s.io_inquire.named = ofc_sema_lhs_from_expr(
scope, ca_named->expr);
if (!s.io_inquire.named)
{
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
const ofc_sema_type_t* etype
= ofc_sema_lhs_type(s.io_inquire.named);
if (!etype)
{
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
if (!ofc_sema_type_is_logical(etype))
{
ofc_sparse_ref_error(stmt->src,
"NAMED must be a LOGICAL variable in INQUIRE");
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
}
if (ca_nextrec)
{
s.io_inquire.nextrec = ofc_sema_lhs_from_expr(
scope, ca_nextrec->expr);
if (!s.io_inquire.nextrec)
{
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
const ofc_sema_type_t* etype
= ofc_sema_lhs_type(s.io_inquire.nextrec);
if (!etype)
{
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
if (!ofc_sema_type_is_integer(etype))
{
ofc_sparse_ref_error(stmt->src,
"NEXTREC must be of type INTEGER in INQUIRE");
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
}
if (ca_number)
{
s.io_inquire.number = ofc_sema_lhs_from_expr(
scope, ca_number->expr);
if (!s.io_inquire.number)
{
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
const ofc_sema_type_t* etype
= ofc_sema_lhs_type(s.io_inquire.number);
if (!etype)
{
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
if (!ofc_sema_type_is_integer(etype))
{
ofc_sparse_ref_error(stmt->src,
"NUMBER must be an INTEGER variable in INQUIRE");
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
}
if (ca_opened)
{
s.io_inquire.opened = ofc_sema_lhs_from_expr(
scope, ca_opened->expr);
if (!s.io_inquire.opened)
{
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
const ofc_sema_type_t* etype
= ofc_sema_lhs_type(s.io_inquire.opened);
if (!etype)
{
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
if (!ofc_sema_type_is_logical(etype))
{
ofc_sparse_ref_error(stmt->src,
"OPENED must be a LOGICAL variable in INQUIRE");
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
}
if (ca_pad)
{
s.io_inquire.pad = ofc_sema_lhs_from_expr(
scope, ca_pad->expr);
if (!s.io_inquire.pad)
{
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
const ofc_sema_type_t* etype
= ofc_sema_lhs_type(s.io_inquire.pad);
if (!etype)
{
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
if (!ofc_sema_type_is_character(etype))
{
ofc_sparse_ref_error(stmt->src,
"PAD must be a CHARACTER variable in INQUIRE");
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
}
if (ca_position)
{
s.io_inquire.position = ofc_sema_lhs_from_expr(
scope, ca_position->expr);
if (!s.io_inquire.position)
{
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
const ofc_sema_type_t* etype
= ofc_sema_lhs_type(s.io_inquire.position);
if (!etype)
{
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
if (!ofc_sema_type_is_character(etype))
{
ofc_sparse_ref_error(stmt->src,
"POSITION must be a CHARACTER variable in INQUIRE");
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
}
if (ca_read)
{
s.io_inquire.read = ofc_sema_lhs_from_expr(
scope, ca_read->expr);
if (!s.io_inquire.read)
{
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
const ofc_sema_type_t* etype
= ofc_sema_lhs_type(s.io_inquire.read);
if (!etype)
{
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
if (!ofc_sema_type_is_character(etype))
{
ofc_sparse_ref_error(stmt->src,
"READ must be a CHARACTER variable in INQUIRE");
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
}
if (ca_readwrite)
{
s.io_inquire.readwrite = ofc_sema_lhs_from_expr(
scope, ca_readwrite->expr);
if (!s.io_inquire.readwrite)
{
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
const ofc_sema_type_t* etype
= ofc_sema_lhs_type(s.io_inquire.readwrite);
if (!etype)
{
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
if (!ofc_sema_type_is_character(etype))
{
ofc_sparse_ref_error(stmt->src,
"READWRITE must be a CHARACTER variable in INQUIRE");
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
}
if (ca_recl)
{
s.io_inquire.recl = ofc_sema_lhs_from_expr(
scope, ca_recl->expr);
if (!s.io_inquire.recl)
{
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
const ofc_sema_type_t* etype
= ofc_sema_lhs_type(s.io_inquire.recl);
if (!etype)
{
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
if (!ofc_sema_type_is_integer(etype))
{
ofc_sparse_ref_error(stmt->src,
"RECL must be an INTEGER variable in INQUIRE");
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
}
if (ca_sequential)
{
s.io_inquire.sequential = ofc_sema_lhs_from_expr(
scope, ca_sequential->expr);
if (!s.io_inquire.sequential)
{
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
const ofc_sema_type_t* etype
= ofc_sema_lhs_type(s.io_inquire.sequential);
if (!etype)
{
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
if (!ofc_sema_type_is_character(etype))
{
ofc_sparse_ref_error(stmt->src,
"SEQUENTIAL must be a CHARACTER variable in INQUIRE");
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
}
if (ca_unformatted)
{
s.io_inquire.unformatted = ofc_sema_lhs_from_expr(
scope, ca_unformatted->expr);
if (!s.io_inquire.unformatted)
{
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
const ofc_sema_type_t* etype
= ofc_sema_lhs_type(s.io_inquire.unformatted);
if (!etype)
{
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
if (!ofc_sema_type_is_character(etype))
{
ofc_sparse_ref_error(stmt->src,
"UNFORMATTED must be a CHARACTER variable in INQUIRE");
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
}
if (ca_write)
{
s.io_inquire.write = ofc_sema_lhs_from_expr(
scope, ca_write->expr);
if (!s.io_inquire.write)
{
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
const ofc_sema_type_t* etype
= ofc_sema_lhs_type(s.io_inquire.write);
if (!etype)
{
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
if (!ofc_sema_type_is_character(etype))
{
ofc_sparse_ref_error(stmt->src,
"WRITE must be a CHARACTER variable in INQUIRE");
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
}
ofc_sema_stmt_t* as
= ofc_sema_stmt_alloc(s);
if (!as)
{
ofc_sema_stmt_io_inquire__cleanup(s);
return NULL;
}
return as;
}
static ofc_sema_stmt_t* ofc_sema_stmt_do_while__block(
ofc_sema_scope_t* scope,
const ofc_parse_stmt_t* stmt)
{
if (!stmt
|| (stmt->type != OFC_PARSE_STMT_DO_WHILE_BLOCK)
|| !stmt->do_while_block.cond)
return NULL;
ofc_sema_stmt_t s;
s.type = OFC_SEMA_STMT_DO_WHILE_BLOCK;
s.do_while_block.cond = ofc_sema_expr(
scope, stmt->do_while_block.cond);
if (!s.do_while_block.cond)
return NULL;
const ofc_sema_type_t* type
= ofc_sema_expr_type(s.do_while_block.cond);
if (!ofc_sema_type_is_logical(type))
{
ofc_sparse_ref_error(stmt->do_while_block.cond->src,
"IF condition type must be LOGICAL.");
ofc_sema_expr_delete(s.do_while_block.cond);
return NULL;
}
s.do_while_block.block = NULL;
if (stmt->do_while_block.block)
{
s.do_while_block.block
= ofc_sema_stmt_list(
scope, stmt->do_while_block.block);
if (!s.do_while_block.block)
{
ofc_sema_expr_delete(s.do_while_block.cond);
return NULL;
}
}
ofc_sema_stmt_t* as = ofc_sema_stmt_alloc(s);
if (!as)
{
ofc_sema_stmt_list_delete(s.do_while_block.block);
ofc_sema_expr_delete(s.do_while_block.cond);
return NULL;
}
if (stmt->do_while_block.end_do_has_label
&& !ofc_sema_label_map_add_end_block(
scope->label, stmt->do_while_block.end_do_label, as))
{
ofc_sema_stmt_delete(as);
return NULL;
}
return as;
}
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;
}
/* Defaults from https://docs.oracle.com/cd/E19957-01/805-4939/6j4m0vnc3/index.html#z4000743817c */
ofc_parse_format_desc_t* ofc_sema_format_desc_set_def(
const ofc_parse_format_desc_t* desc,
const ofc_sema_expr_t* expr,
const ofc_sema_lhs_t* lhs)
{
if (!desc)
return NULL;
const ofc_sema_type_t* type;
if (expr)
{
type = ofc_sema_expr_type(expr);
if (!type) return NULL;
}
else
{
type = ofc_sema_lhs_type(lhs);
if (!type) return NULL;
}
ofc_sema_kind_e kind
= ofc_sema_type_get_kind(type);
ofc_parse_format_desc_t* copy
= ofc_parse_format_desc_copy(desc);
if (!copy) return NULL;
switch (desc->type)
{
case OFC_PARSE_FORMAT_DESC_E:
case OFC_PARSE_FORMAT_DESC_G:
case OFC_PARSE_FORMAT_DESC_REAL:
case OFC_PARSE_FORMAT_DESC_D:
{
if ((type->type != OFC_SEMA_TYPE_REAL)
&& (type->type != OFC_SEMA_TYPE_COMPLEX))
break;
switch (kind)
{
case OFC_SEMA_KIND_4_BYTE:
if (!desc->e_set)
{
copy->e_set = true;
copy->e = 2;
}
if (!desc->d_set)
{
copy->d_set = true;
copy->d = 7;
}
if (!desc->w_set)
{
copy->w_set = true;
copy->w = 15;
}
break;
case OFC_SEMA_KIND_8_BYTE:
if (!desc->e_set)
{
copy->e_set = true;
copy->e = 2;
}
if (!desc->d_set)
{
copy->d_set = true;
copy->d = 16;
}
if (!desc->w_set)
{
copy->w_set = true;
copy->w = 25;
}
break;
case OFC_SEMA_KIND_16_BYTE:
if (!desc->e_set)
{
copy->e_set = true;
copy->e = 3;
}
if (!desc->d_set)
{
copy->d_set = true;
copy->d = 33;
}
if (!desc->w_set)
{
copy->w_set = true;
copy->w = 42;
}
break;
default:
break;
}
break;
}
case OFC_PARSE_FORMAT_DESC_BINARY:
case OFC_PARSE_FORMAT_DESC_OCTAL:
case OFC_PARSE_FORMAT_DESC_HEX:
{
if ((type->type == OFC_SEMA_TYPE_REAL)
&& (kind == OFC_SEMA_KIND_4_BYTE))
{
if (!desc->w_set)
{
copy->w_set = true;
copy->w = 12;
}
}
else if ((type->type == OFC_SEMA_TYPE_REAL)
&& (kind == OFC_SEMA_KIND_8_BYTE))
{
if (!desc->w_set)
{
copy->w_set = true;
copy->w = 23;
}
}
else if (((type->type == OFC_SEMA_TYPE_REAL)
|| (type->type == OFC_SEMA_TYPE_COMPLEX))
&& (kind == OFC_SEMA_KIND_16_BYTE))
{
if (!desc->w_set)
{
copy->w_set = true;
copy->w = 44;
}
}
else if ((type->type == OFC_SEMA_TYPE_BYTE)
&& (kind == OFC_SEMA_KIND_1_BYTE))
{
if (!desc->w_set)
{
copy->w_set = true;
copy->w = 7;
}
}
else if (((type->type == OFC_SEMA_TYPE_INTEGER)
|| (type->type == OFC_SEMA_TYPE_LOGICAL))
&& (kind == OFC_SEMA_KIND_2_BYTE))
{
if (!desc->w_set)
{
copy->w_set = true;
copy->w = 7;
}
}
else if (((type->type == OFC_SEMA_TYPE_INTEGER)
|| (type->type == OFC_SEMA_TYPE_LOGICAL))
&& (kind == OFC_SEMA_KIND_4_BYTE))
{
if (!desc->w_set)
{
copy->w_set = true;
copy->w = 12;
}
}
break;
}
case OFC_PARSE_FORMAT_DESC_INTEGER:
{
if ((type->type == OFC_SEMA_TYPE_BYTE)
&& (kind == OFC_SEMA_KIND_1_BYTE))
{
if (!desc->w_set)
{
copy->w_set = true;
copy->w = 7;
}
}
else if (((type->type == OFC_SEMA_TYPE_INTEGER)
|| (type->type == OFC_SEMA_TYPE_LOGICAL))
&& (kind == OFC_SEMA_KIND_2_BYTE))
{
if (!desc->w_set)
{
copy->w_set = true;
copy->w = 7;
}
}
else if (((type->type == OFC_SEMA_TYPE_INTEGER)
|| (type->type == OFC_SEMA_TYPE_LOGICAL))
&& (kind == OFC_SEMA_KIND_4_BYTE))
{
if (!desc->w_set)
{
copy->w_set = true;
copy->w = 12;
}
}
break;
}
case OFC_PARSE_FORMAT_DESC_LOGICAL:
{
/* Oracle default for L is 2, but gfortran default is 1 */
break;
}
case OFC_PARSE_FORMAT_DESC_CHARACTER:
{
if ((type->type == OFC_SEMA_TYPE_LOGICAL)
&& (kind == OFC_SEMA_KIND_1_BYTE))
{
if (!desc->w_set)
{
copy->w_set = true;
copy->w = 1;
}
}
else if (((type->type == OFC_SEMA_TYPE_INTEGER)
|| (type->type == OFC_SEMA_TYPE_LOGICAL))
&& (kind == OFC_SEMA_KIND_2_BYTE))
{
if (!desc->w_set)
{
copy->w_set = true;
copy->w = 2;
}
}
else if (((type->type == OFC_SEMA_TYPE_INTEGER)
|| (type->type == OFC_SEMA_TYPE_LOGICAL))
&& (kind == OFC_SEMA_KIND_4_BYTE))
{
if (!desc->w_set)
{
copy->w_set = true;
copy->w = 4;
}
}
else if (((type->type == OFC_SEMA_TYPE_REAL)
|| (type->type == OFC_SEMA_TYPE_COMPLEX))
&& (kind == OFC_SEMA_KIND_4_BYTE))
{
if (!desc->w_set)
{
copy->w_set = true;
copy->w = 4;
}
}
else if (((type->type == OFC_SEMA_TYPE_REAL)
|| (type->type == OFC_SEMA_TYPE_COMPLEX))
&& (kind == OFC_SEMA_KIND_8_BYTE))
{
if (!desc->w_set)
{
copy->w_set = true;
copy->w = 8;
}
}
else if (((type->type == OFC_SEMA_TYPE_REAL)
|| (type->type == OFC_SEMA_TYPE_COMPLEX))
&& (kind == OFC_SEMA_KIND_16_BYTE))
{
if (!desc->w_set)
{
copy->w_set = true;
copy->w = 16;
}
}
break;
}
case OFC_PARSE_FORMAT_DESC_REAL_SCALE:
if (!desc->n_set)
{
copy->n_set = true;
copy->n = 0;
}
break;
case OFC_PARSE_FORMAT_DESC_X:
if (!desc->n_set)
{
copy->n_set = true;
copy->n = 1;
}
break;
case OFC_PARSE_FORMAT_DESC_TL:
case OFC_PARSE_FORMAT_DESC_TR:
if (!desc->w_set)
{
copy->w_set = true;
copy->w = 1;
}
break;
default:
break;
}
return copy;
}
ofc_sema_stmt_t* ofc_sema_stmt_io_position(
ofc_sema_scope_t* scope,
const ofc_parse_stmt_t* stmt)
{
if (!scope || !stmt
|| !stmt->io.params)
return NULL;
const char* name;
ofc_sema_stmt_t s;
switch (stmt->type)
{
case OFC_PARSE_STMT_IO_REWIND:
s.type = OFC_SEMA_STMT_IO_REWIND;
name = "REWIND";
break;
case OFC_PARSE_STMT_IO_END_FILE:
s.type = OFC_SEMA_STMT_IO_END_FILE;
name = "ENDFILE";
break;
case OFC_PARSE_STMT_IO_BACKSPACE:
s.type = OFC_SEMA_STMT_IO_BACKSPACE;
name = "BACKSPACE";
break;
default:
return NULL;
}
s.io_position.unit = NULL;
s.io_position.iostat = NULL;
s.io_position.err = NULL;
ofc_parse_call_arg_t* ca_unit = NULL;
ofc_parse_call_arg_t* ca_iostat = NULL;
ofc_parse_call_arg_t* ca_err = NULL;
unsigned i;
for (i = 0; i < stmt->io.params->count; i++)
{
ofc_parse_call_arg_t* param
= stmt->io.params->call_arg[i];
if (!param) continue;
if (ofc_sparse_ref_empty(param->name))
{
if (i >= 1)
{
ofc_sparse_ref_error(param->src,
"Un-named parameter %u has no meaning in %s.", i, name);
return NULL;
}
if (i == 0)
{
ca_unit = param;
}
}
else if (ofc_str_ref_equal_strz_ci(param->name.string, "UNIT"))
{
if (ca_unit)
{
ofc_sparse_ref_error(param->src,
"Re-definition of UNIT in %s.", name);
return NULL;
}
ca_unit = param;
}
else if (ofc_str_ref_equal_strz_ci(param->name.string, "IOSTAT"))
{
if (ca_iostat)
{
ofc_sparse_ref_error(param->src,
"Re-definition of IOSTAT in %s.", name);
return NULL;
}
ca_iostat = param;
}
else if (ofc_str_ref_equal_strz_ci(param->name.string, "ERR"))
{
if (ca_err)
{
ofc_sparse_ref_error(param->src,
"Re-definition of ERR in %s.", name);
return NULL;
}
ca_err = param;
}
else
{
ofc_sparse_ref_error(param->src,
"Unrecognized paramater %u name '%.*s' in %s.",
i, param->name.string.size, param->name.string.base, name);
return NULL;
}
}
if (!ca_unit)
{
ofc_sparse_ref_error(stmt->src,
"No UNIT defined in %s.", name);
return NULL;
}
if (ca_unit->type == OFC_PARSE_CALL_ARG_EXPR)
{
s.io_position.unit = ofc_sema_expr(
scope, ca_unit->expr);
if (!s.io_position.unit) return NULL;
const ofc_sema_type_t* etype
= ofc_sema_expr_type(s.io_position.unit);
if (!etype) return NULL;
if (!ofc_sema_type_is_integer(etype))
{
ofc_sparse_ref_error(stmt->src,
"UNIT must be of type INTEGER in %s", name);
ofc_sema_expr_delete(s.io_position.unit);
return NULL;
}
if (!ofc_sema_expr_validate_uint(s.io_position.unit))
{
ofc_sparse_ref_error(stmt->src,
"UNIT must be a positive INTEGER in %s", name);
ofc_sema_expr_delete(s.io_position.unit);
return NULL;
}
}
else
{
ofc_sparse_ref_error(stmt->src,
"UNIT must be an INTEGER expression in %s", name);
return NULL;
}
if (ca_iostat)
{
s.io_position.iostat = ofc_sema_expr(
scope, ca_iostat->expr);
if (!s.io_position.iostat)
{
ofc_sema_expr_delete(s.io_position.unit);
return NULL;
}
if (s.io_position.iostat->type != OFC_SEMA_EXPR_LHS)
{
ofc_sparse_ref_error(stmt->src,
"IOSTAT must be of a variable in %s", name);
ofc_sema_expr_delete(s.io_position.unit);
ofc_sema_expr_delete(s.io_position.iostat);
return NULL;
}
const ofc_sema_type_t* etype
= ofc_sema_expr_type(s.io_position.iostat);
if (!etype)
{
ofc_sema_expr_delete(s.io_position.unit);
ofc_sema_expr_delete(s.io_position.iostat);
return NULL;
}
if (!ofc_sema_type_is_integer(etype))
{
ofc_sparse_ref_error(stmt->src,
"IOSTAT must be of type INTEGER in %s", name);
ofc_sema_expr_delete(s.io_position.unit);
ofc_sema_expr_delete(s.io_position.iostat);
return NULL;
}
}
if (ca_err)
{
s.io_position.err = ofc_sema_expr_label(
scope, ca_err->expr);
if (!s.io_position.err)
{
ofc_sema_expr_delete(s.io_position.unit);
ofc_sema_expr_delete(s.io_position.iostat);
return NULL;
}
}
ofc_sema_stmt_t* as
= ofc_sema_stmt_alloc(s);
if (!as)
{
ofc_sema_expr_delete(s.io_position.unit);
ofc_sema_expr_delete(s.io_position.iostat);
ofc_sema_expr_delete(s.io_position.err);
return NULL;
}
return as;
}
