break;
case BT_COMPLEX:
-#ifdef HAVE_mpc
mpc_clear (e->value.complex);
-#else
- mpfr_clear (e->value.complex.r);
- mpfr_clear (e->value.complex.i);
-#endif
break;
default:
}
+/* Insert a reference to the component of the given name.
+ Only to be used with CLASS containers. */
+
+void
+gfc_add_component_ref (gfc_expr *e, const char *name)
+{
+ gfc_ref **tail = &(e->ref);
+ gfc_ref *next = NULL;
+ gfc_symbol *derived = e->symtree->n.sym->ts.u.derived;
+ while (*tail != NULL)
+ {
+ if ((*tail)->type == REF_COMPONENT)
+ derived = (*tail)->u.c.component->ts.u.derived;
+ if ((*tail)->type == REF_ARRAY && (*tail)->next == NULL)
+ break;
+ tail = &((*tail)->next);
+ }
+ if (*tail != NULL && strcmp (name, "$data") == 0)
+ next = *tail;
+ (*tail) = gfc_get_ref();
+ (*tail)->next = next;
+ (*tail)->type = REF_COMPONENT;
+ (*tail)->u.c.sym = derived;
+ (*tail)->u.c.component = gfc_find_component (derived, name, true, true);
+ gcc_assert((*tail)->u.c.component);
+ if (!next)
+ e->ts = (*tail)->u.c.component->ts;
+}
+
+
/* Copy a shape array. */
mpz_t *
case BT_COMPLEX:
gfc_set_model_kind (q->ts.kind);
-#ifdef HAVE_mpc
mpc_init2 (q->value.complex, mpfr_get_default_prec());
mpc_set (q->value.complex, p->value.complex, GFC_MPC_RND_MODE);
-#else
- mpfr_init (q->value.complex.r);
- mpfr_init (q->value.complex.i);
- mpfr_set (q->value.complex.r, p->value.complex.r, GFC_RND_MODE);
- mpfr_set (q->value.complex.i, p->value.complex.i, GFC_RND_MODE);
-#endif
break;
case BT_CHARACTER:
case BT_HOLLERITH:
case BT_LOGICAL:
case BT_DERIVED:
+ case BT_CLASS:
break; /* Already done. */
case BT_PROCEDURE:
/* Given an expression node with some sort of numeric binary
expression, insert type conversions required to make the operands
- have the same type.
+ have the same type. Conversion warnings are disabled if wconversion
+ is set to 0.
The exception is that the operands of an exponential don't have to
have the same type. If possible, the base is promoted to the type
1.0**2 stays as it is. */
void
-gfc_type_convert_binary (gfc_expr *e)
+gfc_type_convert_binary (gfc_expr *e, int wconversion)
{
gfc_expr *op1, *op2;
}
if (op1->ts.kind > op2->ts.kind)
- gfc_convert_type (op2, &op1->ts, 2);
+ gfc_convert_type_warn (op2, &op1->ts, 2, wconversion);
else
- gfc_convert_type (op1, &op2->ts, 2);
+ gfc_convert_type_warn (op1, &op2->ts, 2, wconversion);
e->ts = op1->ts;
goto done;
if (e->value.op.op == INTRINSIC_POWER)
goto done;
- gfc_convert_type (e->value.op.op2, &e->ts, 2);
+ gfc_convert_type_warn (e->value.op.op2, &e->ts, 2, wconversion);
goto done;
}
if (op1->ts.type == BT_INTEGER)
{
e->ts = op2->ts;
- gfc_convert_type (e->value.op.op1, &e->ts, 2);
+ gfc_convert_type_warn (e->value.op.op1, &e->ts, 2, wconversion);
goto done;
}
else
e->ts.kind = op2->ts.kind;
if (op1->ts.type != BT_COMPLEX || op1->ts.kind != e->ts.kind)
- gfc_convert_type (e->value.op.op1, &e->ts, 2);
+ gfc_convert_type_warn (e->value.op.op1, &e->ts, 2, wconversion);
if (op2->ts.type != BT_COMPLEX || op2->ts.kind != e->ts.kind)
- gfc_convert_type (e->value.op.op2, &e->ts, 2);
+ gfc_convert_type_warn (e->value.op.op2, &e->ts, 2, wconversion);
done:
return;
{
gfc_expr *e;
- e = cons->expr;
- cons->expr = NULL;
+ if (cons)
+ {
+ e = cons->expr;
+ cons->expr = NULL;
+ }
+ else
+ e = gfc_copy_expr (p);
e->ref = p->ref->next;
p->ref->next = NULL;
gfc_replace_expr (p, e);
{
gfc_constructor *cons;
gfc_expr *newp;
+ gfc_ref *last_ref;
while (p->ref)
{
switch (p->ref->u.ar.type)
{
case AR_ELEMENT:
+ /* <type/kind spec>, parameter :: x(<int>) = scalar_expr
+ will generate this. */
+ if (p->expr_type != EXPR_ARRAY)
+ {
+ remove_subobject_ref (p, NULL);
+ break;
+ }
if (find_array_element (p->value.constructor, &p->ref->u.ar,
&cons) == FAILURE)
return FAILURE;
return FAILURE;
}
- /* If this is a CHARACTER array and we possibly took a
- substring out of it, update the type-spec's character
- length according to the first element (as all should have
- the same length). */
- if (p->ts.type == BT_CHARACTER)
+ if (p->ts.type == BT_DERIVED
+ && p->ref->next
+ && p->value.constructor)
{
- int string_len;
+ /* There may have been component references. */
+ p->ts = p->value.constructor->expr->ts;
+ }
- gcc_assert (p->ref->next);
- gcc_assert (!p->ref->next->next);
- gcc_assert (p->ref->next->type == REF_SUBSTRING);
+ last_ref = p->ref;
+ for (; last_ref->next; last_ref = last_ref->next) {};
+ if (p->ts.type == BT_CHARACTER
+ && last_ref->type == REF_SUBSTRING)
+ {
+ /* If this is a CHARACTER array and we possibly took
+ a substring out of it, update the type-spec's
+ character length according to the first element
+ (as all should have the same length). */
+ int string_len;
if (p->value.constructor)
{
const gfc_expr* first = p->value.constructor->expr;
else
string_len = 0;
- if (!p->ts.cl)
- {
- p->ts.cl = gfc_get_charlen ();
- p->ts.cl->next = NULL;
- p->ts.cl->length = NULL;
- }
- gfc_free_expr (p->ts.cl->length);
- p->ts.cl->length = gfc_int_expr (string_len);
+ if (!p->ts.u.cl)
+ p->ts.u.cl = gfc_new_charlen (p->symtree->n.sym->ns,
+ NULL);
+ else
+ gfc_free_expr (p->ts.u.cl->length);
+
+ p->ts.u.cl->length = gfc_int_expr (string_len);
}
}
gfc_free_ref_list (p->ref);
gfc_free (p->value.character.string);
p->value.character.string = s;
p->value.character.length = end - start;
- p->ts.cl = gfc_new_charlen (gfc_current_ns);
- p->ts.cl->length = gfc_int_expr (p->value.character.length);
+ p->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
+ p->ts.u.cl->length = gfc_int_expr (p->value.character.length);
gfc_free_ref_list (p->ref);
p->ref = NULL;
p->expr_type = EXPR_CONSTANT;
return FAILURE;
}
+/* F2003, 7.1.7 (3): In init expression, allocatable components
+ must not be data-initialized. */
+static gfc_try
+check_alloc_comp_init (gfc_expr *e)
+{
+ gfc_component *c;
+ gfc_constructor *ctor;
+
+ gcc_assert (e->expr_type == EXPR_STRUCTURE);
+ gcc_assert (e->ts.type == BT_DERIVED);
+
+ for (c = e->ts.u.derived->components, ctor = e->value.constructor;
+ c; c = c->next, ctor = ctor->next)
+ {
+ if (c->attr.allocatable
+ && ctor->expr->expr_type != EXPR_NULL)
+ {
+ gfc_error("Invalid initialization expression for ALLOCATABLE "
+ "component '%s' in structure constructor at %L",
+ c->name, &ctor->expr->where);
+ return FAILURE;
+ }
+ }
+
+ return SUCCESS;
+}
static match
check_init_expr_arguments (gfc_expr *e)
with LEN, as required by the standard. */
if (i == 5 && not_restricted
&& ap->expr->symtree->n.sym->ts.type == BT_CHARACTER
- && ap->expr->symtree->n.sym->ts.cl->length == NULL)
+ && ap->expr->symtree->n.sym->ts.u.cl->length == NULL)
{
gfc_error ("Assumed character length variable '%s' in constant "
"expression at %L", e->symtree->n.sym->name, &e->where);
case EXPR_FUNCTION:
t = FAILURE;
- if ((m = check_specification_function (e)) != MATCH_YES)
- {
- gfc_intrinsic_sym* isym;
- gfc_symbol* sym;
+ {
+ gfc_intrinsic_sym* isym;
+ gfc_symbol* sym;
- sym = e->symtree->n.sym;
- if (!gfc_is_intrinsic (sym, 0, e->where)
- || (m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES)
- {
- gfc_error ("Function '%s' in initialization expression at %L "
- "must be an intrinsic or a specification function",
- e->symtree->n.sym->name, &e->where);
- break;
- }
+ sym = e->symtree->n.sym;
+ if (!gfc_is_intrinsic (sym, 0, e->where)
+ || (m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES)
+ {
+ gfc_error ("Function '%s' in initialization expression at %L "
+ "must be an intrinsic function",
+ e->symtree->n.sym->name, &e->where);
+ break;
+ }
- if ((m = check_conversion (e)) == MATCH_NO
- && (m = check_inquiry (e, 1)) == MATCH_NO
- && (m = check_null (e)) == MATCH_NO
- && (m = check_transformational (e)) == MATCH_NO
- && (m = check_elemental (e)) == MATCH_NO)
- {
- gfc_error ("Intrinsic function '%s' at %L is not permitted "
- "in an initialization expression",
- e->symtree->n.sym->name, &e->where);
- m = MATCH_ERROR;
- }
+ if ((m = check_conversion (e)) == MATCH_NO
+ && (m = check_inquiry (e, 1)) == MATCH_NO
+ && (m = check_null (e)) == MATCH_NO
+ && (m = check_transformational (e)) == MATCH_NO
+ && (m = check_elemental (e)) == MATCH_NO)
+ {
+ gfc_error ("Intrinsic function '%s' at %L is not permitted "
+ "in an initialization expression",
+ e->symtree->n.sym->name, &e->where);
+ m = MATCH_ERROR;
+ }
- /* Try to scalarize an elemental intrinsic function that has an
- array argument. */
- isym = gfc_find_function (e->symtree->n.sym->name);
- if (isym && isym->elemental
- && (t = scalarize_intrinsic_call (e)) == SUCCESS)
- break;
- }
+ /* Try to scalarize an elemental intrinsic function that has an
+ array argument. */
+ isym = gfc_find_function (e->symtree->n.sym->name);
+ if (isym && isym->elemental
+ && (t = scalarize_intrinsic_call (e)) == SUCCESS)
+ break;
+ }
if (m == MATCH_YES)
t = gfc_simplify_expr (e, 0);
break;
case EXPR_STRUCTURE:
- if (e->ts.is_iso_c)
- t = SUCCESS;
- else
- t = gfc_check_constructor (e, check_init_expr);
+ t = e->ts.is_iso_c ? SUCCESS : FAILURE;
+ if (t == SUCCESS)
+ break;
+
+ t = check_alloc_comp_init (e);
+ if (t == FAILURE)
+ break;
+
+ t = gfc_check_constructor (e, check_init_expr);
+ if (t == FAILURE)
+ break;
+
break;
case EXPR_ARRAY:
if (t == FAILURE)
return FAILURE;
- if (expr->expr_type == EXPR_ARRAY
- && (gfc_check_constructor_type (expr) == FAILURE
- || gfc_expand_constructor (expr) == FAILURE))
- return FAILURE;
-
- /* Not all inquiry functions are simplified to constant expressions
- so it is necessary to call check_inquiry again. */
- if (!gfc_is_constant_expr (expr) && check_inquiry (expr, 1) != MATCH_YES
- && !gfc_in_match_data ())
+ if (expr->expr_type == EXPR_ARRAY)
{
- gfc_error ("Initialization expression didn't reduce %C");
- return FAILURE;
+ if (gfc_check_constructor_type (expr) == FAILURE)
+ return FAILURE;
+ if (gfc_expand_constructor (expr) == FAILURE)
+ return FAILURE;
}
return SUCCESS;
}
}
- if (sym->attr.cray_pointee
- && lvalue->ref != NULL
- && lvalue->ref->u.ar.type == AR_FULL
- && lvalue->ref->u.ar.as->cp_was_assumed)
- {
- gfc_error ("Vector assignment to assumed-size Cray Pointee at %L "
- "is illegal", &lvalue->where);
- return FAILURE;
- }
-
/* This is possibly a typo: x = f() instead of x => f(). */
if (gfc_option.warn_surprising
&& rvalue->expr_type == EXPR_FUNCTION
return FAILURE;
}
- if (!pointer && !proc_pointer)
+ if (!pointer && !proc_pointer
+ && !(lvalue->ts.type == BT_CLASS
+ && lvalue->ts.u.derived->components->attr.pointer))
{
gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where);
return FAILURE;
if (proc_pointer)
{
char err[200];
+ gfc_symbol *s1,*s2;
+ gfc_component *comp;
+ const char *name;
+
attr = gfc_expr_attr (rvalue);
if (!((rvalue->expr_type == EXPR_NULL)
|| (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer)
&& lvalue->symtree->n.sym->attr.ext_attr
!= rvalue->symtree->n.sym->attr.ext_attr)
{
- symbol_attribute cdecl, stdcall, fastcall;
- unsigned calls;
+ symbol_attribute calls;
- gfc_add_ext_attribute (&cdecl, (unsigned) EXT_ATTR_CDECL, NULL);
- gfc_add_ext_attribute (&stdcall, (unsigned) EXT_ATTR_STDCALL, NULL);
- gfc_add_ext_attribute (&fastcall, (unsigned) EXT_ATTR_FASTCALL, NULL);
- calls = cdecl.ext_attr | stdcall.ext_attr | fastcall.ext_attr;
+ calls.ext_attr = 0;
+ gfc_add_ext_attribute (&calls, EXT_ATTR_CDECL, NULL);
+ gfc_add_ext_attribute (&calls, EXT_ATTR_STDCALL, NULL);
+ gfc_add_ext_attribute (&calls, EXT_ATTR_FASTCALL, NULL);
- if ((calls & lvalue->symtree->n.sym->attr.ext_attr)
- != (calls & rvalue->symtree->n.sym->attr.ext_attr))
+ if ((calls.ext_attr & lvalue->symtree->n.sym->attr.ext_attr)
+ != (calls.ext_attr & rvalue->symtree->n.sym->attr.ext_attr))
{
gfc_error ("Mismatch in the procedure pointer assignment "
"at %L: mismatch in the calling convention",
}
}
- /* TODO: Enable interface check for PPCs. */
- if (gfc_is_proc_ptr_comp (rvalue, NULL))
- return SUCCESS;
- if ((rvalue->expr_type == EXPR_VARIABLE
- && !gfc_compare_interfaces (lvalue->symtree->n.sym,
- rvalue->symtree->n.sym, 0, 1, err,
- sizeof(err)))
- || (rvalue->expr_type == EXPR_FUNCTION
- && !gfc_compare_interfaces (lvalue->symtree->n.sym,
- rvalue->symtree->n.sym->result, 0, 1,
- err, sizeof(err))))
+ if (gfc_is_proc_ptr_comp (lvalue, &comp))
+ s1 = comp->ts.interface;
+ else
+ s1 = lvalue->symtree->n.sym;
+
+ if (gfc_is_proc_ptr_comp (rvalue, &comp))
+ {
+ s2 = comp->ts.interface;
+ name = comp->name;
+ }
+ else if (rvalue->expr_type == EXPR_FUNCTION)
+ {
+ s2 = rvalue->symtree->n.sym->result;
+ name = rvalue->symtree->n.sym->result->name;
+ }
+ else
+ {
+ s2 = rvalue->symtree->n.sym;
+ name = rvalue->symtree->n.sym->name;
+ }
+
+ if (s1 && s2 && !gfc_compare_interfaces (s1, s2, name, 0, 1,
+ err, sizeof(err)))
{
gfc_error ("Interface mismatch in procedure pointer assignment "
"at %L: %s", &rvalue->where, err);
return FAILURE;
}
+
return SUCCESS;
}
return FAILURE;
}
- if (lvalue->ts.kind != rvalue->ts.kind)
+ if (lvalue->ts.type != BT_CLASS && lvalue->ts.kind != rvalue->ts.kind)
{
gfc_error ("Different kind type parameters in pointer "
"assignment at %L", &lvalue->where);
lvalue.symtree->n.sym = sym;
lvalue.where = sym->declared_at;
- if (sym->attr.pointer || sym->attr.proc_pointer)
+ if (sym->attr.pointer || sym->attr.proc_pointer
+ || (sym->ts.type == BT_CLASS
+ && sym->ts.u.derived->components->attr.pointer
+ && rvalue->expr_type == EXPR_NULL))
r = gfc_check_pointer_assign (&lvalue, rvalue);
else
r = gfc_check_assign (&lvalue, rvalue, 1);
gfc_component *c;
/* See if we have a default initializer. */
- for (c = ts->derived->components; c; c = c->next)
+ for (c = ts->u.derived->components; c; c = c->next)
if (c->initializer || c->attr.allocatable)
break;
init = gfc_get_expr ();
init->expr_type = EXPR_STRUCTURE;
init->ts = *ts;
- init->where = ts->derived->declared_at;
+ init->where = ts->u.derived->declared_at;
tail = NULL;
- for (c = ts->derived->components; c; c = c->next)
+ for (c = ts->u.derived->components; c; c = c->next)
{
if (tail == NULL)
init->value.constructor = tail = gfc_get_constructor ();
}
+/* Returns the array_spec of a full array expression. A NULL is
+ returned otherwise. */
+gfc_array_spec *
+gfc_get_full_arrayspec_from_expr (gfc_expr *expr)
+{
+ gfc_array_spec *as;
+ gfc_ref *ref;
+
+ if (expr->rank == 0)
+ return NULL;
+
+ /* Follow any component references. */
+ if (expr->expr_type == EXPR_VARIABLE
+ || expr->expr_type == EXPR_CONSTANT)
+ {
+ as = expr->symtree->n.sym->as;
+ for (ref = expr->ref; ref; ref = ref->next)
+ {
+ switch (ref->type)
+ {
+ case REF_COMPONENT:
+ as = ref->u.c.component->as;
+ continue;
+
+ case REF_SUBSTRING:
+ continue;
+
+ case REF_ARRAY:
+ {
+ switch (ref->u.ar.type)
+ {
+ case AR_ELEMENT:
+ case AR_SECTION:
+ case AR_UNKNOWN:
+ as = NULL;
+ continue;
+
+ case AR_FULL:
+ break;
+ }
+ break;
+ }
+ }
+ }
+ }
+ else
+ as = NULL;
+
+ return as;
+}
+
+
/* General expression traversal function. */
bool
return true;
if (expr->ts.type == BT_CHARACTER
- && expr->ts.cl
- && expr->ts.cl->length
- && expr->ts.cl->length->expr_type != EXPR_CONSTANT
- && gfc_traverse_expr (expr->ts.cl->length, sym, func, f))
+ && expr->ts.u.cl
+ && expr->ts.u.cl->length
+ && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT
+ && gfc_traverse_expr (expr->ts.u.cl->length, sym, func, f))
return true;
switch (expr->expr_type)
case REF_COMPONENT:
if (ref->u.c.component->ts.type == BT_CHARACTER
- && ref->u.c.component->ts.cl
- && ref->u.c.component->ts.cl->length
- && ref->u.c.component->ts.cl->length->expr_type
+ && ref->u.c.component->ts.u.cl
+ && ref->u.c.component->ts.u.cl->length
+ && ref->u.c.component->ts.u.cl->length->expr_type
!= EXPR_CONSTANT
- && gfc_traverse_expr (ref->u.c.component->ts.cl->length,
+ && gfc_traverse_expr (ref->u.c.component->ts.u.cl->length,
sym, func, f))
return true;
OSDN Git Service
