/* These are flags for identifying whether we are reading a character literal
between quotes or normal source code. */
-
+
typedef enum
{ NONSTRING = 0, INSTRING_WARN, INSTRING_NOWARN }
gfc_instring;
INTRINSIC_AND, INTRINSIC_OR, INTRINSIC_EQV, INTRINSIC_NEQV,
/* ==, /=, >, >=, <, <= */
INTRINSIC_EQ, INTRINSIC_NE, INTRINSIC_GT, INTRINSIC_GE,
- INTRINSIC_LT, INTRINSIC_LE,
+ INTRINSIC_LT, INTRINSIC_LE,
/* .EQ., .NE., .GT., .GE., .LT., .LE. (OS = Old-Style) */
INTRINSIC_EQ_OS, INTRINSIC_NE_OS, INTRINSIC_GT_OS, INTRINSIC_GE_OS,
- INTRINSIC_LT_OS, INTRINSIC_LE_OS,
- INTRINSIC_NOT, INTRINSIC_USER, INTRINSIC_ASSIGN,
+ INTRINSIC_LT_OS, INTRINSIC_LE_OS,
+ INTRINSIC_NOT, INTRINSIC_USER, INTRINSIC_ASSIGN,
INTRINSIC_PARENTHESES, GFC_INTRINSIC_END /* Sentinel */
}
gfc_intrinsic_op;
ST_INQUIRE, ST_INTERFACE, ST_SYNC_ALL, ST_SYNC_MEMORY, ST_SYNC_IMAGES,
ST_PARAMETER, ST_MODULE, ST_MODULE_PROC, ST_NAMELIST, ST_NULLIFY, ST_OPEN,
ST_PAUSE, ST_PRIVATE, ST_PROGRAM, ST_PUBLIC, ST_READ, ST_RETURN, ST_REWIND,
- ST_STOP, ST_SUBROUTINE, ST_TYPE, ST_USE, ST_WHERE_BLOCK, ST_WHERE, ST_WAIT,
+ ST_STOP, ST_SUBROUTINE, ST_TYPE, ST_USE, ST_WHERE_BLOCK, ST_WHERE, ST_WAIT,
ST_WRITE, ST_ASSIGNMENT, ST_POINTER_ASSIGNMENT, ST_SELECT_CASE, ST_SEQUENCE,
ST_SIMPLE_IF, ST_STATEMENT_FUNCTION, ST_DERIVED_DECL, ST_LABEL_ASSIGNMENT,
ST_ENUM, ST_ENUMERATOR, ST_END_ENUM, ST_SELECT_TYPE, ST_TYPE_IS, ST_CLASS_IS,
#define NAMED_FUNCTION(a,b,c,d) a,
typedef enum
{
- ISOCBINDING_INVALID = -1,
+ ISOCBINDING_INVALID = -1,
#include "iso-c-binding.def"
ISOCBINDING_LAST,
ISOCBINDING_NUMBER = ISOCBINDING_LAST
use_only:1, /* Symbol has been use-associated, with ONLY. */
use_rename:1, /* Symbol has been use-associated and renamed. */
imported:1, /* Symbol has been associated by IMPORT. */
- host_assoc:1; /* Symbol has been host associated. */
+ host_assoc:1; /* Symbol has been host associated. */
unsigned in_namelist:1, in_common:1, in_equivalence:1;
unsigned function:1, subroutine:1, procedure:1;
/* Special attributes for Cray pointers, pointees. */
unsigned cray_pointer:1, cray_pointee:1;
- /* The symbol is a derived type with allocatable components, pointer
+ /* The symbol is a derived type with allocatable components, pointer
components or private components, procedure pointer components,
possibly nested. zero_comp is true if the derived type has no
- component at all. */
+ component at all. defined_assign_comp is true if the derived
+ type or a (sub-)component has a typebound defined assignment. */
unsigned alloc_comp:1, pointer_comp:1, proc_pointer_comp:1,
- private_comp:1, zero_comp:1, coarray_comp:1, lock_comp:1;
+ private_comp:1, zero_comp:1, coarray_comp:1, lock_comp:1,
+ defined_assign_comp:1;
/* This is a temporary selector for SELECT TYPE. */
unsigned select_type_temporary:1;
struct gfc_namespace *ns; /* namespace containing this symbol */
tree backend_decl;
-
+
/* Identity of the intrinsic module the symbol comes from, or
INTMOD_NONE if it's not imported from a intrinsic module. */
intmod_id from_intmod;
const char *name, *lib_name;
gfc_intrinsic_arg *formal;
gfc_typespec ts;
- unsigned elemental:1, inquiry:1, transformational:1, pure:1,
+ unsigned elemental:1, inquiry:1, transformational:1, pure:1,
generic:1, specific:1, actual_ok:1, noreturn:1, conversion:1,
from_module:1;
/* Sometimes, when an error has been emitted, it is necessary to prevent
it from recurring. */
unsigned int error : 1;
-
+
/* Mark an expression where a user operator has been substituted by
a function call in interface.c(gfc_extend_expr). */
unsigned int user_operator : 1;
/* Mark an expression as being a MOLD argument of ALLOCATE. */
unsigned int mold : 1;
-
+
/* If an expression comes from a Hollerith constant or compile-time
evaluation of a transfer statement, it may have a prescribed target-
memory representation, and these cannot always be backformed from
typedef struct gfc_association_list
{
- struct gfc_association_list *next;
+ struct gfc_association_list *next;
/* Whether this is association to a variable that can be changed; otherwise,
it's association to an expression and the name may not be used as
still referenced or not for dereferencing it on deleting a gfc_finalizer
structure. */
gfc_symbol* proc_sym;
- gfc_symtree* proc_tree;
+ gfc_symtree* proc_tree;
}
gfc_finalizer;
#define gfc_get_finalizer() XCNEW (gfc_finalizer)
bool gfc_has_default_initializer (gfc_symbol *);
gfc_expr *gfc_default_initializer (gfc_typespec *);
gfc_expr *gfc_get_variable_expr (gfc_symtree *);
+void gfc_add_full_array_ref (gfc_expr *, gfc_array_spec *);
gfc_expr * gfc_lval_expr_from_sym (gfc_symbol *);
gfc_array_spec *gfc_get_full_arrayspec_from_expr (gfc_expr *expr);
is_sym_host_assoc (gfc_symbol *sym, gfc_namespace *ns)
{
for (ns = ns->parent; ns; ns = ns->parent)
- {
+ {
if (sym->ns == ns)
return true;
}
sym->ts = ifc->result->ts;
sym->result = sym;
}
- else
+ else
sym->ts = ifc->ts;
sym->ts.interface = ifc;
sym->attr.function = ifc->attr.function;
}
}
- /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
+ /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
type, lists the only ways a character length value of * can be used:
dummy arguments of procedures, named constants, and function results
in external functions. Internal function results and results of module
return 0;
gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
-
+
if (s != NULL)
{
if (s == sym)
int n;
gfc_interface *p;
gfc_symbol *sym;
-
+
n = 0;
sym = e->symtree->n.sym;
gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
" itself recursively. Declare it RECURSIVE or use"
" -frecursive", sym->name, &expr->where);
-
+
return SUCCESS;
}
else if (c && c->ext.actual != NULL)
{
arg0 = c->ext.actual;
-
+
if (c->resolved_sym)
esym = c->resolved_sym;
else
&& !(gfc_option.warn_std & GFC_STD_GNU)))
gfc_errors_to_warnings (1);
- if (sym->attr.if_source != IFSRC_IFBODY)
+ if (sym->attr.if_source != IFSRC_IFBODY)
gfc_procedure_use (def_sym, actual, where);
gfc_errors_to_warnings (0);
{
/* We have constant lower and upper bounds. If the
difference between is 1, it can be considered a
- scalar.
+ scalar.
FIXME: Use gfc_dep_compare_expr instead. */
start = (int) mpz_get_si
(ref->u.ar.as->lower[0]->value.integer);
the actual expression could be a part-ref of the expr symbol. */
arg_ts = &(args->expr->ts);
arg_attr = gfc_expr_attr (args->expr);
-
+
if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
{
/* If the user gave two args then they are providing something for
if (seen_section && retval == SUCCESS)
gfc_warning ("Array section in '%s' call at %L", name,
&(args->expr->where));
-
+
/* See if we have interoperable type and type param. */
if (gfc_verify_c_interop (arg_ts) == SUCCESS
|| gfc_check_any_c_kind (arg_ts) == SUCCESS)
is not an array of zero size. */
if (args_sym->attr.allocatable == 1)
{
- if (args_sym->attr.dimension != 0
+ if (args_sym->attr.dimension != 0
&& (args_sym->as && args_sym->as->rank == 0))
{
gfc_error_now ("Allocatable variable '%s' used as a "
retval = FAILURE;
}
}
-
+
/* Make sure it's not a character string. Arrays of
any type should be ok if the variable is of a C
interoperable type. */
with no length type parameters. It still must have either
the pointer or target attribute, and it can be
allocatable (but must be allocated when c_loc is called). */
- if (args->expr->rank != 0
+ if (args->expr->rank != 0
&& is_scalar_expr_ptr (args->expr) != SUCCESS)
{
gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
&(args->expr->where));
retval = FAILURE;
}
- else if (arg_ts->type == BT_CHARACTER
+ else if (arg_ts->type == BT_CHARACTER
&& is_scalar_expr_ptr (args->expr) != SUCCESS)
{
gfc_error_now ("CHARACTER argument '%s' to '%s' at "
&(args->expr->where)) == FAILURE)
retval = FAILURE;
}
-
+
/* for c_loc/c_funloc, the new symbol is the same as the old one */
*new_sym = sym;
}
}
inquiry_argument = false;
-
+
/* Need to setup the call to the correct c_associated, depending on
the number of cptrs to user gives to compare. */
if (sym && sym->attr.is_iso_c == 1)
if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
== FAILURE)
return FAILURE;
-
+
/* Get the symtree for the new symbol (resolved func).
the old one will be freed later, when it's no longer used. */
gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
}
-
+
/* Resume assumed_size checking. */
need_full_assumed_size--;
sprintf (name, "%s_%c%d", sym->name, type, kind);
/* Set up the binding label as the given symbol's label plus
the type and kind. */
- *binding_label = gfc_get_string ("%s_%c%d", sym->binding_label, type,
+ *binding_label = gfc_get_string ("%s_%c%d", sym->binding_label, type,
kind);
}
else
sprintf (name, "%s", sym->name);
*binding_label = sym->binding_label;
}
-
+
return;
}
/* default to success; will override if find error */
match m = MATCH_YES;
- /* Make sure the actual arguments are in the necessary order (based on the
+ /* Make sure the actual arguments are in the necessary order (based on the
formal args) before resolving. */
if (gfc_procedure_use (sym, &c->ext.actual, &(c->loc)) == FAILURE)
{
(sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
{
set_name_and_label (c, sym, name, &binding_label);
-
+
if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
{
if (c->ext.actual != NULL && c->ext.actual->next != NULL)
if (arg3 == NULL || arg3->expr == NULL)
{
m = MATCH_ERROR;
- gfc_error ("Missing SHAPE argument for call to %s at %L",
+ gfc_error ("Missing SHAPE argument for call to %s at %L",
sym->name, &c->loc);
}
else if (arg3->expr->ts.type != BT_INTEGER
{
/* the 1 means to add the optional arg to formal list */
new_sym = get_iso_c_sym (sym, name, binding_label, 1);
-
+
/* for error reporting, say it's declared where the original was */
new_sym->declared_at = sym->declared_at;
}
c->resolved_sym = new_sym;
else
c->resolved_sym = sym;
-
+
return m;
}
m = gfc_iso_c_sub_interface (c,sym);
return m;
}
-
+
if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
{
if (sym->attr.dummy)
msg = "Equality comparison for %s at %L";
else
msg = "Inequality comparison for %s at %L";
-
+
gfc_warning (msg, gfc_typename (&op1->ts), &op1->where);
}
}
if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
sprintf (msg,
_("Logicals at %%L must be compared with %s instead of %s"),
- (e->value.op.op == INTRINSIC_EQ
+ (e->value.op.op == INTRINSIC_EQ
|| e->value.op.op == INTRINSIC_EQ_OS)
? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
else
}
-/* Compute the last value of a sequence given by a triplet.
+/* Compute the last value of a sequence given by a triplet.
Return 0 if it wasn't able to compute the last value, or if the
sequence if empty, and 1 otherwise. */
{
gfc_free_expr (e1);
gfc_free_expr (e2);
-
+
return;
}
e->value.function.esym = NULL;
e->symtree = st;
- if (new_ref)
+ if (new_ref)
e->ref = new_ref;
/* '_vptr' points to the vtab, which contains the procedure pointers. */
if (t == SUCCESS && e->ts.type == BT_CHARACTER)
{
/* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
- here rather then add a duplicate test for it above. */
+ here rather then add a duplicate test for it above. */
gfc_expand_constructor (e, false);
t = gfc_resolve_character_array_constructor (e);
}
{
if (expr->expr_type != EXPR_VARIABLE)
return false;
-
+
/* A scalar assignment */
if (!expr->ref || *f == 1)
{
/* Used in resolve_allocate_expr to check that a allocation-object and
- a source-expr are conformable. This does not catch all possible
+ a source-expr are conformable. This does not catch all possible
cases; in particular a runtime checking is needed. */
static gfc_try
{
gfc_ref *tail;
for (tail = e2->ref; tail && tail->next; tail = tail->next);
-
+
/* First compare rank. */
if (tail && e1->rank != tail->u.ar.as->rank)
{
using _copy and trans_call. It is convenient to exploit that
when the allocated type is different from the declared type but
no SOURCE exists by setting expr3. */
- code->expr3 = gfc_default_initializer (&code->ext.alloc.ts);
+ code->expr3 = gfc_default_initializer (&code->ext.alloc.ts);
}
else if (!code->expr3)
{
/* This is a potential collision. */
gfc_ref *pr = pe->ref;
gfc_ref *qr = qe->ref;
-
+
/* Follow the references until
a) They start to differ, in which case there is no error;
you can deallocate a%b and a%c in a single statement
if (pr->next && qr->next)
{
- int i;
gfc_array_ref *par = &(pr->u.ar);
gfc_array_ref *qar = &(qr->u.ar);
-
- for (i=0; i<par->dimen; i++)
- {
- if ((par->start[i] != NULL
- || qar->start[i] != NULL)
- && gfc_dep_compare_expr (par->start[i],
- qar->start[i]) != 0)
- goto break_label;
- }
+ if ((par->start[0] != NULL || qar->start[0] != NULL)
+ && gfc_dep_compare_expr (par->start[0],
+ qar->start[0]) != 0)
+ break;
}
}
else
if (pr->u.c.component->name != qr->u.c.component->name)
break;
}
-
+
pr = pr->next;
qr = qr->next;
}
- break_label:
- ;
}
}
}
/* Callback function for our mergesort variant. Determines interval
overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
- op1 > op2. Assumes we're not dealing with the default case.
+ op1 > op2. Assumes we're not dealing with the default case.
We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
There are nine situations to check. */
default_case = body;
}
}
-
+
if (error > 0)
return;
assoc->target = gfc_copy_expr (code->expr2);
assoc->target->where = code->expr2->where;
/* assoc->variable will be set by resolve_assoc_var. */
-
+
code->ext.block.assoc = assoc;
code->expr1->symtree->n.sym->assoc = assoc;
resolve_assoc_var (st->n.sym, false);
}
-
+
/* Take out CLASS IS cases for separate treatment. */
body = code;
while (body && body->block)
{
/* Add to class_is list. */
if (class_is == NULL)
- {
+ {
class_is = body->block;
tail = class_is;
}
if (class_is)
{
gfc_symbol *vtab;
-
+
if (!default_case)
{
/* Add a default case to hold the CLASS IS cases. */
}
while (swapped);
}
-
+
/* Generate IF chain. */
if_st = gfc_get_code ();
if_st->op = EXEC_IF;
new_st->op = EXEC_IF;
new_st->next = default_case->next;
}
-
+
/* Replace CLASS DEFAULT code by the IF chain. */
default_case->next = if_st;
}
/* Resolve a transfer statement. This is making sure that:
-- a derived type being transferred has only non-pointer components
- -- a derived type being transferred doesn't have private components, unless
+ -- a derived type being transferred doesn't have private components, unless
it's being transferred from the module where the type was defined
-- we're not trying to transfer a whole assumed size array. */
/* Find the set of labels that are reachable from this block. We also
record the last statement in each block. */
-
+
static void
find_reachable_labels (gfc_code *block)
{
"inconsistent shape", &cnext->expr1->where);
break;
-
+
case EXEC_ASSIGN_CALL:
resolve_call (cnext);
if (!cnext->resolved_sym->attr.elemental)
case EXEC_ASSIGN:
gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
break;
-
+
/* WHERE operator assignment statement */
case EXEC_ASSIGN_CALL:
resolve_call (cnext);
/* Counts the number of iterators needed inside a forall construct, including
- nested forall constructs. This is used to allocate the needed memory
+ nested forall constructs. This is used to allocate the needed memory
in gfc_resolve_forall. */
-static int
+static int
gfc_count_forall_iterators (gfc_code *code)
{
int max_iters, sub_iters, current_iters;
for (fa = code->ext.forall_iterator; fa; fa = fa->next)
current_iters ++;
-
+
code = code->block->next;
while (code)
- {
+ {
if (code->op == EXEC_FORALL)
{
sub_iters = gfc_count_forall_iterators (code);
}
+/* Add a component reference onto an expression. */
+
+static void
+add_comp_ref (gfc_expr *e, gfc_component *c)
+{
+ gfc_ref **ref;
+ ref = &(e->ref);
+ while (*ref)
+ ref = &((*ref)->next);
+ *ref = gfc_get_ref ();
+ (*ref)->type = REF_COMPONENT;
+ (*ref)->u.c.sym = e->ts.u.derived;
+ (*ref)->u.c.component = c;
+ e->ts = c->ts;
+
+ /* Add a full array ref, as necessary. */
+ if (c->as)
+ {
+ gfc_add_full_array_ref (e, c->as);
+ e->rank = c->as->rank;
+ }
+}
+
+
+/* Build an assignment. Keep the argument 'op' for future use, so that
+ pointer assignments can be made. */
+
+static gfc_code *
+build_assignment (gfc_exec_op op, gfc_expr *expr1, gfc_expr *expr2,
+ gfc_component *comp1, gfc_component *comp2, locus loc)
+{
+ gfc_code *this_code;
+
+ this_code = gfc_get_code ();
+ this_code->op = op;
+ this_code->next = NULL;
+ this_code->expr1 = gfc_copy_expr (expr1);
+ this_code->expr2 = gfc_copy_expr (expr2);
+ this_code->loc = loc;
+ if (comp1 && comp2)
+ {
+ add_comp_ref (this_code->expr1, comp1);
+ add_comp_ref (this_code->expr2, comp2);
+ }
+
+ return this_code;
+}
+
+
+/* Makes a temporary variable expression based on the characteristics of
+ a given variable expression. */
+
+static gfc_expr*
+get_temp_from_expr (gfc_expr *e, gfc_namespace *ns)
+{
+ static int serial = 0;
+ char name[GFC_MAX_SYMBOL_LEN];
+ gfc_symtree *tmp;
+ gfc_array_spec *as;
+ gfc_array_ref *aref;
+ gfc_ref *ref;
+
+ sprintf (name, "DA@%d", serial++);
+ gfc_get_sym_tree (name, ns, &tmp, false);
+ gfc_add_type (tmp->n.sym, &e->ts, NULL);
+
+ as = NULL;
+ ref = NULL;
+ aref = NULL;
+
+ /* This function could be expanded to support other expression type
+ but this is not needed here. */
+ gcc_assert (e->expr_type == EXPR_VARIABLE);
+
+ /* Obtain the arrayspec for the temporary. */
+ if (e->rank)
+ {
+ aref = gfc_find_array_ref (e);
+ if (e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->as == aref->as)
+ as = aref->as;
+ else
+ {
+ for (ref = e->ref; ref; ref = ref->next)
+ if (ref->type == REF_COMPONENT
+ && ref->u.c.component->as == aref->as)
+ {
+ as = aref->as;
+ break;
+ }
+ }
+ }
+
+ /* Add the attributes and the arrayspec to the temporary. */
+ tmp->n.sym->attr = gfc_expr_attr (e);
+ if (as)
+ {
+ tmp->n.sym->as = gfc_copy_array_spec (as);
+ if (!ref)
+ ref = e->ref;
+ if (as->type == AS_DEFERRED)
+ tmp->n.sym->attr.allocatable = 1;
+ }
+ else
+ tmp->n.sym->attr.dimension = 0;
+
+ gfc_set_sym_referenced (tmp->n.sym);
+ gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
+ e = gfc_lval_expr_from_sym (tmp->n.sym);
+
+ /* Should the lhs be a section, use its array ref for the
+ temporary expression. */
+ if (aref && aref->type != AR_FULL)
+ {
+ gfc_free_ref_list (e->ref);
+ e->ref = gfc_copy_ref (ref);
+ }
+ return e;
+}
+
+
+/* Add one line of code to the code chain, making sure that 'head' and
+ 'tail' are appropriately updated. */
+
+static void
+add_code_to_chain (gfc_code **this_code, gfc_code **head, gfc_code **tail)
+{
+ gcc_assert (this_code);
+ if (*head == NULL)
+ *head = *tail = *this_code;
+ else
+ *tail = gfc_append_code (*tail, *this_code);
+ *this_code = NULL;
+}
+
+
+/* Counts the potential number of part array references that would
+ result from resolution of typebound defined assignments. */
+
+static int
+nonscalar_typebound_assign (gfc_symbol *derived, int depth)
+{
+ gfc_component *c;
+ int c_depth = 0, t_depth;
+
+ for (c= derived->components; c; c = c->next)
+ {
+ if ((c->ts.type != BT_DERIVED
+ || c->attr.pointer
+ || c->attr.allocatable
+ || c->attr.proc_pointer_comp
+ || c->attr.class_pointer
+ || c->attr.proc_pointer)
+ && !c->attr.defined_assign_comp)
+ continue;
+
+ if (c->as && c_depth == 0)
+ c_depth = 1;
+
+ if (c->ts.u.derived->attr.defined_assign_comp)
+ t_depth = nonscalar_typebound_assign (c->ts.u.derived,
+ c->as ? 1 : 0);
+ else
+ t_depth = 0;
+
+ c_depth = t_depth > c_depth ? t_depth : c_depth;
+ }
+ return depth + c_depth;
+}
+
+
+/* Implement 7.2.1.3 of the F08 standard:
+ "An intrinsic assignment where the variable is of derived type is
+ performed as if each component of the variable were assigned from the
+ corresponding component of expr using pointer assignment (7.2.2) for
+ each pointer component, defined assignment for each nonpointer
+ nonallocatable component of a type that has a type-bound defined
+ assignment consistent with the component, intrinsic assignment for
+ each other nonpointer nonallocatable component, ..."
+
+ The pointer assignments are taken care of by the intrinsic
+ assignment of the structure itself. This function recursively adds
+ defined assignments where required. The recursion is accomplished
+ by calling resolve_code.
+
+ When the lhs in a defined assignment has intent INOUT, we need a
+ temporary for the lhs. In pseudo-code:
+
+ ! Only call function lhs once.
+ if (lhs is not a constant or an variable)
+ temp_x = expr2
+ expr2 => temp_x
+ ! Do the intrinsic assignment
+ expr1 = expr2
+ ! Now do the defined assignments
+ do over components with typebound defined assignment [%cmp]
+ #if one component's assignment procedure is INOUT
+ t1 = expr1
+ #if expr2 non-variable
+ temp_x = expr2
+ expr2 => temp_x
+ # endif
+ expr1 = expr2
+ # for each cmp
+ t1%cmp {defined=} expr2%cmp
+ expr1%cmp = t1%cmp
+ #else
+ expr1 = expr2
+
+ # for each cmp
+ expr1%cmp {defined=} expr2%cmp
+ #endif
+ */
+
+/* The temporary assignments have to be put on top of the additional
+ code to avoid the result being changed by the intrinsic assignment.
+ */
+static int component_assignment_level = 0;
+static gfc_code *tmp_head = NULL, *tmp_tail = NULL;
+
+static void
+generate_component_assignments (gfc_code **code, gfc_namespace *ns)
+{
+ gfc_component *comp1, *comp2;
+ gfc_code *this_code = NULL, *head = NULL, *tail = NULL;
+ gfc_expr *t1;
+ int error_count, depth;
+
+ gfc_get_errors (NULL, &error_count);
+
+ /* Filter out continuing processing after an error. */
+ if (error_count
+ || (*code)->expr1->ts.type != BT_DERIVED
+ || (*code)->expr2->ts.type != BT_DERIVED)
+ return;
+
+ /* TODO: Handle more than one part array reference in assignments. */
+ depth = nonscalar_typebound_assign ((*code)->expr1->ts.u.derived,
+ (*code)->expr1->rank ? 1 : 0);
+ if (depth > 1)
+ {
+ gfc_warning ("TODO: type-bound defined assignment(s) at %L not "
+ "done because multiple part array references would "
+ "occur in intermediate expressions.", &(*code)->loc);
+ return;
+ }
+
+ component_assignment_level++;
+
+ /* Create a temporary so that functions get called only once. */
+ if ((*code)->expr2->expr_type != EXPR_VARIABLE
+ && (*code)->expr2->expr_type != EXPR_CONSTANT)
+ {
+ gfc_expr *tmp_expr;
+
+ /* Assign the rhs to the temporary. */
+ tmp_expr = get_temp_from_expr ((*code)->expr1, ns);
+ this_code = build_assignment (EXEC_ASSIGN,
+ tmp_expr, (*code)->expr2,
+ NULL, NULL, (*code)->loc);
+ /* Add the code and substitute the rhs expression. */
+ add_code_to_chain (&this_code, &tmp_head, &tmp_tail);
+ gfc_free_expr ((*code)->expr2);
+ (*code)->expr2 = tmp_expr;
+ }
+
+ /* Do the intrinsic assignment. This is not needed if the lhs is one
+ of the temporaries generated here, since the intrinsic assignment
+ to the final result already does this. */
+ if ((*code)->expr1->symtree->n.sym->name[2] != '@')
+ {
+ this_code = build_assignment (EXEC_ASSIGN,
+ (*code)->expr1, (*code)->expr2,
+ NULL, NULL, (*code)->loc);
+ add_code_to_chain (&this_code, &head, &tail);
+ }
+
+ comp1 = (*code)->expr1->ts.u.derived->components;
+ comp2 = (*code)->expr2->ts.u.derived->components;
+
+ t1 = NULL;
+ for (; comp1; comp1 = comp1->next, comp2 = comp2->next)
+ {
+ bool inout = false;
+
+ /* The intrinsic assignment does the right thing for pointers
+ of all kinds and allocatable components. */
+ if (comp1->ts.type != BT_DERIVED
+ || comp1->attr.pointer
+ || comp1->attr.allocatable
+ || comp1->attr.proc_pointer_comp
+ || comp1->attr.class_pointer
+ || comp1->attr.proc_pointer)
+ continue;
+
+ /* Make an assigment for this component. */
+ this_code = gfc_get_code ();
+ this_code = build_assignment (EXEC_ASSIGN,
+ (*code)->expr1, (*code)->expr2,
+ comp1, comp2, (*code)->loc);
+
+ /* Convert the assignment if there is a defined assignment for
+ this type. Otherwise, using the call from resolve_code,
+ recurse into its components. */
+ resolve_code (this_code, ns);
+
+ if (this_code->op == EXEC_ASSIGN_CALL)
+ {
+ gfc_symbol *rsym;
+ /* Check that there is a typebound defined assignment. If not,
+ then this must be a module defined assignment. We cannot
+ use the defined_assign_comp attribute here because it must
+ be this derived type that has the defined assignment and not
+ a parent type. */
+ if (!(comp1->ts.u.derived->f2k_derived
+ && comp1->ts.u.derived->f2k_derived
+ ->tb_op[INTRINSIC_ASSIGN]))
+ {
+ gfc_free_statements (this_code);
+ this_code = NULL;
+ continue;
+ }
+
+ /* If the first argument of the subroutine has intent INOUT
+ a temporary must be generated and used instead. */
+ rsym = this_code->resolved_sym;
+ if (rsym->formal
+ && rsym->formal->sym->attr.intent == INTENT_INOUT)
+ {
+ gfc_code *temp_code;
+ inout = true;
+
+ /* Build the temporary required for the assignment and put
+ it at the head of the generated code. */
+ if (!t1)
+ {
+ t1 = get_temp_from_expr ((*code)->expr1, ns);
+ temp_code = build_assignment (EXEC_ASSIGN,
+ t1, (*code)->expr1,
+ NULL, NULL, (*code)->loc);
+ add_code_to_chain (&temp_code, &tmp_head, &tmp_tail);
+ }
+
+ /* Replace the first actual arg with the component of the
+ temporary. */
+ gfc_free_expr (this_code->ext.actual->expr);
+ this_code->ext.actual->expr = gfc_copy_expr (t1);
+ add_comp_ref (this_code->ext.actual->expr, comp1);
+ }
+ }
+ else if (this_code->op == EXEC_ASSIGN && !this_code->next)
+ {
+ /* Don't add intrinsic assignments since they are already
+ effected by the intrinsic assignment of the structure. */
+ gfc_free_statements (this_code);
+ this_code = NULL;
+ continue;
+ }
+
+ add_code_to_chain (&this_code, &head, &tail);
+
+ if (t1 && inout)
+ {
+ /* Transfer the value to the final result. */
+ this_code = build_assignment (EXEC_ASSIGN,
+ (*code)->expr1, t1,
+ comp1, comp2, (*code)->loc);
+ add_code_to_chain (&this_code, &head, &tail);
+ }
+ }
+
+ /* This is probably not necessary. */
+ if (this_code)
+ {
+ gfc_free_statements (this_code);
+ this_code = NULL;
+ }
+
+ /* Put the temporary assignments at the top of the generated code. */
+ if (tmp_head && component_assignment_level == 1)
+ {
+ gfc_append_code (tmp_head, head);
+ head = tmp_head;
+ tmp_head = tmp_tail = NULL;
+ }
+
+ /* Now attach the remaining code chain to the input code. Step on
+ to the end of the new code since resolution is complete. */
+ gcc_assert ((*code)->op == EXEC_ASSIGN);
+ tail->next = (*code)->next;
+ /* Overwrite 'code' because this would place the intrinsic assignment
+ before the temporary for the lhs is created. */
+ gfc_free_expr ((*code)->expr1);
+ gfc_free_expr ((*code)->expr2);
+ **code = *head;
+ free (head);
+ *code = tail;
+
+ component_assignment_level--;
+}
+
+
/* Given a block of code, recursively resolve everything pointed to by this
code block. */
else
goto call;
}
+
+ /* F03 7.4.1.3 for non-allocatable, non-pointer components. */
+ if (code->expr1->ts.type == BT_DERIVED
+ && code->expr1->ts.u.derived->attr.defined_assign_comp)
+ generate_component_assignments (&code, ns);
+
break;
case EXEC_LABEL_ASSIGN:
if (sym->value->expr_type == EXPR_STRUCTURE)
t= resolve_structure_cons (sym->value, 1);
- else
+ else
t = gfc_resolve_expr (sym->value);
if (t == FAILURE)
{
gfc_gsymbol *binding_label_gsym;
gfc_gsymbol *comm_name_gsym;
- const char * bind_label = comm_block_tree->n.common->binding_label
+ const char * bind_label = comm_block_tree->n.common->binding_label
? comm_block_tree->n.common->binding_label : "";
/* See if a global symbol exists by the common block's name. It may
check and nothing to add as a global symbol for the label. */
if (!comm_block_tree->n.common->binding_label)
return;
-
+
binding_label_gsym =
gfc_find_gsymbol (gfc_gsym_root,
comm_block_tree->n.common->binding_label);
comm_name_gsym->name, &(comm_name_gsym->where));
}
}
-
+
return;
}
if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
&& derived_sym->attr.is_bind_c == 1)
verify_bind_c_derived_type (derived_sym);
-
+
return;
}
-/* Verify that any binding labels used in a given namespace do not collide
+/* Verify that any binding labels used in a given namespace do not collide
with the names or binding labels of any global symbols. */
static void
gfc_verify_binding_labels (gfc_symbol *sym)
{
int has_error = 0;
-
- if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
+
+ if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
&& sym->attr.flavor != FL_DERIVED && sym->binding_label)
{
gfc_gsymbol *bind_c_sym;
bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
- if (bind_c_sym != NULL
+ if (bind_c_sym != NULL
&& strcmp (bind_c_sym->name, sym->binding_label) == 0)
{
- if (sym->attr.if_source == IFSRC_DECL
- && (bind_c_sym->type != GSYM_SUBROUTINE
- && bind_c_sym->type != GSYM_FUNCTION)
- && ((sym->attr.contained == 1
- && strcmp (bind_c_sym->sym_name, sym->name) != 0)
- || (sym->attr.use_assoc == 1
+ if (sym->attr.if_source == IFSRC_DECL
+ && (bind_c_sym->type != GSYM_SUBROUTINE
+ && bind_c_sym->type != GSYM_FUNCTION)
+ && ((sym->attr.contained == 1
+ && strcmp (bind_c_sym->sym_name, sym->name) != 0)
+ || (sym->attr.use_assoc == 1
&& (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
{
/* Make sure global procedures don't collide with anything. */
&(bind_c_sym->where));
has_error = 1;
}
- else if (sym->attr.contained == 0
- && (sym->attr.if_source == IFSRC_IFBODY
- && sym->attr.flavor == FL_PROCEDURE)
- && (bind_c_sym->sym_name != NULL
+ else if (sym->attr.contained == 0
+ && (sym->attr.if_source == IFSRC_IFBODY
+ && sym->attr.flavor == FL_PROCEDURE)
+ && (bind_c_sym->sym_name != NULL
&& strcmp (bind_c_sym->sym_name, sym->name) != 0))
{
/* Make sure procedures in interface bodies don't collide. */
&(bind_c_sym->where));
has_error = 1;
}
- else if (sym->attr.contained == 0
+ else if (sym->attr.contained == 0
&& sym->attr.if_source == IFSRC_UNKNOWN)
if ((sym->attr.use_assoc && bind_c_sym->mod_name
- && strcmp (bind_c_sym->mod_name, sym->module) != 0)
+ && strcmp (bind_c_sym->mod_name, sym->module) != 0)
|| sym->attr.use_assoc == 0)
{
gfc_error ("Binding label '%s' at %L collides with global "
/* Build an initializer for a local integer, real, complex, logical, or
character variable, based on the command line flags finit-local-zero,
- finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
+ finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
null if the symbol should not have a default initialization. */
static gfc_expr *
build_default_init_expr (gfc_symbol *sym)
characters, and only if the corresponding command-line flags
were set. Otherwise, we free init_expr and return null. */
switch (sym->ts.type)
- {
+ {
case BT_INTEGER:
if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
- mpz_set_si (init_expr->value.integer,
+ mpz_set_si (init_expr->value.integer,
gfc_option.flag_init_integer_value);
else
{
break;
}
break;
-
+
case BT_COMPLEX:
switch (gfc_option.flag_init_real)
{
break;
}
break;
-
+
case BT_LOGICAL:
if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE)
init_expr->value.logical = 0;
init_expr = NULL;
}
break;
-
+
case BT_CHARACTER:
- /* For characters, the length must be constant in order to
+ /* For characters, the length must be constant in order to
create a default initializer. */
if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
&& sym->ts.u.cl->length
init_expr->value.function.actual = arg;
}
break;
-
+
default:
gfc_free_expr (init_expr);
init_expr = NULL;
/* For saved variables, we don't want to add an initializer at function
entry, so we just add a static initializer. Note that automatic variables
are stack allocated even with -fno-automatic. */
- if (sym->attr.save || sym->ns->save_all
+ if (sym->attr.save || sym->ns->save_all
|| (gfc_option.flag_max_stack_var_size == 0
&& (!sym->attr.dimension || !is_non_constant_shape_array (sym))))
{
return FAILURE;
}
}
-
+
return SUCCESS;
}
sym->attr.is_c_interop = 1;
sym->ts.is_c_interop = 1;
}
-
+
curr_arg = sym->formal;
while (curr_arg != NULL)
{
BIND(C) to try and prevent multiple errors being
reported. */
has_non_interop_arg = 1;
-
+
curr_arg = curr_arg->next;
}
sym->attr.is_bind_c = 0;
}
}
-
+
if (!sym->attr.proc_pointer)
{
if (sym->attr.save == SAVE_EXPLICIT)
{
gfc_error ("FINAL procedure '%s' declared at %L has the same"
" rank (%d) as '%s'",
- list->proc_sym->name, &list->where, my_rank,
+ list->proc_sym->name, &list->where, my_rank,
i->proc_sym->name);
goto error;
}
else if (t2->specific->pass_arg)
pass2 = t2->specific->pass_arg;
else
- pass2 = t2->specific->u.specific->n.sym->formal->sym->name;
+ pass2 = t2->specific->u.specific->n.sym->formal->sym->name;
if (gfc_compare_interfaces (sym1, sym2, sym2->name, !t1->is_operator, 0,
NULL, 0, pass1, pass2))
{
{
gfc_symbol* super_type;
gfc_tbp_generic* target;
-
+
/* If there's already an error here, do nothing (but don't fail again). */
if (p->error)
return SUCCESS;
/* Add target to non-typebound operator list. */
if (!target->specific->deferred && !derived->attr.use_assoc
- && p->access != ACCESS_PRIVATE && derived->ns == gfc_current_ns)
+ && p->access != ACCESS_PRIVATE)
{
gfc_interface *head, *intr;
if (gfc_check_new_interface (derived->ns->op[op], target_proc,
me_arg->name, &where, resolve_bindings_derived->name);
goto error;
}
-
+
gcc_assert (me_arg->ts.type == BT_CLASS);
if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank != 0)
{
if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
return SUCCESS;
-
+
super_type = gfc_get_derived_super_type (derived);
if (super_type)
resolve_typebound_procedures (super_type);
clearer than something sophisticated. */
gcc_assert (ancestor && !sub->attr.abstract);
-
+
if (!ancestor->attr.abstract)
return SUCCESS;
}
+/* This check for typebound defined assignments is done recursively
+ since the order in which derived types are resolved is not always in
+ order of the declarations. */
+
+static void
+check_defined_assignments (gfc_symbol *derived)
+{
+ gfc_component *c;
+
+ for (c = derived->components; c; c = c->next)
+ {
+ if (c->ts.type != BT_DERIVED
+ || c->attr.pointer
+ || c->attr.allocatable
+ || c->attr.proc_pointer_comp
+ || c->attr.class_pointer
+ || c->attr.proc_pointer)
+ continue;
+
+ if (c->ts.u.derived->attr.defined_assign_comp
+ || (c->ts.u.derived->f2k_derived
+ && c->ts.u.derived->f2k_derived->tb_op[INTRINSIC_ASSIGN]))
+ {
+ derived->attr.defined_assign_comp = 1;
+ return;
+ }
+
+ check_defined_assignments (c->ts.u.derived);
+ if (c->ts.u.derived->attr.defined_assign_comp)
+ {
+ derived->attr.defined_assign_comp = 1;
+ return;
+ }
+ }
+}
+
+
/* Resolve the components of a derived type. This does not have to wait until
resolution stage, but can be done as soon as the dt declaration has been
parsed. */
c->attr.class_ok = ifc->result->attr.class_ok;
}
else
- {
+ {
c->ts = ifc->ts;
c->attr.allocatable = ifc->attr.allocatable;
c->attr.pointer = ifc->attr.pointer;
|| (!sym->attr.is_class && c == sym->components))
&& strcmp (super_type->name, c->name) == 0)
c->attr.access = super_type->attr.access;
-
+
/* If this type is an extension, see if this component has the same name
as an inherited type-bound procedure. */
if (super_type && !sym->attr.is_class
return FAILURE;
}
+ check_defined_assignments (sym);
+
+ if (!sym->attr.defined_assign_comp && super_type)
+ sym->attr.defined_assign_comp
+ = super_type->attr.defined_assign_comp;
+
/* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
all DEFERRED bindings are overridden. */
if (super_type && super_type->attr.abstract && !sym->attr.abstract
/* Resolve the finalizer procedures. */
if (gfc_resolve_finalizers (sym) == FAILURE)
return FAILURE;
-
+
if (sym->attr.is_class && sym->ts.u.derived == NULL)
{
/* Fix up incomplete CLASS symbols. */
vptr->ts.u.derived = vtab->ts.u.derived;
}
}
-
+
if (resolve_fl_derived0 (sym) == FAILURE)
return FAILURE;
-
+
/* Resolve the type-bound procedures. */
if (resolve_typebound_procedures (sym) == FAILURE)
return FAILURE;
resolve_fl_parameter (gfc_symbol *sym)
{
/* A parameter array's shape needs to be constant. */
- if (sym->as != NULL
+ if (sym->as != NULL
&& (sym->as->type == AS_DEFERRED
|| is_non_constant_shape_array (sym)))
{
can. */
mp_flag = (sym->result != NULL && sym->result != sym);
- /* Make sure that the intrinsic is consistent with its internal
- representation. This needs to be done before assigning a default
+ /* Make sure that the intrinsic is consistent with its internal
+ representation. This needs to be done before assigning a default
type to avoid spurious warnings. */
if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
&& gfc_resolve_intrinsic (sym, &sym->declared_at) == FAILURE)
}
if (sym->ts.type == BT_ASSUMED)
- {
+ {
/* TS 29113, C407a. */
if (!sym->attr.dummy)
{
sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
{
gfc_try t = SUCCESS;
-
+
/* First, make sure the variable is declared at the
module-level scope (J3/04-007, Section 15.3). */
if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
verify_bind_c_derived_type (sym->ts.u.derived);
t = FAILURE;
}
-
+
/* Verify the variable itself as C interoperable if it
is BIND(C). It is not possible for this to succeed if
the verify_bind_c_derived_type failed, so don't have to handle
sym = ns->proc_name;
if (sym == NULL)
return 0;
-
+
if (sym->attr.flavor == FL_PROCEDURE)
break;
}
}
-
+
return sym->attr.flavor == FL_PROCEDURE && sym->attr.implicit_pure
&& !sym->attr.pure;
}
}
-/* Resolve equivalence object.
+/* Resolve equivalence object.
An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
an allocatable array, an object of nonsequence derived type, an object of
sequence derived type containing a pointer at any level of component
old_cs_base = cs_base;
resolve_types (ns);
+ component_assignment_level = 0;
resolve_codes (ns);
gfc_current_ns = old_ns;
projects / gcc.git / commitdiff