static ofc_sema_lhs_t* ofc_sema_lhs_index(
ofc_sema_lhs_t* lhs,
ofc_sema_array_index_t* index)
{
if (!index)
return NULL;
if (!ofc_sema_lhs_reference(lhs))
return NULL;
ofc_sema_lhs_t* alhs
= (ofc_sema_lhs_t*)malloc(
sizeof(ofc_sema_lhs_t));
if (!alhs)
{
ofc_sema_lhs_delete(lhs);
return NULL;
}
alhs->type = OFC_SEMA_LHS_ARRAY_INDEX;
alhs->src = lhs->src;
alhs->parent = lhs;
alhs->index = index;
alhs->data_type = lhs->data_type;
alhs->refcnt = 0;
return alhs;
}
bool ofc_sema_lhs_list_init(
ofc_sema_lhs_list_t* lhs,
const ofc_sema_expr_list_t* init)
{
unsigned lhs_count;
unsigned init_count;
if (!ofc_sema_lhs_list_elem_count(lhs, &lhs_count)
|| !ofc_sema_expr_list_elem_count(init, &init_count))
return false;
unsigned e = (lhs_count < init_count ? lhs_count : init_count);
unsigned i;
for (i = 0; i < e; i++)
{
ofc_sema_lhs_t* lhs_elem
= ofc_sema_lhs_list_elem_get(lhs, i);
if (!lhs_elem) return false;
ofc_sema_expr_t* init_elem
= ofc_sema_expr_list_elem_get(init, i);
if (!init_elem)
{
ofc_sema_lhs_delete(lhs_elem);
return false;
}
bool success = ofc_sema_lhs_init(
lhs_elem, init_elem);
ofc_sema_lhs_delete(lhs_elem);
if (!success)
{
/* TODO - Fail atomically? */
ofc_sparse_ref_error(init_elem->src,
"Invalid initializer");
ofc_sema_expr_delete(init_elem);
return false;
}
ofc_sema_expr_delete(init_elem);
}
return true;
}
static ofc_sema_lhs_t* ofc_sema_lhs_slice(
ofc_sema_lhs_t* lhs,
ofc_sema_array_slice_t* slice)
{
if (!slice)
return NULL;
const ofc_sema_array_t* parray
= ofc_sema_lhs_array(lhs);
if (!parray) return NULL;
if (!ofc_sema_lhs_reference(lhs))
return NULL;
ofc_sema_array_t* array
= ofc_sema_array_slice_dims(slice, parray);
if (!array)
{
ofc_sema_lhs_delete(lhs);
return NULL;
}
ofc_sema_lhs_t* alhs
= (ofc_sema_lhs_t*)malloc(
sizeof(ofc_sema_lhs_t));
if (!alhs)
{
ofc_sema_array_delete(array);
ofc_sema_lhs_delete(lhs);
return NULL;
}
alhs->type = OFC_SEMA_LHS_ARRAY_SLICE;
alhs->src = lhs->src;
alhs->parent = lhs;
alhs->data_type = lhs->data_type;
alhs->refcnt = 0;
alhs->slice.slice = slice;
alhs->slice.dims = array;
return alhs;
}
void ofc_sema_lhs_list_delete(ofc_sema_lhs_list_t* list)
{
if (!list)
return;
unsigned i;
for (i = 0; i < list->count; i++)
ofc_sema_lhs_delete(list->lhs[i]);
free(list->lhs);
free(list);
}
static ofc_sema_lhs_t* ofc_sema_lhs_member(
ofc_sema_lhs_t* lhs,
ofc_sema_decl_t* member)
{
if (ofc_sema_lhs_is_array(lhs)
&& ofc_sema_decl_is_array(member))
{
/* FORTRAN can't handle nested arrays. */
return NULL;
}
if (!ofc_sema_lhs_reference(lhs))
return NULL;
if (!ofc_sema_decl_reference(member))
{
ofc_sema_lhs_delete(lhs);
return NULL;
}
ofc_sema_lhs_t* alhs
= (ofc_sema_lhs_t*)malloc(
sizeof(ofc_sema_lhs_t));
if (!alhs)
{
ofc_sema_decl_delete(member);
ofc_sema_lhs_delete(lhs);
return NULL;
}
alhs->type = OFC_SEMA_LHS_STRUCTURE_MEMBER;
alhs->src = lhs->src;
alhs->parent = lhs;
alhs->data_type = ofc_sema_decl_type(member);
alhs->refcnt = 0;
alhs->member = member;
return alhs;
}
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_input_list_compare(
const ofc_sema_stmt_t* stmt,
const ofc_parse_format_desc_list_t* format_list,
ofc_sema_lhs_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_lhs_t* lhs
= ofc_sema_lhs_list_elem_get(iolist, i);
const ofc_sema_type_t* type
= ofc_sema_lhs_type(lhs);
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_lhs_delete(lhs);
return false;
}
if (ofc_parse_format_is_data_desc(desc))
break;
ofc_parse_format_desc_delete(desc);
}
if (!ofc_sema_io_compare_types(
stmt, lhs, NULL, type, desc))
{
ofc_sema_lhs_delete(lhs);
ofc_parse_format_desc_delete(desc);
return false;
}
ofc_parse_format_desc_delete(desc);
}
ofc_sema_lhs_delete(lhs);
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, lhs, NULL, type, desc))
{
ofc_sema_lhs_delete(lhs);
ofc_parse_format_desc_delete(desc);
return false;
}
ofc_parse_format_desc_delete(desc);
ofc_sema_lhs_delete(lhs);
}
return true;
}
static ofc_parse_format_desc_t* ofc_sema_io_format_input_list_check_def__helper(
ofc_parse_format_desc_t* desc,
ofc_sema_lhs_list_t* iolist,
unsigned* offset, bool* changed)
{
if (!desc || !iolist)
return NULL;
if (desc->type == OFC_PARSE_FORMAT_DESC_REPEAT)
{
ofc_parse_format_desc_list_t* repeat_list
= ofc_parse_format_desc_list_create();
if (!repeat_list) return NULL;
bool was_changed = false;
unsigned k;
for (k = 0; k < desc->repeat->count; k++)
{
bool c = false;
ofc_parse_format_desc_t* elem
= ofc_sema_io_format_input_list_check_def__helper(
desc->repeat->desc[k], iolist, offset, &c);
if (c) was_changed = true;
if (!ofc_parse_format_desc_list_add(repeat_list, elem))
{
ofc_parse_format_desc_list_delete(repeat_list);
return NULL;
}
}
if (changed) *changed = was_changed;
ofc_parse_format_desc_t* repeat
= ofc_parse_format_desc_create_repeat(repeat_list, desc->n);
return repeat;
}
else if (!ofc_parse_format_is_data_desc(desc))
{
if (changed) *changed = false;
return ofc_parse_format_desc_copy(desc);
}
else
{
unsigned repeat;
if (!ofc_parse_format_desc_elem_count(
desc, &repeat))
return NULL;
ofc_sema_lhs_t* lhs
= ofc_sema_lhs_list_elem_get(iolist, *offset);
*offset += repeat;
if (!lhs)
return ofc_parse_format_desc_copy(desc);
ofc_parse_format_desc_t* copy
= ofc_sema_format_desc_set_def(desc, NULL, lhs);
if (!copy)
{
ofc_sema_lhs_delete(lhs);
return NULL;
}
bool is_same = ofc_parse_format_desc_compare(desc, copy);
if (changed) *changed = is_same;
ofc_sema_lhs_delete(lhs);
return copy;
}
return NULL;
}
void ofc_sema_stmt_io_inquire__cleanup(
ofc_sema_stmt_t s)
{
ofc_sema_expr_delete(s.io_inquire.unit);
ofc_sema_expr_delete(s.io_inquire.file);
ofc_sema_expr_delete(s.io_inquire.err);
ofc_sema_lhs_delete(s.io_inquire.access);
ofc_sema_lhs_delete(s.io_inquire.action);
ofc_sema_lhs_delete(s.io_inquire.blank);
ofc_sema_lhs_delete(s.io_inquire.delim);
ofc_sema_lhs_delete(s.io_inquire.direct);
ofc_sema_lhs_delete(s.io_inquire.exist);
ofc_sema_lhs_delete(s.io_inquire.form);
ofc_sema_lhs_delete(s.io_inquire.formatted);
ofc_sema_lhs_delete(s.io_inquire.iostat);
ofc_sema_lhs_delete(s.io_inquire.name);
ofc_sema_lhs_delete(s.io_inquire.named);
ofc_sema_lhs_delete(s.io_inquire.nextrec);
ofc_sema_lhs_delete(s.io_inquire.number);
ofc_sema_lhs_delete(s.io_inquire.opened);
ofc_sema_lhs_delete(s.io_inquire.pad);
ofc_sema_lhs_delete(s.io_inquire.position);
ofc_sema_lhs_delete(s.io_inquire.read);
ofc_sema_lhs_delete(s.io_inquire.readwrite);
ofc_sema_lhs_delete(s.io_inquire.recl);
ofc_sema_lhs_delete(s.io_inquire.sequential);
ofc_sema_lhs_delete(s.io_inquire.unformatted);
ofc_sema_lhs_delete(s.io_inquire.write);
}
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_substring(
ofc_sema_scope_t* scope,
ofc_sema_lhs_t* lhs,
const ofc_parse_array_index_t* index)
{
if (!ofc_sema_lhs_reference(lhs))
return NULL;
if (!index
|| (index->count != 1)
|| !lhs->data_type)
{
ofc_sema_lhs_delete(lhs);
return NULL;
}
const ofc_parse_array_range_t* range
= index->range[0];
if (!range || range->stride)
{
ofc_sema_lhs_delete(lhs);
return NULL;
}
ofc_sema_expr_t* first
= ofc_sema_expr(scope, range->first);
if (range->first && !first)
{
ofc_sema_lhs_delete(lhs);
return NULL;
}
ofc_sema_expr_t* last = NULL;
if (range->last)
{
last = ofc_sema_expr(scope, range->last);
if (!last)
{
ofc_sema_lhs_delete(lhs);
ofc_sema_expr_delete(first);
return NULL;
}
}
else if (!range->is_slice)
{
last = first;
}
unsigned len = 0;
bool len_var = true;
if ((!first || ofc_sema_expr_is_constant(first))
&& ofc_sema_expr_is_constant(last))
{
const ofc_sema_typeval_t* first_ctv
= ofc_sema_expr_constant(first);
const ofc_sema_typeval_t* last_ctv
= ofc_sema_expr_constant(last);
if ((first && !first_ctv) || !last_ctv)
{
ofc_sema_lhs_delete(lhs);
if (last != first)
ofc_sema_expr_delete(last);
ofc_sema_expr_delete(first);
return NULL;
}
int64_t ifirst = 1;
if (first && !ofc_sema_typeval_get_integer(
first_ctv, &ifirst))
{
ofc_sema_lhs_delete(lhs);
if (last != first)
ofc_sema_expr_delete(last);
ofc_sema_expr_delete(first);
return NULL;
}
int64_t ilast;
if (!ofc_sema_typeval_get_integer(
last_ctv, &ilast))
{
ofc_sema_lhs_delete(lhs);
if (last != first)
ofc_sema_expr_delete(last);
ofc_sema_expr_delete(first);
return NULL;
}
if (ifirst < 0)
{
ofc_sparse_ref_error(lhs->src,
"First index in character substring must be 1 or greater");
ofc_sema_lhs_delete(lhs);
if (last != first)
ofc_sema_expr_delete(last);
ofc_sema_expr_delete(first);
return NULL;
}
if (ilast < ifirst)
{
ofc_sparse_ref_error(lhs->src,
"Last index in character substring must be greater than first");
ofc_sema_lhs_delete(lhs);
if (last != first)
ofc_sema_expr_delete(last);
ofc_sema_expr_delete(first);
return NULL;
}
if ((lhs->data_type->len > 0)
&& (ilast > lhs->data_type->len))
{
ofc_sparse_ref_warning(lhs->src,
"Last index in character substring out-of-bounds");
}
int64_t ilen = (ilast - ifirst) + 1;
len = ilen;
if ((int64_t)len != ilen)
{
ofc_sema_lhs_delete(lhs);
if (last != first)
ofc_sema_expr_delete(last);
ofc_sema_expr_delete(first);
return NULL;
}
len_var = false;
}
const ofc_sema_type_t* type
= ofc_sema_type_create_character(
lhs->data_type->kind, len, len_var);
if (!type)
{
ofc_sema_lhs_delete(lhs);
if (last != first)
ofc_sema_expr_delete(last);
ofc_sema_expr_delete(first);
return NULL;
}
ofc_sema_lhs_t* alhs
= (ofc_sema_lhs_t*)malloc(
sizeof(ofc_sema_lhs_t));
if (!alhs)
{
if (last != first)
ofc_sema_expr_delete(last);
ofc_sema_expr_delete(first);
ofc_sema_lhs_delete(lhs);
return NULL;
}
alhs->type = OFC_SEMA_LHS_SUBSTRING;
alhs->src = lhs->src;
alhs->parent = lhs;
alhs->substring.first = first;
alhs->substring.last = last;
alhs->data_type = type;
alhs->refcnt = 0;
return alhs;
}
ofc_sema_lhs_t* ofc_sema_lhs_elem_get(
ofc_sema_lhs_t* lhs, unsigned offset)
{
if (!lhs)
return NULL;
switch (lhs->type)
{
case OFC_SEMA_LHS_DECL:
case OFC_SEMA_LHS_ARRAY_INDEX:
case OFC_SEMA_LHS_STRUCTURE_MEMBER:
if (ofc_sema_type_is_procedure(lhs->data_type))
return NULL;
ofc_sema_structure_t* structure
= ofc_sema_lhs_structure(lhs);
if (ofc_sema_lhs_is_array(lhs))
{
unsigned base_count = 1;
if (structure)
{
unsigned scount;
if (!ofc_sema_structure_elem_count(
structure, &scount))
return NULL;
base_count *= scount;
if (base_count == 0)
return NULL;
}
unsigned base_offset = (offset % base_count);
ofc_sema_array_index_t* index
= ofc_sema_array_index_from_offset(
lhs->decl, (offset / base_count));
if (!index) return NULL;
ofc_sema_lhs_t* nlhs
= ofc_sema_lhs_index(lhs, index);
if (!nlhs)
{
ofc_sema_array_index_delete(index);
return NULL;
}
ofc_sema_lhs_t* rlhs
= ofc_sema_lhs_elem_get(
nlhs, base_offset);
ofc_sema_lhs_delete(nlhs);
return rlhs;
}
else if (structure)
{
ofc_sema_decl_t* member
= ofc_sema_structure_member_get_decl_offset(
structure, offset);
ofc_sema_lhs_t* nlhs
= ofc_sema_lhs_member(lhs, member);
if (!nlhs)
{
ofc_sema_decl_delete(member);
return NULL;
}
ofc_sema_lhs_t* rlhs
= ofc_sema_lhs_elem_get(
nlhs, offset);
ofc_sema_lhs_delete(nlhs);
return rlhs;
}
else
{
if (offset != 0)
return NULL;
if (!ofc_sema_lhs_reference(lhs))
return NULL;
return lhs;
}
break;
case OFC_SEMA_LHS_ARRAY_SLICE:
{
if (ofc_sema_type_is_procedure(lhs->data_type))
return NULL;
ofc_sema_structure_t* structure
= ofc_sema_lhs_structure(lhs);
unsigned base_count = 1;
if (structure)
{
unsigned scount;
if (!ofc_sema_structure_elem_count(
structure, &scount))
return NULL;
base_count *= scount;
if (base_count == 0)
return NULL;
}
unsigned base_offset = (offset % base_count);
ofc_sema_array_index_t* index
= ofc_sema_array_slice_index_from_offset(
lhs->slice.slice, (offset / base_count));
if (!index) return NULL;
ofc_sema_lhs_t* nlhs
= ofc_sema_lhs_index(lhs->parent, index);
if (!nlhs)
{
ofc_sema_array_index_delete(index);
return NULL;
}
ofc_sema_lhs_t* rlhs
= ofc_sema_lhs_elem_get(
nlhs, base_offset);
ofc_sema_lhs_delete(nlhs);
return rlhs;
}
case OFC_SEMA_LHS_SUBSTRING:
if (offset != 0)
return NULL;
if (!ofc_sema_lhs_reference(lhs))
return NULL;
return lhs;
case OFC_SEMA_LHS_IMPLICIT_DO:
{
if (!lhs->implicit_do.iter)
return NULL;
unsigned sub_elem_count;
if (!ofc_sema_lhs_list_elem_count(
lhs->implicit_do.lhs, &sub_elem_count))
return NULL;
if (sub_elem_count == 0)
return NULL;
unsigned sub_offset
= (offset % sub_elem_count);
offset /= sub_elem_count;
const ofc_sema_typeval_t* ctv[2];
ctv[0] = ofc_sema_expr_constant(
lhs->implicit_do.init);
ctv[1] = ofc_sema_expr_constant(
lhs->implicit_do.step);
long double first, step = 1.0;
if (!ofc_sema_typeval_get_real(ctv[0], &first))
return NULL;
if (ctv[1] && !ofc_sema_typeval_get_real(ctv[1], &step))
return NULL;
long double doffset
= first + ((long double)offset * step);
ofc_sema_typeval_t* dinit
= ofc_sema_typeval_create_real(
doffset, OFC_SEMA_KIND_NONE,
OFC_SPARSE_REF_EMPTY);
if (!dinit) return NULL;
ofc_sema_typeval_t* init
= ofc_sema_typeval_cast(
dinit, lhs->implicit_do.iter->type);
ofc_sema_typeval_delete(dinit);
if (!init) return NULL;
ofc_sema_expr_t* iter_expr
= ofc_sema_expr_typeval(init);
if (!iter_expr)
{
ofc_sema_typeval_delete(init);
return NULL;
}
ofc_sema_lhs_t* rval = NULL;
unsigned e = sub_offset;
unsigned i;
for (i = 0; i < lhs->implicit_do.lhs->count; i++)
{
ofc_sema_lhs_t* lhs_dummy
= lhs->implicit_do.lhs->lhs[i];
unsigned elem_count;
if (!ofc_sema_lhs_elem_count(
lhs_dummy, &elem_count))
return NULL;
if (e < elem_count)
{
ofc_sema_lhs_t* body
= ofc_sema_lhs_copy_replace(
lhs_dummy, lhs->implicit_do.iter, iter_expr);
if (!body) return NULL;
rval = ofc_sema_lhs_elem_get(
body, sub_offset);
ofc_sema_lhs_delete(body);
}
else
{
e -= elem_count;
}
}
ofc_sema_expr_delete(iter_expr);
return rval;
}
default:
break;
}
return NULL;
}
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;
}
static ofc_sema_lhs_t* ofc_sema__lhs(
ofc_sema_scope_t* scope,
const ofc_parse_lhs_t* lhs,
bool is_expr, bool force_local,
bool is_dummy_arg)
{
if (!scope || !lhs)
return NULL;
switch (lhs->type)
{
case OFC_PARSE_LHS_IMPLICIT_DO:
ofc_sparse_ref_error(lhs->src,
"Can't resolve implicit do to single %s.",
(is_expr ? "primary expression": "LHS"));
return NULL;
case OFC_PARSE_LHS_STAR_LEN:
ofc_sparse_ref_error(lhs->src,
"Can't resolve star length to %s.",
(is_expr ? "primary expression": "LHS"));
return NULL;
case OFC_PARSE_LHS_MEMBER_TYPE:
case OFC_PARSE_LHS_MEMBER_STRUCTURE:
{
ofc_sema_lhs_t* parent = ofc_sema__lhs(
scope, lhs->parent, is_expr, force_local, is_dummy_arg);
if (!parent) return NULL;
ofc_sema_structure_t* structure
= ofc_sema_lhs_structure(parent);
if (!structure)
{
ofc_sparse_ref_error(lhs->src,
"Attempting to dereference member of a variable"
" that's not a structure.");
ofc_sema_lhs_delete(parent);
return NULL;
}
if ((lhs->type == OFC_PARSE_LHS_MEMBER_TYPE)
&& !ofc_sema_structure_is_derived_type(structure))
{
ofc_sparse_ref_warning(lhs->src,
"Dereferencing member of a VAX struct using F90 syntax");
}
else if ((lhs->type == OFC_PARSE_LHS_MEMBER_STRUCTURE)
&& ofc_sema_structure_is_derived_type(structure))
{
ofc_sparse_ref_warning(lhs->src,
"Dereferencing member of an F90 TYPE using VAX syntax");
}
ofc_sema_decl_t* member
= ofc_sema_structure_member_get_decl_name(
structure, lhs->member.name.string);
if (!member)
{
ofc_sparse_ref_error(lhs->src,
"Dereferencing undefined structure member");
ofc_sema_lhs_delete(parent);
return NULL;
}
ofc_sema_lhs_t* slhs
= ofc_sema_lhs_member(
parent, member);
ofc_sema_lhs_delete(parent);
return slhs;
}
case OFC_PARSE_LHS_ARRAY:
{
ofc_sema_lhs_t* parent = ofc_sema__lhs(
scope, lhs->parent, is_expr, force_local, is_dummy_arg);
if (!parent) return NULL;
if (!ofc_sema_lhs_is_array(parent))
{
if (!ofc_sema_type_is_character(
parent->data_type))
{
ofc_sparse_ref_error(lhs->src,
"Attempting to index a variable that's not an array");
ofc_sema_lhs_delete(parent);
return NULL;
}
ofc_sema_lhs_t* slhs
= ofc_sema_lhs_substring(
scope, parent, lhs->array.index);
ofc_sema_lhs_delete(parent);
return slhs;
}
ofc_sema_array_index_t* index
= ofc_sema_array_index(scope,
ofc_sema_lhs_array(parent),
lhs->array.index);
if (index)
{
ofc_sema_lhs_t* slhs
= ofc_sema_lhs_index(parent, index);
ofc_sema_lhs_delete(parent);
if (!slhs)
{
ofc_sema_array_index_delete(index);
return NULL;
}
return slhs;
}
/* TODO - Don't double-error when an index is out-of-bounds. */
ofc_sema_array_slice_t* slice
= ofc_sema_array_slice(scope,
ofc_sema_lhs_array(parent),
lhs->array.index);
if (!slice)
{
ofc_sema_lhs_delete(parent);
return NULL;
}
ofc_sema_lhs_t* slhs
= ofc_sema_lhs_slice(parent, slice);
ofc_sema_lhs_delete(parent);
if (!slhs)
{
ofc_sema_array_slice_delete(slice);
return NULL;
}
return slhs;
}
case OFC_PARSE_LHS_VARIABLE:
break;
default:
return NULL;
}
ofc_sema_decl_t* decl
= ofc_sema_scope_decl_find_create(
scope, lhs->variable, force_local);
if (!decl)
{
ofc_sparse_ref_error(lhs->src,
"No declaration for '%.*s' and no valid IMPLICIT rule.",
lhs->variable.string.size, lhs->variable.string.base);
return NULL;
}
if (!is_expr && !is_dummy_arg
&& ofc_sema_decl_is_parameter(decl))
{
/* TODO - Throw this error for PARAMETER arrays, etc. too. */
ofc_sparse_ref_error(lhs->src,
"Assignment to PARAMETER declaration");
return NULL;
}
ofc_sema_lhs_t* slhs
= (ofc_sema_lhs_t*)malloc(
sizeof(ofc_sema_lhs_t));
if (!slhs) return NULL;
if (!ofc_sema_decl_reference(decl))
{
free(slhs);
return NULL;
}
slhs->type = OFC_SEMA_LHS_DECL;
slhs->src = lhs->src;
slhs->decl = decl;
slhs->refcnt = 0;
if (is_expr || is_dummy_arg)
{
if (!is_dummy_arg
|| !ofc_sema_decl_is_external(decl))
{
if (!ofc_sema_decl_type_finalize(decl))
{
ofc_sema_lhs_delete(slhs);
return NULL;
}
}
if (!ofc_sema_decl_mark_used(decl, false, true))
{
ofc_sema_lhs_delete(slhs);
return NULL;
}
}
slhs->data_type = decl->type;
return slhs;
}
void ofc_sema_lhs_delete(
ofc_sema_lhs_t* lhs)
{
if (!lhs)
return;
if (lhs->refcnt > 0)
{
lhs->refcnt--;
return;
}
switch (lhs->type)
{
case OFC_SEMA_LHS_DECL:
ofc_sema_decl_delete(lhs->decl);
break;
case OFC_SEMA_LHS_ARRAY_INDEX:
case OFC_SEMA_LHS_ARRAY_SLICE:
case OFC_SEMA_LHS_SUBSTRING:
case OFC_SEMA_LHS_STRUCTURE_MEMBER:
ofc_sema_lhs_delete(lhs->parent);
break;
default:
break;
}
switch (lhs->type)
{
case OFC_SEMA_LHS_ARRAY_INDEX:
ofc_sema_array_index_delete(lhs->index);
break;
case OFC_SEMA_LHS_ARRAY_SLICE:
ofc_sema_array_slice_delete(lhs->slice.slice);
ofc_sema_array_delete(lhs->slice.dims);
break;
case OFC_SEMA_LHS_SUBSTRING:
if (lhs->substring.last != lhs->substring.first)
ofc_sema_expr_delete(lhs->substring.last);
ofc_sema_expr_delete(lhs->substring.first);
break;
case OFC_SEMA_LHS_STRUCTURE_MEMBER:
ofc_sema_decl_delete(lhs->member);
break;
case OFC_SEMA_LHS_IMPLICIT_DO:
ofc_sema_lhs_list_delete(lhs->implicit_do.lhs);
ofc_sema_decl_delete(lhs->implicit_do.iter);
ofc_sema_expr_delete(lhs->implicit_do.init);
ofc_sema_expr_delete(lhs->implicit_do.last);
ofc_sema_expr_delete(lhs->implicit_do.step);
break;
default:
break;
}
free(lhs);
}
ofc_sema_lhs_t* ofc_sema_lhs_copy_replace(
const ofc_sema_lhs_t* lhs,
const ofc_sema_decl_t* replace,
const ofc_sema_expr_t* with)
{
if (!lhs)
return NULL;
ofc_sema_lhs_t* copy
= (ofc_sema_lhs_t*)malloc(
sizeof(ofc_sema_lhs_t));
if (!copy) return NULL;
*copy = *lhs;
if (lhs->type == OFC_SEMA_LHS_DECL)
{
if (!ofc_sema_decl_reference(lhs->decl))
{
free(copy);
return NULL;
}
}
else if (lhs->type == OFC_SEMA_LHS_IMPLICIT_DO)
{
copy->implicit_do.lhs
= ofc_sema_lhs_list_copy_replace(
lhs->implicit_do.lhs, replace, with);
copy->implicit_do.iter
= (ofc_sema_decl_reference(lhs->implicit_do.iter)
? lhs->implicit_do.iter : NULL);
copy->implicit_do.init
= ofc_sema_expr_copy_replace(
lhs->implicit_do.init, replace, with);
copy->implicit_do.last
= ofc_sema_expr_copy_replace(
lhs->implicit_do.last, replace, with);
copy->implicit_do.step
= ofc_sema_expr_copy_replace(
lhs->implicit_do.step, replace, with);
if (!copy->implicit_do.lhs
|| !copy->implicit_do.iter
|| !copy->implicit_do.init
|| !copy->implicit_do.last
|| (lhs->implicit_do.step
&& !copy->implicit_do.step))
{
ofc_sema_lhs_delete(copy);
return NULL;
}
}
else
{
switch (lhs->type)
{
case OFC_SEMA_LHS_ARRAY_INDEX:
copy->index = ofc_sema_array_index_copy_replace(
lhs->index, replace, with);
if (!copy->index)
{
free(copy);
return NULL;
}
break;
case OFC_SEMA_LHS_ARRAY_SLICE:
copy->slice.slice
= ofc_sema_array_slice_copy_replace(
lhs->slice.slice, replace, with);
copy->slice.dims
= ofc_sema_array_copy_replace(
lhs->slice.dims, replace, with);
if (!copy->slice.slice
|| !copy->slice.dims)
{
ofc_sema_array_slice_delete(copy->slice.slice);
ofc_sema_array_delete(copy->slice.dims);
free(copy);
return NULL;
}
break;
case OFC_SEMA_LHS_SUBSTRING:
if (lhs->substring.first)
{
copy->substring.first
= ofc_sema_expr_copy_replace(
lhs->substring.first, replace, with);
if (!copy->substring.first)
{
free(copy);
return NULL;
}
}
if (lhs->substring.last)
{
copy->substring.last
= ofc_sema_expr_copy_replace(
lhs->substring.last, replace, with);
if (!copy->substring.last)
{
ofc_sema_expr_delete(
copy->substring.first);
free(copy);
return NULL;
}
}
break;
case OFC_SEMA_LHS_STRUCTURE_MEMBER:
break;
default:
free(copy);
return NULL;
}
copy->parent = ofc_sema_lhs_copy_replace(
lhs->parent, replace, with);
if (!copy->parent)
{
ofc_sema_lhs_delete(copy);
return NULL;
}
}
return copy;
}
