summaryrefslogtreecommitdiff
path: root/gcc/fortran
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/fortran')
-rw-r--r--gcc/fortran/ChangeLog347
-rw-r--r--gcc/fortran/arith.c5
-rw-r--r--gcc/fortran/check.c12
-rw-r--r--gcc/fortran/decl.c121
-rw-r--r--gcc/fortran/expr.c3
-rw-r--r--gcc/fortran/gfortran.h30
-rw-r--r--gcc/fortran/interface.c10
-rw-r--r--gcc/fortran/intrinsic.texi14
-rw-r--r--gcc/fortran/io.c6
-rw-r--r--gcc/fortran/match.c169
-rw-r--r--gcc/fortran/module.c115
-rw-r--r--gcc/fortran/options.c4
-rw-r--r--gcc/fortran/parse.c59
-rw-r--r--gcc/fortran/parse.h1
-rw-r--r--gcc/fortran/resolve.c632
-rw-r--r--gcc/fortran/symbol.c39
-rw-r--r--gcc/fortran/trans-array.c51
-rw-r--r--gcc/fortran/trans-common.c5
-rw-r--r--gcc/fortran/trans-decl.c71
-rw-r--r--gcc/fortran/trans-expr.c312
-rw-r--r--gcc/fortran/trans-intrinsic.c2
-rw-r--r--gcc/fortran/trans-openmp.c5
-rw-r--r--gcc/fortran/trans-stmt.c157
-rw-r--r--gcc/fortran/trans-stmt.h1
-rw-r--r--gcc/fortran/trans.c14
25 files changed, 1800 insertions, 385 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index c325d258ae8..eef8cf8d5a0 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,349 @@
+2009-11-05 Steven G. Kargl <kargl@gcc.gnu.org>
+
+ PR fortran/41918
+ * fortran/trans-decl.c: Silence intent(out) warning for derived type
+ dummy arguments with default initialization.
+
+2009-11-05 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/41556
+ * interface.c (matching_typebound_op,gfc_extend_assign): Handle CLASS
+ variables.
+
+2009-11-05 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/41556
+ PR fortran/41873
+ * resolve.c (resolve_function,resolve_call): Prevent abstract interfaces
+ from being called, but allow deferred type-bound procedures with
+ abstract interface.
+
+2009-11-04 Tobias Burnus <burnus@gcc.gnu.org>
+ Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/41556
+ PR fortran/41937
+ * interface.c (gfc_check_operator_interface): Handle CLASS arguments.
+ * resolve.c (resolve_allocate_expr): Handle allocatable components of
+ CLASS variables.
+
+2009-11-04 Richard Guenther <rguenther@suse.de>
+
+ * options.c (gfc_post_options): Rely on common code processing
+ LTO options. Only enable -fwhole-file here.
+
+2009-11-03 Tobias Burnus <burnus@net-b.de>
+
+ PR fortran/41907
+ * trans-expr.c (gfc_conv_procedure_call): Fix presence check
+ for optional arguments.
+
+2009-11-01 Tobias Burnus <burnus@net-b.de>
+
+ PR fortran/41872
+ * trans-decl.c (gfc_trans_deferred_vars): Do not nullify
+ autodeallocated allocatable scalars at the end of scope.
+ (gfc_generate_function_code): Fix indention.
+ * trans-expr.c (gfc_conv_procedure_call): For allocatable
+ scalars, fix calling by reference and autodeallocating
+ of intent out variables.
+
+2009-11-01 Tobias Burnus <burnus@net-b.de>
+
+ PR fortran/41850
+ * trans-expr.c (gfc_conv_procedure_call): Deallocate intent-out
+ variables only when present. Remove unneccessary present check.
+
+2009-10-29 Tobias Burnus <burnus@net-b.de>
+
+ PR fortran/41777
+ * trans-expr.c (gfc_conv_procedure_call,gfc_conv_expr_reference):
+ Use for generic EXPR_FUNCTION the attributes of the specific
+ function.
+
+2009-10-29 Janne Blomqvist <jb@gcc.gnu.org>
+
+ PR fortran/41860
+ * resolve.c (apply_default_init_local): Treat -fno-automatic as if
+ var was saved.
+
+2009-10-28 Rafael Avila de Espindola <espindola@google.com>
+
+ * trans-common.c (create_common): Set TREE_PUBLIC to false on
+ fake variables.
+
+2009-10-26 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/41714
+ * trans.c (gfc_trans_code): Remove call to
+ 'tree_annotate_all_with_location'. Location should already be set.
+ * trans-openmp.c (gfc_trans_omp_workshare): Ditto.
+ * trans-stmt.c (gfc_trans_allocate): Do correct data initialization for
+ CLASS variables with SOURCE tag, plus some cleanup.
+
+2009-10-24 Janus Weil <janus@gcc.gnu.org>
+ Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/41784
+ * module.c (load_derived_extensions): Skip symbols which are not being
+ loaded.
+
+2009-10-24 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/41772
+ * trans-intrinsic.c (gfc_conv_intrinsic_transfer): Stop'extent'
+ from going negative.
+
+2009-10-23 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/41800
+ * trans-expr.c (gfc_trans_scalar_assign): Handle CLASS variables.
+
+2009-10-23 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/41758
+ * match.c (conformable_arrays): Move to resolve.c.
+ (gfc_match_allocate): Don't resolve SOURCE expr yet, and move some
+ checks to resolve_allocate_expr.
+ * resolve.c (conformable_arrays): Moved here from match.c.
+ (resolve_allocate_expr): Moved some checks here from gfc_match_allocate.
+ (resolve_code): Resolve SOURCE tag for ALLOCATE expressions.
+
+2009-10-22 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/41781
+ * resolve.c (resolve_codes): Don't clear 'cs_base' for BLOCK constructs,
+ to make sure labels are treated correctly.
+ * symbol.c (gfc_get_st_label): Create labels in the right namespace.
+ For BLOCK constructs go into the parent namespace.
+
+2009-10-21 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/41706
+ PR fortran/41766
+ * match.c (select_type_set_tmp): Set flavor for temporary.
+ * resolve.c (resolve_class_typebound_call): Correctly resolve actual
+ arguments.
+
+2009-10-20 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/41706
+ * resolve.c (resolve_arg_exprs): New function.
+ (resolve_class_compcall): Call the above.
+ (resolve_class_typebound_call): The same.
+
+2009-10-19 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/41586
+ * parse.c (parse_derived): Correctly set 'alloc_comp' and 'pointer_comp'
+ for CLASS variables.
+ * trans-array.c (structure_alloc_comps): Handle deallocation and
+ nullification of allocatable scalar components.
+ * trans-decl.c (gfc_get_symbol_decl): Remember allocatable scalars for
+ automatic deallocation.
+ (gfc_trans_deferred_vars): Automatically deallocate allocatable scalars.
+
+2009-10-19 Tobias Burnus <burnus@net-b.de>
+ Steven G. Kargl <kargl@gcc.gnu.org>
+
+ PR fortran/41755
+ * symbol.c (gfc_undo_symbols): Add NULL check.
+ * match.c (gfc_match_equivalence): Add check for
+ missing comma.
+
+2009-10-19 Richard Guenther <rguenther@suse.de>
+
+ PR fortran/41494
+ * trans-expr.c (gfc_trans_scalar_assign): Do not call
+ gfc_evaluate_now.
+
+2009-10-17 Janus Weil <janus@gcc.gnu.org>
+ Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/41608
+ * decl.c (gfc_match_data_decl): Add BT_CLASS for undefined type
+ and empty type errors.
+ * parse.c (gfc_build_block_ns): Only set recursive if parent ns
+ has a proc_name.
+
+ PR fortran/41629
+ PR fortran/41618
+ PR fortran/41587
+ * gfortran.h : Add class_ok bitfield to symbol_attr.
+ * decl.c (build_sym): Set attr.class_ok if dummy, pointer or
+ allocatable.
+ (build_struct): Use gfc_try 't' to carry errors past the call
+ to encapsulate_class_symbol.
+ (attr_decl1): For a CLASS object, apply the new attribute to
+ the data component.
+ * match.c (gfc_match_select_type): Set attr.class_ok for an
+ assigned selector.
+ * resolve.c (resolve_fl_variable_derived): Check a CLASS object
+ is dummy, pointer or allocatable by testing the class_ok and
+ the use_assoc attribute.
+
+2009-10-16 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/41719
+ * resolve.c (resolve_ordinary_assign): Reject intrinsic assignments
+ to polymorphic variables.
+
+2009-10-16 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/41648
+ PR fortran/41656
+ * trans-expr.c (select_class_proc): Convert the expression for the
+ vindex, carried on the first member of the esym list.
+ * gfortran.h : Add the vindex field to the esym_list structure.
+ and eliminate the class_object field.
+ * resolve.c (check_class_members): Remove the setting of the
+ class_object field.
+ (vindex_expr): New function.
+ (get_class_from_expr): New function.
+ (resolve_class_compcall): Call the above to find the ultimate
+ class or derived component. If derived, do not generate the
+ esym list. Add and expression for the vindex to the esym list
+ by calling the above.
+ (resolve_class_typebound_call): The same.
+
+2009-10-15 Steven G. Kargl <kargl@gcc.gnu.org>
+
+ PR fortran/41712
+ * intrinsic.texi: Explicitly state that ETIME and DTIME take
+ REAL(4) arguments. Fix nearby typographically errors where
+ /leq was used instead of \leq.
+
+2009-10-13 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/41581
+ * decl.c (encapsulate_class_symbol): Add new component '$size'.
+ * resolve.c (resolve_allocate_expr): Move CLASS handling to
+ gfc_trans_allocate.
+ (resolve_class_assign): Replaced by gfc_trans_class_assign.
+ (resolve_code): Remove calls to resolve_class_assign.
+ * trans.c (gfc_trans_code): Use new function gfc_trans_class_assign.
+ * trans-expr.c (get_proc_ptr_comp): Fix a memory leak.
+ (gfc_conv_procedure_call): For CLASS dummies, set the
+ $size component.
+ (gfc_trans_class_assign): New function, replacing resolve_class_assign.
+ * trans-stmt.h (gfc_trans_class_assign): New prototype.
+ * trans-stmt.c (gfc_trans_allocate): Use correct size when allocating
+ CLASS variables. Do proper initialization. Move some code here from
+ resolve_allocate_expr.
+
+2009-10-11 Jerry DeLisle <jvdelisle@gcc.gnu.org>
+
+ PR fortran/38439
+ * io.c (check_format): Fix locus for error messages and fix a comment.
+
+2009-10-11 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/41583
+ * decl.c (hash_value): New function.
+ (gfc_match_derived_decl): Call it.
+
+2009-10-09 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/41585
+ * decl.c (build_struct): Bugfix for CLASS components.
+
+2009-10-09 Tobias Burnus <burnus@net-b.de>
+
+ PR fortran/41582
+ * decl.c (encapsulate_class_symbol): Save attr.abstract.
+ * resolve.c (resolve_allocate_expr): Reject class allocate
+ without typespec or source=.
+ * trans-stmt.c (gfc_trans_allocate): Change gfc_warning
+ into gfc_error for "not yet implemented".
+
+2009-10-09 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/41579
+ * gfortran.h (gfc_select_type_stack): New struct, to be used as a stack
+ for SELECT TYPE statements.
+ (select_type_stack): New global variable.
+ (type_selector,select_type_tmp): Removed.
+ * match.c (type_selector,type_selector): Removed.
+ (select_type_stack): New variable, serving as a stack for
+ SELECT TYPE statements.
+ (select_type_push,select_type_set_tmp): New functions.
+ (gfc_match_select_type): Call select_type_push.
+ (gfc_match_type_is): Call select_type_set_tmp.
+ * parse.c (select_type_pop): New function.
+ (parse_select_type_block): Call select_type_pop.
+ * symbol.c (select_type_insert_tmp): New function.
+ (gfc_find_sym_tree): Call select_type_insert_tmp.
+
+2009-10-07 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
+
+ * arith.c (arith_power): Use mpc_pow_z.
+ * gfortran.h (HAVE_mpc_pow_z): Define.
+
+2009-10-07 Daniel Kraft <d@domob.eu>
+
+ PR fortran/41615
+ * resolve.c (resolve_contained_fntype): Clarify error message for
+ invalid assumed-length character result on module procedures.
+
+2009-10-07 Janus Weil <janus@gcc.gnu.org>
+
+ * expr.c (gfc_check_pointer_assign): Do the correct type checking when
+ CLASS variables are involved.
+ * match.c (gfc_match_select_type): Parse associate-name in SELECT TYPE
+ statements, and set up a local namespace for the SELECT TYPE block.
+ * parse.h (gfc_build_block_ns): New prototype.
+ * parse.c (parse_select_type_block): Return from local namespace to its
+ parent after SELECT TYPE block.
+ (gfc_build_block_ns): New function for setting up the local namespace
+ for a BLOCK construct.
+ (parse_block_construct): Use gfc_build_block_ns.
+ * resolve.c (resolve_select_type): Insert assignment for the selector
+ variable, in case an associate-name is given, and put the SELECT TYPE
+ statement inside a BLOCK.
+ (resolve_code): Call resolve_class_assign after checking the assignment.
+ * symbol.c (gfc_find_sym_tree): Moved some code here from
+ gfc_get_ha_sym_tree.
+ (gfc_get_ha_sym_tree): Moved some code to gfc_find_sym_tree.
+
+2009-10-07 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/41613
+ * resolve.c (check_class_members): Reset compcall.assign.
+
+2009-10-05 Paul Thomas <pault@gcc.gnu.org>
+
+ * trans-expr.c (select_class_proc): New function.
+ (conv_function_val): Deal with class methods and call above.
+ * symbol.c (gfc_type_compatible): Treat case where both ts1 and
+ ts2 are BT_CLASS.
+ gfortran.h : Add structure gfc_class_esym_list and include in
+ the structure gfc_expr.
+ * module.c (load_derived_extensions): New function.
+ (read_module): Call above.
+ (write_dt_extensions): New function.
+ (write_derived_extensions): New function.
+ (write_module): Use the above.
+ * resolve.c (resolve_typebound_call): Add a function expression
+ for class methods. This carries the chain of symbols for the
+ dynamic dispatch in select_class_proc.
+ (resolve_compcall): Add second, boolean argument to indicate if
+ a function is being handled.
+ (check_members): New function.
+ (check_class_members): New function.
+ (resolve_class_compcall): New function.
+ (resolve_class_typebound_call): New function.
+ (gfc_resolve_expr): Call above for component calls..
+
+2009-10-05 Daniel Kraft <d@domob.eu>
+
+ PR fortran/41403
+ * trans-stmt.c (gfc_trans_goto): Ignore statement list on assigned goto
+ if it is present.
+
+2009-10-03 Richard Guenther <rguenther@suse.de>
+
+ * options.c (gfc_post_options): Handle -flto and -fwhopr.
+
2009-10-02 Tobias Burnus <burnus@net-b.de>
PR fortran/41479
@@ -285,7 +631,6 @@
* parse.c (next_free): Improve error locus printing.
(next_fixed): Change gfc_warn to gfc_warning_now, and improve
locus reporting.
-
2009-09-16 Michael Matz <matz@suse.de>
diff --git a/gcc/fortran/arith.c b/gcc/fortran/arith.c
index dddf7e003ce..82a43ad7178 100644
--- a/gcc/fortran/arith.c
+++ b/gcc/fortran/arith.c
@@ -1111,7 +1111,10 @@ arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
case BT_COMPLEX:
{
-#ifdef HAVE_mpc_pow
+#ifdef HAVE_mpc_pow_z
+ mpc_pow_z (result->value.complex, op1->value.complex,
+ op2->value.integer, GFC_MPC_RND_MODE);
+#elif defined(HAVE_mpc_pow)
mpc_t apower;
gfc_set_model (mpc_realref (op1->value.complex));
mpc_init2 (apower, mpfr_get_default_prec());
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 171eeaa97bf..9b6f8ea0a4f 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -599,10 +599,8 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
where = &pointer->where;
- if (pointer->expr_type == EXPR_VARIABLE)
- attr1 = gfc_variable_attr (pointer, NULL);
- else if (pointer->expr_type == EXPR_FUNCTION)
- attr1 = pointer->symtree->n.sym->attr;
+ if (pointer->expr_type == EXPR_VARIABLE || pointer->expr_type == EXPR_FUNCTION)
+ attr1 = gfc_expr_attr (pointer);
else if (pointer->expr_type == EXPR_NULL)
goto null_arg;
else
@@ -624,10 +622,8 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
if (target->expr_type == EXPR_NULL)
goto null_arg;
- if (target->expr_type == EXPR_VARIABLE)
- attr2 = gfc_variable_attr (target, NULL);
- else if (target->expr_type == EXPR_FUNCTION)
- attr2 = target->symtree->n.sym->attr;
+ if (target->expr_type == EXPR_VARIABLE || target->expr_type == EXPR_FUNCTION)
+ attr2 = gfc_expr_attr (target);
else
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer "
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 82442042dcc..08d2bd69ddf 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -1028,7 +1028,8 @@ verify_c_interop_param (gfc_symbol *sym)
/* Build a polymorphic CLASS entity, using the symbol that comes from build_sym.
A CLASS entity is represented by an encapsulating type, which contains the
declared type as '$data' component, plus an integer component '$vindex'
- which determines the dynamic type. */
+ which determines the dynamic type, and another integer '$size', which
+ contains the size of the dynamic type structure. */
static gfc_try
encapsulate_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
@@ -1077,6 +1078,7 @@ encapsulate_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
c->attr.pointer = attr->pointer || attr->dummy;
c->attr.allocatable = attr->allocatable;
c->attr.dimension = attr->dimension;
+ c->attr.abstract = ts->u.derived->attr.abstract;
c->as = (*as);
c->initializer = gfc_get_expr ();
c->initializer->expr_type = EXPR_NULL;
@@ -1088,6 +1090,14 @@ encapsulate_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
c->ts.kind = 4;
c->attr.access = ACCESS_PRIVATE;
c->initializer = gfc_int_expr (0);
+
+ /* Add component '$size'. */
+ if (gfc_add_component (fclass, "$size", &c) == FAILURE)
+ return FAILURE;
+ c->ts.type = BT_INTEGER;
+ c->ts.kind = 4;
+ c->attr.access = ACCESS_PRIVATE;
+ c->initializer = gfc_int_expr (0);
}
fclass->attr.extension = 1;
@@ -1171,7 +1181,12 @@ build_sym (const char *name, gfc_charlen *cl,
sym->attr.implied_index = 0;
if (sym->ts.type == BT_CLASS)
- encapsulate_class_symbol (&sym->ts, &sym->attr, &sym->as);
+ {
+ sym->attr.class_ok = (sym->attr.dummy
+ || sym->attr.pointer
+ || sym->attr.allocatable) ? 1 : 0;
+ encapsulate_class_symbol (&sym->ts, &sym->attr, &sym->as);
+ }
return SUCCESS;
}
@@ -1462,10 +1477,11 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
gfc_array_spec **as)
{
gfc_component *c;
+ gfc_try t = SUCCESS;
- /* If the current symbol is of the same derived type that we're
+ /* F03:C438/C439. If the current symbol is of the same derived type that we're
constructing, it must have the pointer attribute. */
- if (current_ts.type == BT_DERIVED
+ if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
&& current_ts.u.derived == gfc_current_block ()
&& current_attr.pointer == 0)
{
@@ -1544,12 +1560,9 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
}
}
- if (c->ts.type == BT_CLASS)
- encapsulate_class_symbol (&c->ts, &c->attr, &c->as);
-
/* Check array components. */
if (!c->attr.dimension)
- return SUCCESS;
+ goto scalar;
if (c->attr.pointer)
{
@@ -1557,7 +1570,7 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
{
gfc_error ("Pointer array component of structure at %C must have a "
"deferred shape");
- return FAILURE;
+ t = FAILURE;
}
}
else if (c->attr.allocatable)
@@ -1566,7 +1579,7 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
{
gfc_error ("Allocatable component of structure at %C must have a "
"deferred shape");
- return FAILURE;
+ t = FAILURE;
}
}
else
@@ -1575,11 +1588,15 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
{
gfc_error ("Array component of structure at %C must have an "
"explicit shape");
- return FAILURE;
+ t = FAILURE;
}
}
- return SUCCESS;
+scalar:
+ if (c->ts.type == BT_CLASS)
+ encapsulate_class_symbol (&c->ts, &c->attr, &c->as);
+
+ return t;
}
@@ -3751,7 +3768,8 @@ gfc_match_data_decl (void)
if (m != MATCH_YES)
return m;
- if (current_ts.type == BT_DERIVED && gfc_current_state () != COMP_DERIVED)
+ if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
+ && gfc_current_state () != COMP_DERIVED)
{
sym = gfc_use_derived (current_ts.u.derived);
@@ -3771,7 +3789,8 @@ gfc_match_data_decl (void)
goto cleanup;
}
- if (current_ts.type == BT_DERIVED && current_ts.u.derived->components == NULL
+ if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
+ && current_ts.u.derived->components == NULL
&& !current_ts.u.derived->attr.zero_comp)
{
@@ -5684,13 +5703,31 @@ attr_decl1 (void)
}
}
- /* Update symbol table. DIMENSION attribute is set
- in gfc_set_array_spec(). */
- if (current_attr.dimension == 0
- && gfc_copy_attr (&sym->attr, &current_attr, &var_locus) == FAILURE)
+ /* Update symbol table. DIMENSION attribute is set in
+ gfc_set_array_spec(). For CLASS variables, this must be applied
+ to the first component, or '$data' field. */
+ if (sym->ts.type == BT_CLASS && sym->ts.u.derived)
{
- m = MATCH_ERROR;
- goto cleanup;
+ gfc_component *comp;
+ comp = gfc_find_component (sym->ts.u.derived, "$data", true, true);
+ if (comp == NULL || gfc_copy_attr (&comp->attr, &current_attr,
+ &var_locus) == FAILURE)
+ {
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+ sym->attr.class_ok = (sym->attr.class_ok
+ || current_attr.allocatable
+ || current_attr.pointer);
+ }
+ else
+ {
+ if (current_attr.dimension == 0
+ && gfc_copy_attr (&sym->attr, &current_attr, &var_locus) == FAILURE)
+ {
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
}
if (gfc_set_array_spec (sym, as, &var_locus) == FAILURE)
@@ -6746,8 +6783,44 @@ gfc_get_type_attr_spec (symbol_attribute *attr, char *name)
}
-/* Counter for assigning a unique vindex number to each derived type. */
-static int vindex_counter = 0;
+/* Assign a hash value for a derived type. The algorithm is that of
+ SDBM. The hashed string is '[module_name #] derived_name'. */
+static unsigned int
+hash_value (gfc_symbol *sym)
+{
+ unsigned int hash = 0;
+ const char *c;
+ int i, len;
+
+ /* Hash of the module or procedure name. */
+ if (sym->module != NULL)
+ c = sym->module;
+ else if (sym->ns && sym->ns->proc_name
+ && sym->ns->proc_name->attr.flavor == FL_MODULE)
+ c = sym->ns->proc_name->name;
+ else
+ c = NULL;
+
+ if (c)
+ {
+ len = strlen (c);
+ for (i = 0; i < len; i++, c++)
+ hash = (hash << 6) + (hash << 16) - hash + (*c);
+
+ /* Disambiguate between 'a' in 'aa' and 'aa' in 'a'. */
+ hash = (hash << 6) + (hash << 16) - hash + '#';
+ }
+
+ /* Hash of the derived type name. */
+ len = strlen (sym->name);
+ c = sym->name;
+ for (i = 0; i < len; i++, c++)
+ hash = (hash << 6) + (hash << 16) - hash + (*c);
+
+ /* Return the hash but take the modulus for the sake of module read,
+ even though this slightly increases the chance of collision. */
+ return (hash % 100000000);
+}
/* Match the beginning of a derived type declaration. If a type name
@@ -6871,8 +6944,8 @@ gfc_match_derived_decl (void)
}
if (!sym->vindex)
- /* Set the vindex for this type and increment the counter. */
- sym->vindex = ++vindex_counter;
+ /* Set the vindex for this type. */
+ sym->vindex = hash_value (sym);
/* Take over the ABSTRACT attribute. */
sym->attr.abstract = attr.abstract;
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 32aa68265bb..cbd3172b454 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -3277,8 +3277,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
return SUCCESS;
}
- if (lvalue->ts.type != BT_CLASS && lvalue->symtree->n.sym->ts.type != BT_CLASS
- && !gfc_compare_types (&lvalue->ts, &rvalue->ts))
+ if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
{
gfc_error ("Different types in pointer assignment at %L; attempted "
"assignment of %s to %s", &lvalue->where,
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index b40f01ba4bf..74a31d2661c 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -672,6 +672,7 @@ typedef struct
unsigned is_bind_c:1; /* say if is bound to C. */
unsigned extension:1; /* extends a derived type. */
unsigned is_class:1; /* is a CLASS container. */
+ unsigned class_ok:1; /* is a CLASS object with correct attributes. */
/* These flags are both in the typespec and attribute. The attribute
list is what gets read from/written to a module file. The typespec
@@ -1594,6 +1595,17 @@ typedef struct gfc_intrinsic_sym
gfc_intrinsic_sym;
+typedef struct gfc_class_esym_list
+{
+ gfc_symbol *derived;
+ gfc_symbol *esym;
+ struct gfc_expr *vindex;
+ struct gfc_class_esym_list *next;
+}
+gfc_class_esym_list;
+
+#define gfc_get_class_esym_list() XCNEW (gfc_class_esym_list)
+
/* Expression nodes. The expression node types deserve explanations,
since the last couple can be easily misconstrued:
@@ -1618,6 +1630,7 @@ gfc_intrinsic_sym;
# endif
# if MPC_VERSION >= MPC_VERSION_NUM(0,7,1)
# define HAVE_mpc_arc
+# define HAVE_mpc_pow_z
# endif
#else
#define mpc_realref(X) ((X).r)
@@ -1705,6 +1718,7 @@ typedef struct gfc_expr
const char *name; /* Points to the ultimate name of the function */
gfc_intrinsic_sym *isym;
gfc_symbol *esym;
+ gfc_class_esym_list *class_esym;
}
function;
@@ -2195,6 +2209,18 @@ iterator_stack;
extern iterator_stack *iter_stack;
+/* Used for (possibly nested) SELECT TYPE statements. */
+typedef struct gfc_select_type_stack
+{
+ gfc_symbol *selector; /* Current selector variable. */
+ gfc_symtree *tmp; /* Current temporary variable. */
+ struct gfc_select_type_stack *prev; /* Previous element on stack. */
+}
+gfc_select_type_stack;
+extern gfc_select_type_stack *select_type_stack;
+#define gfc_get_select_type_stack() XCNEW (gfc_select_type_stack)
+
+
/* Node in the linked list used for storing finalizer procedures. */
typedef struct gfc_finalizer
@@ -2553,10 +2579,6 @@ void gfc_free_equiv (gfc_equiv *);
void gfc_free_data (gfc_data *);
void gfc_free_case_list (gfc_case *);
-/* Used for SELECT TYPE statements. */
-extern gfc_symbol *type_selector;
-extern gfc_symtree *select_type_tmp;
-
/* matchexp.c -- FIXME too? */
gfc_expr *gfc_get_parentheses (gfc_expr *);
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 0fd4742a1de..866a81ca1d8 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -626,6 +626,7 @@ gfc_check_operator_interface (gfc_symbol *sym, gfc_intrinsic_op op,
- Types and kinds do not conform, and
- First argument is of derived type. */
if (sym->formal->sym->ts.type != BT_DERIVED
+ && sym->formal->sym->ts.type != BT_CLASS
&& (r1 == 0 || r1 == r2)
&& (sym->formal->sym->ts.type == sym->formal->next->sym->ts.type
|| (gfc_numeric_ts (&sym->formal->sym->ts)
@@ -2573,13 +2574,16 @@ matching_typebound_op (gfc_expr** tb_base,
gfc_actual_arglist* base;
for (base = args; base; base = base->next)
- if (base->expr->ts.type == BT_DERIVED)
+ if (base->expr->ts.type == BT_DERIVED || base->expr->ts.type == BT_CLASS)
{
gfc_typebound_proc* tb;
gfc_symbol* derived;
gfc_try result;
- derived = base->expr->ts.u.derived;
+ if (base->expr->ts.type == BT_CLASS)
+ derived = base->expr->ts.u.derived->components->ts.u.derived;
+ else
+ derived = base->expr->ts.u.derived;
if (op == INTRINSIC_USER)
{
@@ -2836,7 +2840,7 @@ gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
rhs = c->expr2;
/* Don't allow an intrinsic assignment to be replaced. */
- if (lhs->ts.type != BT_DERIVED
+ if (lhs->ts.type != BT_DERIVED && lhs->ts.type != BT_CLASS
&& (rhs->rank == 0 || rhs->rank == lhs->rank)
&& (lhs->ts.type == rhs->ts.type
|| (gfc_numeric_ts (&lhs->ts) && gfc_numeric_ts (&rhs->ts))))
diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi
index 2c993b9048a..3aa16b0f860 100644
--- a/gcc/fortran/intrinsic.texi
+++ b/gcc/fortran/intrinsic.texi
@@ -2744,7 +2744,7 @@ Inverse function: @ref{ACOSH}
@code{COUNT(MASK [, DIM [, KIND]])} counts the number of @code{.TRUE.}
elements of @var{MASK} along the dimension of @var{DIM}. If @var{DIM} is
omitted it is taken to be @code{1}. @var{DIM} is a scalar of type
-@code{INTEGER} in the range of @math{1 /leq DIM /leq n)} where @math{n}
+@code{INTEGER} in the range of @math{1 \leq DIM \leq n)} where @math{n}
is the rank of @var{MASK}.
@item @emph{Standard}:
@@ -2864,7 +2864,7 @@ end program test_cpu_time
@code{CSHIFT(ARRAY, SHIFT [, DIM])} performs a circular shift on elements of
@var{ARRAY} along the dimension of @var{DIM}. If @var{DIM} is omitted it is
taken to be @code{1}. @var{DIM} is a scalar of type @code{INTEGER} in the
-range of @math{1 /leq DIM /leq n)} where @math{n} is the rank of @var{ARRAY}.
+range of @math{1 \leq DIM \leq n)} where @math{n} is the rank of @var{ARRAY}.
If the rank of @var{ARRAY} is one, then all elements of @var{ARRAY} are shifted
by @var{SHIFT} places. If rank is greater than one, then all complete rank one
sections of @var{ARRAY} along the given dimension are shifted. Elements
@@ -3458,8 +3458,8 @@ Subroutine, function
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
-@item @var{VALUES}@tab The type shall be @code{REAL, DIMENSION(2)}.
-@item @var{TIME}@tab The type shall be @code{REAL}.
+@item @var{VALUES}@tab The type shall be @code{REAL(4), DIMENSION(2)}.
+@item @var{TIME}@tab The type shall be @code{REAL(4)}.
@end multitable
@item @emph{Return value}:
@@ -3503,7 +3503,7 @@ end program test_dtime
@code{EOSHIFT(ARRAY, SHIFT[, BOUNDARY, DIM])} performs an end-off shift on
elements of @var{ARRAY} along the dimension of @var{DIM}. If @var{DIM} is
omitted it is taken to be @code{1}. @var{DIM} is a scalar of type
-@code{INTEGER} in the range of @math{1 /leq DIM /leq n)} where @math{n} is the
+@code{INTEGER} in the range of @math{1 \leq DIM \leq n)} where @math{n} is the
rank of @var{ARRAY}. If the rank of @var{ARRAY} is one, then all elements of
@var{ARRAY} are shifted by @var{SHIFT} places. If rank is greater than one,
then all complete rank one sections of @var{ARRAY} along the given dimension are
@@ -3767,8 +3767,8 @@ Subroutine, function
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
-@item @var{VALUES}@tab The type shall be @code{REAL, DIMENSION(2)}.
-@item @var{TIME}@tab The type shall be @code{REAL}.
+@item @var{VALUES}@tab The type shall be @code{REAL(4), DIMENSION(2)}.
+@item @var{TIME}@tab The type shall be @code{REAL(4)}.
@end multitable
@item @emph{Return value}:
diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c
index abd370f5048..d6b64c4120c 100644
--- a/gcc/fortran/io.c
+++ b/gcc/fortran/io.c
@@ -643,6 +643,8 @@ format_item_1:
case FMT_X:
/* X requires a prior number if we're being pedantic. */
+ if (mode != MODE_FORMAT)
+ format_locus.nextc += format_string_pos;
if (gfc_notify_std (GFC_STD_GNU, "Extension: X descriptor "
"requires leading space count at %L", &format_locus)
== FAILURE)
@@ -722,7 +724,7 @@ data_desc:
break;
case FMT_P:
- /* Comma after P is allowed only for F, E, EN, ES, D, or G.
+ /* No comma after P allowed only for F, E, EN, ES, D, or G.
10.1.1 (1). */
t = format_lex ();
if (t == FMT_ERROR)
@@ -1052,7 +1054,7 @@ between_desc:
default:
if (mode != MODE_FORMAT)
- format_locus.nextc += format_string_pos;
+ format_locus.nextc += format_string_pos - 1;
if (gfc_notify_std (GFC_STD_GNU, "Extension: Missing comma at %L",
&format_locus) == FAILURE)
return FAILURE;
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 3e969e78ca2..24e292bd4d6 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -29,9 +29,8 @@ along with GCC; see the file COPYING3. If not see
int gfc_matching_procptr_assignment = 0;
bool gfc_matching_prefix = false;
-/* Used for SELECT TYPE statements. */
-gfc_symbol *type_selector;
-gfc_symtree *select_type_tmp;
+/* Stack of SELECT TYPE statements. */
+gfc_select_type_stack *select_type_stack = NULL;
/* For debugging and diagnostic purposes. Return the textual representation
of the intrinsic operator OP. */
@@ -2389,58 +2388,6 @@ char_selector:
}
-/* Used in gfc_match_allocate to check that a allocation-object and
- a source-expr are conformable. This does not catch all possible
- cases; in particular a runtime checking is needed. */
-
-static gfc_try
-conformable_arrays (gfc_expr *e1, gfc_expr *e2)
-{
- /* First compare rank. */
- if (e2->ref && e1->rank != e2->ref->u.ar.as->rank)
- {
- gfc_error ("Source-expr at %L must be scalar or have the "
- "same rank as the allocate-object at %L",
- &e1->where, &e2->where);
- return FAILURE;
- }
-
- if (e1->shape)
- {
- int i;
- mpz_t s;
-
- mpz_init (s);
-
- for (i = 0; i < e1->rank; i++)
- {
- if (e2->ref->u.ar.end[i])
- {
- mpz_set (s, e2->ref->u.ar.end[i]->value.integer);
- mpz_sub (s, s, e2->ref->u.ar.start[i]->value.integer);
- mpz_add_ui (s, s, 1);
- }
- else
- {
- mpz_set (s, e2->ref->u.ar.start[i]->value.integer);
- }
-
- if (mpz_cmp (e1->shape[i], s) != 0)
- {
- gfc_error ("Source-expr at %L and allocate-object at %L must "
- "have the same shape", &e1->where, &e2->where);
- mpz_clear (s);
- return FAILURE;
- }
- }
-
- mpz_clear (s);
- }
-
- return SUCCESS;
-}
-
-
/* Match an ALLOCATE statement. */
match
@@ -2621,7 +2568,7 @@ alloc_opt_list:
goto cleanup;
}
- /* The next 3 conditionals check C631. */
+ /* The next 2 conditionals check C631. */
if (ts.type != BT_UNKNOWN)
{
gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
@@ -2636,28 +2583,6 @@ alloc_opt_list:
goto cleanup;
}
- gfc_resolve_expr (tmp);
-
- if (!gfc_type_compatible (&head->expr->ts, &tmp->ts))
- {
- gfc_error ("Type of entity at %L is type incompatible with "
- "source-expr at %L", &head->expr->where, &tmp->where);
- goto cleanup;
- }
-
- /* Check C633. */
- if (tmp->ts.kind != head->expr->ts.kind)
- {
- gfc_error ("The allocate-object at %L and the source-expr at %L "
- "shall have the same kind type parameter",
- &head->expr->where, &tmp->where);
- goto cleanup;
- }
-
- /* Check C632 and restriction following Note 6.18. */
- if (tmp->rank > 0 && conformable_arrays (tmp, head->expr) == FAILURE)
- goto cleanup;
-
source = tmp;
saw_source = true;
@@ -3751,7 +3676,10 @@ gfc_match_equivalence (void)
if (gfc_match_eos () == MATCH_YES)
break;
if (gfc_match_char (',') != MATCH_YES)
- goto syntax;
+ {
+ gfc_error ("Expecting a comma in EQUIVALENCE at %C");
+ goto cleanup;
+ }
}
return MATCH_YES;
@@ -4021,46 +3949,90 @@ gfc_match_select (void)
}
+/* Push the current selector onto the SELECT TYPE stack. */
+
+static void
+select_type_push (gfc_symbol *sel)
+{
+ gfc_select_type_stack *top = gfc_get_select_type_stack ();
+ top->selector = sel;
+ top->tmp = NULL;
+ top->prev = select_type_stack;
+
+ select_type_stack = top;
+}
+
+
+/* Set the temporary for the current SELECT TYPE selector. */
+
+static void
+select_type_set_tmp (gfc_typespec *ts)
+{
+ char name[GFC_MAX_SYMBOL_LEN];
+ gfc_symtree *tmp;
+
+ sprintf (name, "tmp$%s", ts->u.derived->name);
+ gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
+ gfc_add_type (tmp->n.sym, ts, NULL);
+ gfc_set_sym_referenced (tmp->n.sym);
+ gfc_add_pointer (&tmp->n.sym->attr, NULL);
+ gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
+
+ select_type_stack->tmp = tmp;
+}
+
+
/* Match a SELECT TYPE statement. */
match
gfc_match_select_type (void)
{
- gfc_expr *expr;
+ gfc_expr *expr1, *expr2 = NULL;
match m;
+ char name[GFC_MAX_SYMBOL_LEN];
m = gfc_match_label ();
if (m == MATCH_ERROR)
return m;
- m = gfc_match (" select type ( %e ", &expr);
+ m = gfc_match (" select type ( ");
if (m != MATCH_YES)
return m;
- /* TODO: Implement ASSOCIATE. */
- m = gfc_match (" => ");
+ gfc_current_ns = gfc_build_block_ns (gfc_current_ns);
+
+ m = gfc_match (" %n => %e", name, &expr2);
if (m == MATCH_YES)
{
- gfc_error ("Associate-name in SELECT TYPE statement at %C "
- "is not yet supported");
- return MATCH_ERROR;
+ expr1 = gfc_get_expr();
+ expr1->expr_type = EXPR_VARIABLE;
+ if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false))
+ return MATCH_ERROR;
+ expr1->symtree->n.sym->ts = expr2->ts;
+ expr1->symtree->n.sym->attr.referenced = 1;
+ expr1->symtree->n.sym->attr.class_ok = 1;
+ }
+ else
+ {
+ m = gfc_match (" %e ", &expr1);
+ if (m != MATCH_YES)
+ return m;
}
m = gfc_match (" )%t");
if (m != MATCH_YES)
return m;
- /* Check for F03:C811.
- TODO: Change error message once ASSOCIATE is implemented. */
- if (expr->expr_type != EXPR_VARIABLE || expr->ref != NULL)
+ /* Check for F03:C811. */
+ if (!expr2 && (expr1->expr_type != EXPR_VARIABLE || expr1->ref != NULL))
{
- gfc_error ("Selector must be a named variable in SELECT TYPE statement "
- "at %C");
+ gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
+ "use associate-name=>");
return MATCH_ERROR;
}
/* Check for F03:C813. */
- if (expr->ts.type != BT_CLASS)
+ if (expr1->ts.type != BT_CLASS && !(expr2 && expr2->ts.type == BT_CLASS))
{
gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
"at %C");
@@ -4068,9 +4040,11 @@ gfc_match_select_type (void)
}
new_st.op = EXEC_SELECT_TYPE;
- new_st.expr1 = expr;
+ new_st.expr1 = expr1;
+ new_st.expr2 = expr2;
+ new_st.ext.ns = gfc_current_ns;
- type_selector = expr->symtree->n.sym;
+ select_type_push (expr1->symtree->n.sym);
return MATCH_YES;
}
@@ -4155,7 +4129,6 @@ gfc_match_type_is (void)
{
gfc_case *c = NULL;
match m;
- char name[GFC_MAX_SYMBOL_LEN];
if (gfc_current_state () != COMP_SELECT_TYPE)
{
@@ -4187,11 +4160,7 @@ gfc_match_type_is (void)
new_st.ext.case_list = c;
/* Create temporary variable. */
- sprintf (name, "tmp$%s", c->ts.u.derived->name);
- gfc_get_sym_tree (name, gfc_current_ns, &select_type_tmp, false);
- select_type_tmp->n.sym->ts = c->ts;
- select_type_tmp->n.sym->attr.referenced = 1;
- select_type_tmp->n.sym->attr.pointer = 1;
+ select_type_set_tmp (&c->ts);
return MATCH_YES;
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 1769eada5fe..b2ad6ecc477 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -3972,6 +3972,72 @@ load_equiv (void)
}
+/* This function loads the sym_root of f2k_derived with the extensions to
+ the derived type. */
+static void
+load_derived_extensions (void)
+{
+ int symbol, nuse, j;
+ gfc_symbol *derived;
+ gfc_symbol *dt;
+ gfc_symtree *st;
+ pointer_info *info;
+ char name[GFC_MAX_SYMBOL_LEN + 1];
+ char module[GFC_MAX_SYMBOL_LEN + 1];
+ const char *p;
+
+ mio_lparen ();
+ while (peek_atom () != ATOM_RPAREN)
+ {
+ mio_lparen ();
+ mio_integer (&symbol);
+ info = get_integer (symbol);
+ derived = info->u.rsym.sym;
+
+ /* This one is not being loaded. */
+ if (!info || !derived)
+ {
+ while (peek_atom () != ATOM_RPAREN)
+ skip_list ();
+ continue;
+ }
+
+ gcc_assert (derived->attr.flavor == FL_DERIVED);
+ if (derived->f2k_derived == NULL)
+ derived->f2k_derived = gfc_get_namespace (NULL, 0);
+
+ while (peek_atom () != ATOM_RPAREN)
+ {
+ mio_lparen ();
+ mio_internal_string (name);
+ mio_internal_string (module);
+
+ /* Only use one use name to find the symbol. */
+ nuse = number_use_names (name, false);
+ j = 1;
+ p = find_use_name_n (name, &j, false);
+ if (p)
+ {
+ st = gfc_find_symtree (gfc_current_ns->sym_root, p);
+ dt = st->n.sym;
+ st = gfc_find_symtree (derived->f2k_derived->sym_root, name);
+ if (st == NULL)
+ {
+ /* Only use the real name in f2k_derived to ensure a single
+ symtree. */
+ st = gfc_new_symtree (&derived->f2k_derived->sym_root, name);
+ st->n.sym = dt;
+ st->n.sym->refs++;
+ }
+ }
+ mio_rparen ();
+ }
+ mio_rparen ();
+ }
+ mio_rparen ();
+}
+
+
/* Recursive function to traverse the pointer_info tree and load a
needed symbol. We return nonzero if we load a symbol and stop the
traversal, because the act of loading can alter the tree. */
@@ -4113,7 +4179,7 @@ check_for_ambiguous (gfc_symbol *st_sym, pointer_info *info)
static void
read_module (void)
{
- module_locus operator_interfaces, user_operators;
+ module_locus operator_interfaces, user_operators, extensions;
const char *p;
char name[GFC_MAX_SYMBOL_LEN + 1];
int i;
@@ -4130,10 +4196,13 @@ read_module (void)
skip_list ();
skip_list ();
- /* Skip commons and equivalences for now. */
+ /* Skip commons, equivalences and derived type extensions for now. */
skip_list ();
skip_list ();
+ get_module_locus (&extensions);
+ skip_list ();
+
mio_lparen ();
/* Create the fixup nodes for all the symbols. */
@@ -4386,6 +4455,11 @@ read_module (void)
gfc_check_interfaces (gfc_current_ns);
+ /* Now we should be in a position to fill f2k_derived with derived type
+ extensions, since everything has been loaded. */
+ set_module_locus (&extensions);
+ load_derived_extensions ();
+
/* Clean up symbol nodes that were never loaded, create references
to hidden symbols. */
@@ -4594,6 +4668,36 @@ write_equiv (void)
}
+/* Write derived type extensions to the module. */
+
+static void
+write_dt_extensions (gfc_symtree *st)
+{
+ mio_lparen ();
+ mio_pool_string (&st->n.sym->name);
+ if (st->n.sym->module != NULL)
+ mio_pool_string (&st->n.sym->module);
+ else
+ mio_internal_string (module_name);
+ mio_rparen ();
+}
+
+static void
+write_derived_extensions (gfc_symtree *st)
+{
+ if (!((st->n.sym->attr.flavor == FL_DERIVED)
+ && (st->n.sym->f2k_derived != NULL)
+ && (st->n.sym->f2k_derived->sym_root != NULL)))
+ return;
+
+ mio_lparen ();
+ mio_symbol_ref (&(st->n.sym));
+ gfc_traverse_symtree (st->n.sym->f2k_derived->sym_root,
+ write_dt_extensions);
+ mio_rparen ();
+}
+
+
/* Write a symbol to the module. */
static void
@@ -4820,6 +4924,13 @@ write_module (void)
write_char ('\n');
write_char ('\n');
+ mio_lparen ();
+ gfc_traverse_symtree (gfc_current_ns->sym_root,
+ write_derived_extensions);
+ mio_rparen ();
+ write_char ('\n');
+ write_char ('\n');
+
/* Write symbol information. First we traverse all symbols in the
primary namespace, writing those that need to be written.
Sometimes writing one symbol will cause another to need to be
diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c
index 3e20f8e45d4..3742addb6b1 100644
--- a/gcc/fortran/options.c
+++ b/gcc/fortran/options.c
@@ -242,6 +242,10 @@ gfc_post_options (const char **pfilename)
if (flag_whole_program)
gfc_option.flag_whole_file = 1;
+ /* Enable whole-file mode if LTO is in effect. */
+ if (flag_lto || flag_whopr)
+ gfc_option.flag_whole_file = 1;
+
/* -fbounds-check is equivalent to -fcheck=bounds */
if (flag_bounds_check)
gfc_option.rtcheck |= GFC_RTCHECK_BOUNDS;
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 13199c91bb0..95a327bf23d 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -2068,11 +2068,15 @@ endType:
{
/* Look for allocatable components. */
if (c->attr.allocatable
+ || (c->ts.type == BT_CLASS
+ && c->ts.u.derived->components->attr.allocatable)
|| (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.alloc_comp))
sym->attr.alloc_comp = 1;
/* Look for pointer components. */
if (c->attr.pointer
+ || (c->ts.type == BT_CLASS
+ && c->ts.u.derived->components->attr.pointer)
|| (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pointer_comp))
sym->attr.pointer_comp = 1;
@@ -2887,6 +2891,17 @@ parse_select_block (void)
}
+/* Pop the current selector from the SELECT TYPE stack. */
+
+static void
+select_type_pop (void)
+{
+ gfc_select_type_stack *old = select_type_stack;
+ select_type_stack = old->prev;
+ gfc_free (old);
+}
+
+
/* Parse a SELECT TYPE construct (F03:R821). */
static void
@@ -2909,12 +2924,8 @@ parse_select_type_block (void)
if (st == ST_NONE)
unexpected_eof ();
if (st == ST_END_SELECT)
- {
- /* Empty SELECT CASE is OK. */
- accept_statement (st);
- pop_state ();
- return;
- }
+ /* Empty SELECT CASE is OK. */
+ goto done;
if (st == ST_TYPE_IS || st == ST_CLASS_IS)
break;
@@ -2959,8 +2970,11 @@ parse_select_type_block (void)
}
while (st != ST_END_SELECT);
+done:
pop_state ();
accept_statement (st);
+ gfc_current_ns = gfc_current_ns->parent;
+ select_type_pop ();
}
@@ -3033,18 +3047,13 @@ check_do_closure (void)
static void parse_progunit (gfc_statement);
-/* Parse a BLOCK construct. */
+/* Set up the local namespace for a BLOCK construct. */
-static void
-parse_block_construct (void)
+gfc_namespace*
+gfc_build_block_ns (gfc_namespace *parent_ns)
{
- gfc_namespace* parent_ns;
gfc_namespace* my_ns;
- gfc_state_data s;
-
- gfc_notify_std (GFC_STD_F2008, "Fortran 2008: BLOCK construct at %C");
- parent_ns = gfc_current_ns;
my_ns = gfc_get_namespace (parent_ns, 1);
my_ns->construct_entities = 1;
@@ -3064,7 +3073,25 @@ parse_block_construct (void)
my_ns->proc_name->name, NULL);
gcc_assert (t == SUCCESS);
}
- my_ns->proc_name->attr.recursive = parent_ns->proc_name->attr.recursive;
+
+ if (parent_ns->proc_name)
+ my_ns->proc_name->attr.recursive = parent_ns->proc_name->attr.recursive;
+
+ return my_ns;
+}
+
+
+/* Parse a BLOCK construct. */
+
+static void
+parse_block_construct (void)
+{
+ gfc_namespace* my_ns;
+ gfc_state_data s;
+
+ gfc_notify_std (GFC_STD_F2008, "Fortran 2008: BLOCK construct at %C");
+
+ my_ns = gfc_build_block_ns (gfc_current_ns);
new_st.op = EXEC_BLOCK;
new_st.ext.ns = my_ns;
@@ -3075,7 +3102,7 @@ parse_block_construct (void)
parse_progunit (ST_NONE);
- gfc_current_ns = parent_ns;
+ gfc_current_ns = gfc_current_ns->parent;
pop_state ();
}
diff --git a/gcc/fortran/parse.h b/gcc/fortran/parse.h
index 2b926618d28..e0a2969c2a3 100644
--- a/gcc/fortran/parse.h
+++ b/gcc/fortran/parse.h
@@ -70,4 +70,5 @@ match gfc_match_enumerator_def (void);
void gfc_free_enum_history (void);
extern bool gfc_matching_function;
match gfc_match_prefix (gfc_typespec *);
+gfc_namespace* gfc_build_block_ns (gfc_namespace *);
#endif /* GFC_PARSE_H */
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index bb803b3475c..a721d944b33 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -367,15 +367,26 @@ resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
/* 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 are not on that list;
- ergo, not permitted. */
+ in external functions. Internal function results and results of module
+ procedures are not on this list, ergo, not permitted. */
if (sym->result->ts.type == BT_CHARACTER)
{
gfc_charlen *cl = sym->result->ts.u.cl;
if (!cl || !cl->length)
- gfc_error ("Character-valued internal function '%s' at %L must "
- "not be assumed length", sym->name, &sym->declared_at);
+ {
+ /* See if this is a module-procedure and adapt error message
+ accordingly. */
+ bool module_proc;
+ gcc_assert (ns->parent && ns->parent->proc_name);
+ module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE);
+
+ gfc_error ("Character-valued %s '%s' at %L must not be"
+ " assumed length",
+ module_proc ? _("module procedure")
+ : _("internal function"),
+ sym->name, &sym->declared_at);
+ }
}
}
@@ -2515,7 +2526,9 @@ resolve_function (gfc_expr *expr)
return FAILURE;
}
- if (sym && sym->attr.abstract)
+ /* If this ia a deferred TBP with an abstract interface (which may
+ of course be referenced), expr->value.function.name will be set. */
+ if (sym && sym->attr.abstract && !expr->value.function.name)
{
gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
sym->name, &expr->where);
@@ -3127,6 +3140,15 @@ resolve_call (gfc_code *c)
}
}
+ /* If this ia a deferred TBP with an abstract interface
+ (which may of course be referenced), c->expr1 will be set. */
+ if (csym && csym->attr.abstract && !c->expr1)
+ {
+ gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
+ csym->name, &c->loc);
+ return FAILURE;
+ }
+
/* Subroutines without the RECURSIVE attribution are not allowed to
* call themselves. */
if (csym && is_illegal_recursion (csym, gfc_current_ns))
@@ -4997,28 +5019,42 @@ resolve_typebound_call (gfc_code* c)
c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL);
gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual);
+
gfc_free_expr (c->expr1);
- c->expr1 = NULL;
+ c->expr1 = gfc_get_expr ();
+ c->expr1->expr_type = EXPR_FUNCTION;
+ c->expr1->symtree = target;
+ c->expr1->where = c->loc;
return resolve_call (c);
}
-/* Resolve a component-call expression. */
-
+/* Resolve a component-call expression. This originally was intended
+ only to see functions. However, it is convenient to use it in
+ resolving subroutine class methods, since we do not have to add a
+ gfc_code each time. */
static gfc_try
-resolve_compcall (gfc_expr* e)
+resolve_compcall (gfc_expr* e, bool fcn)
{
gfc_actual_arglist* newactual;
gfc_symtree* target;
/* Check that's really a FUNCTION. */
- if (!e->value.compcall.tbp->function)
+ if (fcn && !e->value.compcall.tbp->function)
{
gfc_error ("'%s' at %L should be a FUNCTION",
e->value.compcall.name, &e->where);
return FAILURE;
}
+ else if (!fcn && !e->value.compcall.tbp->subroutine)
+ {
+ /* To resolve class member calls, we borrow this bit
+ of code to select the specific procedures. */
+ gfc_error ("'%s' at %L should be a SUBROUTINE",
+ e->value.compcall.name, &e->where);
+ return FAILURE;
+ }
/* These must not be assign-calls! */
gcc_assert (!e->value.compcall.assign);
@@ -5043,12 +5079,337 @@ resolve_compcall (gfc_expr* e)
e->value.function.actual = newactual;
e->value.function.name = e->value.compcall.name;
e->value.function.esym = target->n.sym;
+ e->value.function.class_esym = NULL;
e->value.function.isym = NULL;
e->symtree = target;
e->ts = target->n.sym->ts;
e->expr_type = EXPR_FUNCTION;
- return gfc_resolve_expr (e);
+ /* Resolution is not necessary if this is a class subroutine; this
+ function only has to identify the specific proc. Resolution of
+ the call will be done next in resolve_typebound_call. */
+ return fcn ? gfc_resolve_expr (e) : SUCCESS;
+}
+
+
+/* Resolve a typebound call for the members in a class. This group of
+ functions implements dynamic dispatch in the provisional version
+ of f03 OOP. As soon as vtables are in place and contain pointers
+ to methods, this will no longer be necessary. */
+static gfc_expr *list_e;
+static void check_class_members (gfc_symbol *);
+static gfc_try class_try;
+static bool fcn_flag;
+static gfc_symbol *class_object;
+
+
+static void
+check_members (gfc_symbol *derived)
+{
+ if (derived->attr.flavor == FL_DERIVED)
+ check_class_members (derived);
+}
+
+
+static void
+check_class_members (gfc_symbol *derived)
+{
+ gfc_symbol* tbp_sym;
+ gfc_expr *e;
+ gfc_symtree *tbp;
+ gfc_class_esym_list *etmp;
+
+ e = gfc_copy_expr (list_e);
+
+ tbp = gfc_find_typebound_proc (derived, &class_try,
+ e->value.compcall.name,
+ false, &e->where);
+
+ if (tbp == NULL)
+ {
+ gfc_error ("no typebound available procedure named '%s' at %L",
+ e->value.compcall.name, &e->where);
+ return;
+ }
+
+ if (tbp->n.tb->is_generic)
+ {
+ tbp_sym = NULL;
+
+ /* If we have to match a passed class member, force the actual
+ expression to have the correct type. */
+ if (!tbp->n.tb->nopass)
+ {
+ if (e->value.compcall.base_object == NULL)
+ e->value.compcall.base_object =
+ extract_compcall_passed_object (e);
+
+ e->value.compcall.base_object->ts.type = BT_DERIVED;
+ e->value.compcall.base_object->ts.u.derived = derived;
+ }
+ }
+ else
+ tbp_sym = tbp->n.tb->u.specific->n.sym;
+
+ e->value.compcall.tbp = tbp->n.tb;
+ e->value.compcall.name = tbp->name;
+
+ /* Let the original expresssion catch the assertion in
+ resolve_compcall, since this flag does not appear to be reset or
+ copied in some systems. */
+ e->value.compcall.assign = 0;
+
+ /* Do the renaming, PASSing, generic => specific and other
+ good things for each class member. */
+ class_try = (resolve_compcall (e, fcn_flag) == SUCCESS)
+ ? class_try : FAILURE;
+
+ /* Now transfer the found symbol to the esym list. */
+ if (class_try == SUCCESS)
+ {
+ etmp = list_e->value.function.class_esym;
+ list_e->value.function.class_esym
+ = gfc_get_class_esym_list();
+ list_e->value.function.class_esym->next = etmp;
+ list_e->value.function.class_esym->derived = derived;
+ list_e->value.function.class_esym->esym
+ = e->value.function.esym;
+ }
+
+ gfc_free_expr (e);
+
+ /* Burrow down into grandchildren types. */
+ if (derived->f2k_derived)
+ gfc_traverse_ns (derived->f2k_derived, check_members);
+}
+
+
+/* Eliminate esym_lists where all the members point to the
+ typebound procedure of the declared type; ie. one where
+ type selection has no effect.. */
+static void
+resolve_class_esym (gfc_expr *e)
+{
+ gfc_class_esym_list *p, *q;
+ bool empty = true;
+
+ gcc_assert (e && e->expr_type == EXPR_FUNCTION);
+
+ p = e->value.function.class_esym;
+ if (p == NULL)
+ return;
+
+ for (; p; p = p->next)
+ empty = empty && (e->value.function.esym == p->esym);
+
+ if (empty)
+ {
+ p = e->value.function.class_esym;
+ for (; p; p = q)
+ {
+ q = p->next;
+ gfc_free (p);
+ }
+ e->value.function.class_esym = NULL;
+ }
+}
+
+
+/* Generate an expression for the vindex, given the reference to
+ the class of the final expression (class_ref), the base of the
+ full reference list (new_ref), the declared type and the class
+ object (st). */
+static gfc_expr*
+vindex_expr (gfc_ref *class_ref, gfc_ref *new_ref,
+ gfc_symbol *declared, gfc_symtree *st)
+{
+ gfc_expr *vindex;
+ gfc_ref *ref;
+
+ /* Build an expression for the correct vindex; ie. that of the last
+ CLASS reference. */
+ ref = gfc_get_ref();
+ ref->type = REF_COMPONENT;
+ ref->u.c.component = declared->components->next;
+ ref->u.c.sym = declared;
+ ref->next = NULL;
+ if (class_ref)
+ {
+ class_ref->next = ref;
+ }
+ else
+ {
+ gfc_free_ref_list (new_ref);
+ new_ref = ref;
+ }
+ vindex = gfc_get_expr ();
+ vindex->expr_type = EXPR_VARIABLE;
+ vindex->symtree = st;
+ vindex->symtree->n.sym->refs++;
+ vindex->ts = ref->u.c.component->ts;
+ vindex->ref = new_ref;
+
+ return vindex;
+}
+
+
+/* Get the ultimate declared type from an expression. In addition,
+ return the last class/derived type reference and the copy of the
+ reference list. */
+static gfc_symbol*
+get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
+ gfc_expr *e)
+{
+ gfc_symbol *declared;
+ gfc_ref *ref;
+
+ declared = NULL;
+ *class_ref = NULL;
+ *new_ref = gfc_copy_ref (e->ref);
+ for (ref = *new_ref; ref; ref = ref->next)
+ {
+ if (ref->type != REF_COMPONENT)
+ continue;
+
+ if (ref->u.c.component->ts.type == BT_CLASS
+ || ref->u.c.component->ts.type == BT_DERIVED)
+ {
+ declared = ref->u.c.component->ts.u.derived;
+ *class_ref = ref;
+ }
+ }
+
+ if (declared == NULL)
+ declared = e->symtree->n.sym->ts.u.derived;
+
+ return declared;
+}
+
+
+/* Resolve the argument expressions so that any arguments expressions
+ that include class methods are resolved before the current call.
+ This is necessary because of the static variables used in CLASS
+ method resolution. */
+static void
+resolve_arg_exprs (gfc_actual_arglist *arg)
+{
+ /* Resolve the actual arglist expressions. */
+ for (; arg; arg = arg->next)
+ {
+ if (arg->expr)
+ gfc_resolve_expr (arg->expr);
+ }
+}
+
+
+/* Resolve a CLASS typebound function, or 'method'. */
+static gfc_try
+resolve_class_compcall (gfc_expr* e)
+{
+ gfc_symbol *derived, *declared;
+ gfc_ref *new_ref;
+ gfc_ref *class_ref;
+ gfc_symtree *st;
+
+ st = e->symtree;
+ class_object = st->n.sym;
+
+ /* Get the CLASS declared type. */
+ declared = get_declared_from_expr (&class_ref, &new_ref, e);
+
+ /* Weed out cases of the ultimate component being a derived type. */
+ if (class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
+ {
+ gfc_free_ref_list (new_ref);
+ return resolve_compcall (e, true);
+ }
+
+ /* Resolve the argument expressions, */
+ resolve_arg_exprs (e->value.function.actual);
+
+ /* Get the data component, which is of the declared type. */
+ derived = declared->components->ts.u.derived;
+
+ /* Resolve the function call for each member of the class. */
+ class_try = SUCCESS;
+ fcn_flag = true;
+ list_e = gfc_copy_expr (e);
+ check_class_members (derived);
+
+ class_try = (resolve_compcall (e, true) == SUCCESS)
+ ? class_try : FAILURE;
+
+ /* Transfer the class list to the original expression. Note that
+ the class_esym list is cleaned up in trans-expr.c, as the calls
+ are translated. */
+ e->value.function.class_esym = list_e->value.function.class_esym;
+ list_e->value.function.class_esym = NULL;
+ gfc_free_expr (list_e);
+
+ resolve_class_esym (e);
+
+ /* More than one typebound procedure so transmit an expression for
+ the vindex as the selector. */
+ if (e->value.function.class_esym != NULL)
+ e->value.function.class_esym->vindex
+ = vindex_expr (class_ref, new_ref, declared, st);
+
+ return class_try;
+}
+
+/* Resolve a CLASS typebound subroutine, or 'method'. */
+static gfc_try
+resolve_class_typebound_call (gfc_code *code)
+{
+ gfc_symbol *derived, *declared;
+ gfc_ref *new_ref;
+ gfc_ref *class_ref;
+ gfc_symtree *st;
+
+ st = code->expr1->symtree;
+ class_object = st->n.sym;
+
+ /* Get the CLASS declared type. */
+ declared = get_declared_from_expr (&class_ref, &new_ref, code->expr1);
+
+ /* Weed out cases of the ultimate component being a derived type. */
+ if (class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
+ {
+ gfc_free_ref_list (new_ref);
+ return resolve_typebound_call (code);
+ }
+
+ /* Resolve the argument expressions, */
+ resolve_arg_exprs (code->expr1->value.compcall.actual);
+
+ /* Get the data component, which is of the declared type. */
+ derived = declared->components->ts.u.derived;
+
+ class_try = SUCCESS;
+ fcn_flag = false;
+ list_e = gfc_copy_expr (code->expr1);
+ check_class_members (derived);
+
+ class_try = (resolve_typebound_call (code) == SUCCESS)
+ ? class_try : FAILURE;
+
+ /* Transfer the class list to the original expression. Note that
+ the class_esym list is cleaned up in trans-expr.c, as the calls
+ are translated. */
+ code->expr1->value.function.class_esym
+ = list_e->value.function.class_esym;
+ list_e->value.function.class_esym = NULL;
+ gfc_free_expr (list_e);
+
+ resolve_class_esym (code->expr1);
+
+ /* More than one typebound procedure so transmit an expression for
+ the vindex as the selector. */
+ if (code->expr1->value.function.class_esym != NULL)
+ code->expr1->value.function.class_esym->vindex
+ = vindex_expr (class_ref, new_ref, declared, st);
+
+ return class_try;
}
@@ -5162,7 +5523,10 @@ gfc_resolve_expr (gfc_expr *e)
break;
case EXPR_COMPCALL:
- t = resolve_compcall (e);
+ if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
+ t = resolve_class_compcall (e);
+ else
+ t = resolve_compcall (e, true);
break;
case EXPR_SUBSTRING:
@@ -5605,6 +5969,58 @@ gfc_expr_to_initialize (gfc_expr *e)
}
+/* Used in resolve_allocate_expr to check that a allocation-object and
+ a source-expr are conformable. This does not catch all possible
+ cases; in particular a runtime checking is needed. */
+
+static gfc_try
+conformable_arrays (gfc_expr *e1, gfc_expr *e2)
+{
+ /* First compare rank. */
+ if (e2->ref && e1->rank != e2->ref->u.ar.as->rank)
+ {
+ gfc_error ("Source-expr at %L must be scalar or have the "
+ "same rank as the allocate-object at %L",
+ &e1->where, &e2->where);
+ return FAILURE;
+ }
+
+ if (e1->shape)
+ {
+ int i;
+ mpz_t s;
+
+ mpz_init (s);
+
+ for (i = 0; i < e1->rank; i++)
+ {
+ if (e2->ref->u.ar.end[i])
+ {
+ mpz_set (s, e2->ref->u.ar.end[i]->value.integer);
+ mpz_sub (s, s, e2->ref->u.ar.start[i]->value.integer);
+ mpz_add_ui (s, s, 1);
+ }
+ else
+ {
+ mpz_set (s, e2->ref->u.ar.start[i]->value.integer);
+ }
+
+ if (mpz_cmp (e1->shape[i], s) != 0)
+ {
+ gfc_error ("Source-expr at %L and allocate-object at %L must "
+ "have the same shape", &e1->where, &e2->where);
+ mpz_clear (s);
+ return FAILURE;
+ }
+ }
+
+ mpz_clear (s);
+ }
+
+ return SUCCESS;
+}
+
+
/* Resolve the expression in an ALLOCATE statement, doing the additional
checks to see whether the expression is OK or not. The expression must
have a trailing array reference that gives the size of the array. */
@@ -5612,11 +6028,10 @@ gfc_expr_to_initialize (gfc_expr *e)
static gfc_try
resolve_allocate_expr (gfc_expr *e, gfc_code *code)
{
- int i, pointer, allocatable, dimension, check_intent_in;
+ int i, pointer, allocatable, dimension, check_intent_in, is_abstract;
symbol_attribute attr;
gfc_ref *ref, *ref2;
gfc_array_ref *ar;
- gfc_code *init_st;
gfc_symbol *sym;
gfc_alloc *a;
gfc_component *c;
@@ -5634,6 +6049,9 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
if (e->symtree)
sym = e->symtree->n.sym;
+ /* Check whether ultimate component is abstract and CLASS. */
+ is_abstract = 0;
+
if (e->expr_type != EXPR_VARIABLE)
{
allocatable = 0;
@@ -5648,6 +6066,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
allocatable = sym->ts.u.derived->components->attr.allocatable;
pointer = sym->ts.u.derived->components->attr.pointer;
dimension = sym->ts.u.derived->components->attr.dimension;
+ is_abstract = sym->ts.u.derived->components->attr.abstract;
}
else
{
@@ -5675,12 +6094,14 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
allocatable = c->ts.u.derived->components->attr.allocatable;
pointer = c->ts.u.derived->components->attr.pointer;
dimension = c->ts.u.derived->components->attr.dimension;
+ is_abstract = c->ts.u.derived->components->attr.abstract;
}
else
{
allocatable = c->attr.allocatable;
pointer = c->attr.pointer;
dimension = c->attr.dimension;
+ is_abstract = c->attr.abstract;
}
break;
@@ -5699,46 +6120,44 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
return FAILURE;
}
- if (check_intent_in && sym->attr.intent == INTENT_IN)
- {
- gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
- sym->name, &e->where);
- return FAILURE;
- }
-
- if (e->ts.type == BT_CLASS)
+ /* Some checks for the SOURCE tag. */
+ if (code->expr3)
{
- /* Initialize VINDEX for CLASS objects. */
- init_st = gfc_get_code ();
- init_st->loc = code->loc;
- init_st->expr1 = gfc_expr_to_initialize (e);
- init_st->op = EXEC_ASSIGN;
- gfc_add_component_ref (init_st->expr1, "$vindex");
- if (code->expr3 && code->expr3->ts.type == BT_CLASS)
+ /* Check F03:C631. */
+ if (!gfc_type_compatible (&e->ts, &code->expr3->ts))
{
- /* vindex must be determined at run time. */
- init_st->expr2 = gfc_copy_expr (code->expr3);
- gfc_add_component_ref (init_st->expr2, "$vindex");
+ gfc_error ("Type of entity at %L is type incompatible with "
+ "source-expr at %L", &e->where, &code->expr3->where);
+ return FAILURE;
}
- else
+
+ /* Check F03:C632 and restriction following Note 6.18. */
+ if (code->expr3->rank > 0
+ && conformable_arrays (code->expr3, e) == FAILURE)
+ return FAILURE;
+
+ /* Check F03:C633. */
+ if (code->expr3->ts.kind != e->ts.kind)
{
- /* vindex is fixed at compile time. */
- int vindex;
- if (code->expr3)
- vindex = code->expr3->ts.u.derived->vindex;
- else if (code->ext.alloc.ts.type == BT_DERIVED)
- vindex = code->ext.alloc.ts.u.derived->vindex;
- else if (e->ts.type == BT_CLASS)
- vindex = e->ts.u.derived->components->ts.u.derived->vindex;
- else
- vindex = e->ts.u.derived->vindex;
- init_st->expr2 = gfc_int_expr (vindex);
+ gfc_error ("The allocate-object at %L and the source-expr at %L "
+ "shall have the same kind type parameter",
+ &e->where, &code->expr3->where);
+ return FAILURE;
}
- init_st->expr2->where = init_st->expr1->where = init_st->loc;
- init_st->next = code->next;
- code->next = init_st;
- /* Only allocate the DATA component. */
- gfc_add_component_ref (e, "$data");
+ }
+ else if (is_abstract&& code->ext.alloc.ts.type == BT_UNKNOWN)
+ {
+ gcc_assert (e->ts.type == BT_CLASS);
+ gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
+ "type-spec or SOURCE=", sym->name, &e->where);
+ return FAILURE;
+ }
+
+ if (check_intent_in && sym->attr.intent == INTENT_IN)
+ {
+ gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
+ sym->name, &e->where);
+ return FAILURE;
}
if (pointer || dimension == 0)
@@ -5790,7 +6209,7 @@ check_symbols:
sym = a->expr->symtree->n.sym;
/* TODO - check derived type components. */
- if (sym->ts.type == BT_DERIVED)
+ if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
continue;
if ((ar->start[i] != NULL
@@ -6444,8 +6863,15 @@ resolve_select_type (gfc_code *code)
gfc_case *c, *default_case;
gfc_symtree *st;
char name[GFC_MAX_SYMBOL_LEN];
+ gfc_namespace *ns;
- selector_type = code->expr1->ts.u.derived->components->ts.u.derived;
+ ns = code->ext.ns;
+ gfc_resolve (ns);
+
+ if (code->expr2)
+ selector_type = code->expr2->ts.u.derived->components->ts.u.derived;
+ else
+ selector_type = code->expr1->ts.u.derived->components->ts.u.derived;
/* Assume there is no DEFAULT case. */
default_case = NULL;
@@ -6487,6 +6913,32 @@ resolve_select_type (gfc_code *code)
}
}
+ if (code->expr2)
+ {
+ /* Insert assignment for selector variable. */
+ new_st = gfc_get_code ();
+ new_st->op = EXEC_ASSIGN;
+ new_st->expr1 = gfc_copy_expr (code->expr1);
+ new_st->expr2 = gfc_copy_expr (code->expr2);
+ ns->code = new_st;
+ }
+
+ /* Put SELECT TYPE statement inside a BLOCK. */
+ new_st = gfc_get_code ();
+ new_st->op = code->op;
+ new_st->expr1 = code->expr1;
+ new_st->expr2 = code->expr2;
+ new_st->block = code->block;
+ if (!ns->code)
+ ns->code = new_st;
+ else
+ ns->code->next = new_st;
+ code->op = EXEC_BLOCK;
+ code->expr1 = code->expr2 = NULL;
+ code->block = NULL;
+
+ code = new_st;
+
/* Transform to EXEC_SELECT. */
code->op = EXEC_SELECT;
gfc_add_component_ref (code->expr1, "$vindex");
@@ -6506,7 +6958,7 @@ resolve_select_type (gfc_code *code)
continue;
/* Assign temporary to selector. */
sprintf (name, "tmp$%s", c->ts.u.derived->name);
- st = gfc_find_symtree (code->expr1->symtree->n.sym->ns->sym_root, name);
+ st = gfc_find_symtree (ns->sym_root, name);
new_st = gfc_get_code ();
new_st->op = EXEC_POINTER_ASSIGN;
new_st->expr1 = gfc_get_variable_expr (st);
@@ -7287,46 +7739,16 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
}
}
- gfc_check_assign (lhs, rhs, 1);
- return false;
-}
-
-
-/* Check an assignment to a CLASS object (pointer or ordinary assignment). */
-
-static void
-resolve_class_assign (gfc_code *code)
-{
- gfc_code *assign_code = gfc_get_code ();
-
- if (code->expr2->ts.type != BT_CLASS)
+ /* F03:7.4.1.2. */
+ if (lhs->ts.type == BT_CLASS)
{
- /* Insert an additional assignment which sets the vindex. */
- assign_code->next = code->next;
- code->next = assign_code;
- assign_code->op = EXEC_ASSIGN;
- assign_code->expr1 = gfc_copy_expr (code->expr1);
- gfc_add_component_ref (assign_code->expr1, "$vindex");
- if (code->expr2->ts.type == BT_DERIVED)
- /* vindex is constant, determined at compile time. */
- assign_code->expr2 = gfc_int_expr (code->expr2->ts.u.derived->vindex);
- else if (code->expr2->ts.type == BT_CLASS)
- {
- /* vindex must be determined at run time. */
- assign_code->expr2 = gfc_copy_expr (code->expr2);
- gfc_add_component_ref (assign_code->expr2, "$vindex");
- }
- else if (code->expr2->expr_type == EXPR_NULL)
- assign_code->expr2 = gfc_int_expr (0);
- else
- gcc_unreachable ();
+ gfc_error ("Variable must not be polymorphic in assignment at %L",
+ &lhs->where);
+ return false;
}
- /* Modify the actual pointer assignment. */
- if (code->expr2->ts.type == BT_CLASS)
- code->op = EXEC_ASSIGN;
- else
- gfc_add_component_ref (code->expr1, "$data");
+ gfc_check_assign (lhs, rhs, 1);
+ return false;
}
@@ -7400,6 +7822,10 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
if (gfc_resolve_expr (code->expr2) == FAILURE)
t = FAILURE;
+ if (code->op == EXEC_ALLOCATE
+ && gfc_resolve_expr (code->expr3) == FAILURE)
+ t = FAILURE;
+
switch (code->op)
{
case EXEC_NOP:
@@ -7452,9 +7878,6 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
if (t == FAILURE)
break;
- if (code->expr1->ts.type == BT_CLASS)
- resolve_class_assign (code);
-
if (resolve_ordinary_assign (code, ns))
{
if (code->op == EXEC_COMPCALL)
@@ -7462,7 +7885,6 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
else
goto call;
}
-
break;
case EXEC_LABEL_ASSIGN:
@@ -7483,11 +7905,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
if (t == FAILURE)
break;
- if (code->expr1->ts.type == BT_CLASS)
- resolve_class_assign (code);
-
gfc_check_pointer_assign (code->expr1, code->expr2);
-
break;
case EXEC_ARITHMETIC_IF:
@@ -7517,7 +7935,11 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
case EXEC_COMPCALL:
compcall:
- resolve_typebound_call (code);
+ if (code->expr1->symtree
+ && code->expr1->symtree->n.sym->ts.type == BT_CLASS)
+ resolve_class_typebound_call (code);
+ else
+ resolve_typebound_call (code);
break;
case EXEC_CALL_PPC:
@@ -8219,7 +8641,8 @@ apply_default_init_local (gfc_symbol *sym)
/* For saved variables, we don't want to add an initializer at
function entry, so we just add a static initializer. */
- if (sym->attr.save || sym->ns->save_all)
+ if (sym->attr.save || sym->ns->save_all
+ || gfc_option.flag_max_stack_var_size == 0)
{
/* Don't clobber an existing initializer! */
gcc_assert (sym->value == NULL);
@@ -8333,9 +8756,8 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
}
/* C509. */
- if (!(sym->attr.dummy || sym->attr.allocatable || sym->attr.pointer
- || sym->ts.u.derived->components->attr.allocatable
- || sym->ts.u.derived->components->attr.pointer))
+ /* Assume that use associated symbols were checked in the module ns. */
+ if (!sym->attr.class_ok && !sym->attr.use_assoc)
{
gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
"or pointer", sym->name, &sym->declared_at);
@@ -11724,7 +12146,11 @@ resolve_codes (gfc_namespace *ns)
resolve_codes (n);
gfc_current_ns = ns;
- cs_base = NULL;
+
+ /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
+ if (!(ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL))
+ cs_base = NULL;
+
/* Set to an out of range value. */
current_entry_id = -1;
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 39285b16fea..c1b39b0d9f1 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -2030,9 +2030,16 @@ gfc_st_label *
gfc_get_st_label (int labelno)
{
gfc_st_label *lp;
+ gfc_namespace *ns;
+
+ /* Find the namespace of the scoping unit:
+ If we're in a BLOCK construct, jump to the parent namespace. */
+ ns = gfc_current_ns;
+ while (ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL)
+ ns = ns->parent;
/* First see if the label is already in this namespace. */
- lp = gfc_current_ns->st_labels;
+ lp = ns->st_labels;
while (lp)
{
if (lp->value == labelno)
@@ -2050,7 +2057,7 @@ gfc_get_st_label (int labelno)
lp->defined = ST_LABEL_UNKNOWN;
lp->referenced = ST_LABEL_UNKNOWN;
- gfc_insert_bbt (&gfc_current_ns->st_labels, lp, compare_st_labels);
+ gfc_insert_bbt (&ns->st_labels, lp, compare_st_labels);
return lp;
}
@@ -2461,6 +2468,19 @@ ambiguous_symbol (const char *name, gfc_symtree *st)
}
+/* If we're in a SELECT TYPE block, check if the variable 'st' matches any
+ selector on the stack. If yes, replace it by the corresponding temporary. */
+
+static void
+select_type_insert_tmp (gfc_symtree **st)
+{
+ gfc_select_type_stack *stack = select_type_stack;
+ for (; stack; stack = stack->prev)
+ if ((*st)->n.sym == stack->selector)
+ *st = stack->tmp;
+}
+
+
/* Search for a symtree starting in the current namespace, resorting to
any parent namespaces if requested by a nonzero parent_flag.
Returns nonzero if the name is ambiguous. */
@@ -2479,6 +2499,8 @@ gfc_find_sym_tree (const char *name, gfc_namespace *ns, int parent_flag,
st = gfc_find_symtree (ns->sym_root, name);
if (st != NULL)
{
+ select_type_insert_tmp (&st);
+
*result = st;
/* Ambiguous generic interfaces are permitted, as long
as the specific interfaces are different. */
@@ -2645,12 +2667,6 @@ gfc_get_ha_sym_tree (const char *name, gfc_symtree **result)
i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
- /* Special case: If we're in a SELECT TYPE block,
- replace the selector variable by a temporary. */
- if (gfc_current_state () == COMP_SELECT_TYPE
- && st && st->n.sym == type_selector)
- st = select_type_tmp;
-
if (st != NULL)
{
save_symbol_data (st->n.sym);
@@ -2732,7 +2748,7 @@ gfc_undo_symbols (void)
if (p->gfc_new)
{
/* Symbol was new. */
- if (p->attr.in_common && p->common_block->head)
+ if (p->attr.in_common && p->common_block && p->common_block->head)
{
/* If the symbol was added to any common block, it
needs to be removed to stop the resolver looking
@@ -4579,9 +4595,12 @@ gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2)
if ((ts1->type == BT_DERIVED || ts1->type == BT_CLASS)
&& (ts2->type == BT_DERIVED || ts2->type == BT_CLASS))
{
- if (ts1->type == BT_CLASS)
+ if (ts1->type == BT_CLASS && ts2->type == BT_DERIVED)
return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
ts2->u.derived);
+ else if (ts1->type == BT_CLASS && ts2->type == BT_CLASS)
+ return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
+ ts2->u.derived->components->ts.u.derived);
else if (ts2->type != BT_CLASS)
return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived);
else
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index e16200010d1..4e94373133a 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -5906,6 +5906,36 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
tmp = gfc_trans_dealloc_allocated (comp);
gfc_add_expr_to_block (&fnblock, tmp);
}
+ else if (c->attr.allocatable)
+ {
+ /* Allocatable scalar components. */
+ comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
+
+ tmp = gfc_deallocate_with_status (comp, NULL_TREE, true, NULL);
+ gfc_add_expr_to_block (&fnblock, tmp);
+
+ tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp,
+ build_int_cst (TREE_TYPE (comp), 0));
+ gfc_add_expr_to_block (&fnblock, tmp);
+ }
+ else if (c->ts.type == BT_CLASS
+ && c->ts.u.derived->components->attr.allocatable)
+ {
+ /* Allocatable scalar CLASS components. */
+ comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
+
+ /* Add reference to '$data' component. */
+ tmp = c->ts.u.derived->components->backend_decl;
+ comp = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
+ comp, tmp, NULL_TREE);
+
+ tmp = gfc_deallocate_with_status (comp, NULL_TREE, true, NULL);
+ gfc_add_expr_to_block (&fnblock, tmp);
+
+ tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp,
+ build_int_cst (TREE_TYPE (comp), 0));
+ gfc_add_expr_to_block (&fnblock, tmp);
+ }
break;
case NULLIFY_ALLOC_COMP:
@@ -5917,6 +5947,27 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
decl, cdecl, NULL_TREE);
gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
}
+ else if (c->attr.allocatable)
+ {
+ /* Allocatable scalar components. */
+ comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
+ tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp,
+ build_int_cst (TREE_TYPE (comp), 0));
+ gfc_add_expr_to_block (&fnblock, tmp);
+ }
+ else if (c->ts.type == BT_CLASS
+ && c->ts.u.derived->components->attr.allocatable)
+ {
+ /* Allocatable scalar CLASS components. */
+ comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
+ /* Add reference to '$data' component. */
+ tmp = c->ts.u.derived->components->backend_decl;
+ comp = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
+ comp, tmp, NULL_TREE);
+ tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp,
+ build_int_cst (TREE_TYPE (comp), 0));
+ gfc_add_expr_to_block (&fnblock, tmp);
+ }
else if (cmp_has_alloc_comps)
{
comp = fold_build3 (COMPONENT_REF, ctype,
diff --git a/gcc/fortran/trans-common.c b/gcc/fortran/trans-common.c
index 5b1952aee4a..1fb3c40f113 100644
--- a/gcc/fortran/trans-common.c
+++ b/gcc/fortran/trans-common.c
@@ -680,7 +680,6 @@ create_common (gfc_common_head *com, segment_info *head, bool saw_equiv)
var_decl = build_decl (s->sym->declared_at.lb->location,
VAR_DECL, DECL_NAME (s->field),
TREE_TYPE (s->field));
- TREE_PUBLIC (var_decl) = TREE_PUBLIC (decl);
TREE_STATIC (var_decl) = TREE_STATIC (decl);
TREE_USED (var_decl) = TREE_USED (decl);
if (s->sym->attr.use_assoc)
@@ -689,7 +688,9 @@ create_common (gfc_common_head *com, segment_info *head, bool saw_equiv)
TREE_ADDRESSABLE (var_decl) = 1;
/* This is a fake variable just for debugging purposes. */
TREE_ASM_WRITTEN (var_decl) = 1;
-
+ /* Fake variables are not visible from other translation units. */
+ TREE_PUBLIC (var_decl) = 0;
+
/* To preserve identifier names in COMMON, chain to procedure
scope unless at top level in a module definition. */
if (com
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index ee38efbe27c..200c3f5654c 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -1187,22 +1187,23 @@ gfc_get_symbol_decl (gfc_symbol * sym)
/* Create variables to hold the non-constant bits of array info. */
gfc_build_qualified_array (decl, sym);
- /* Remember this variable for allocation/cleanup. */
- gfc_defer_symbol_init (sym);
-
if ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer)
GFC_DECL_PACKED_ARRAY (decl) = 1;
}
- if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
- gfc_defer_symbol_init (sym);
- /* This applies a derived type default initializer. */
- else if (sym->ts.type == BT_DERIVED
- && sym->attr.save == SAVE_NONE
- && !sym->attr.data
- && !sym->attr.allocatable
- && (sym->value && !sym->ns->proc_name->attr.is_main_program)
- && !sym->attr.use_assoc)
+ /* Remember this variable for allocation/cleanup. */
+ if (sym->attr.dimension || sym->attr.allocatable
+ || (sym->ts.type == BT_CLASS &&
+ (sym->ts.u.derived->components->attr.dimension
+ || sym->ts.u.derived->components->attr.allocatable))
+ || (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
+ /* This applies a derived type default initializer. */
+ || (sym->ts.type == BT_DERIVED
+ && sym->attr.save == SAVE_NONE
+ && !sym->attr.data
+ && !sym->attr.allocatable
+ && (sym->value && !sym->ns->proc_name->attr.is_main_program)
+ && !sym->attr.use_assoc))
gfc_defer_symbol_init (sym);
gfc_finish_var_decl (decl, sym);
@@ -3054,7 +3055,8 @@ init_intent_out_dt (gfc_symbol * proc_sym, tree body)
Allocation and initialization of array variables.
Allocation of character string variables.
Initialization and possibly repacking of dummy arrays.
- Initialization of ASSIGN statement auxiliary variable. */
+ Initialization of ASSIGN statement auxiliary variable.
+ Automatic deallocation. */
tree
gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
@@ -3182,6 +3184,33 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
}
else if (sym_has_alloc_comp)
fnbody = gfc_trans_deferred_array (sym, fnbody);
+ else if (sym->attr.allocatable
+ || (sym->ts.type == BT_CLASS
+ && sym->ts.u.derived->components->attr.allocatable))
+ {
+ /* Automatic deallocatation of allocatable scalars. */
+ tree tmp;
+ gfc_expr *e;
+ gfc_se se;
+ stmtblock_t block;
+
+ e = gfc_lval_expr_from_sym (sym);
+ if (sym->ts.type == BT_CLASS)
+ gfc_add_component_ref (e, "$data");
+
+ gfc_init_se (&se, NULL);
+ se.want_pointer = 1;
+ gfc_conv_expr (&se, e);
+ gfc_free_expr (e);
+
+ gfc_start_block (&block);
+ gfc_add_expr_to_block (&block, fnbody);
+
+ /* Note: Nullifying is not needed. */
+ tmp = gfc_deallocate_with_status (se.expr, NULL_TREE, true, NULL);
+ gfc_add_expr_to_block (&block, tmp);
+ fnbody = gfc_finish_block (&block);
+ }
else if (sym->ts.type == BT_CHARACTER)
{
gfc_get_backend_locus (&loc);
@@ -3747,8 +3776,12 @@ generate_local_decl (gfc_symbol * sym)
else if (warn_unused_variable
&& sym->attr.dummy
&& sym->attr.intent == INTENT_OUT)
- gfc_warning ("Dummy argument '%s' at %L was declared INTENT(OUT) but was not set",
- sym->name, &sym->declared_at);
+ {
+ if (!(sym->ts.type == BT_DERIVED
+ && sym->ts.u.derived->components->initializer))
+ gfc_warning ("Dummy argument '%s' at %L was declared INTENT(OUT) "
+ "but was not set", sym->name, &sym->declared_at);
+ }
/* Specific warning for unused dummy arguments. */
else if (warn_unused_variable && sym->attr.dummy)
gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
@@ -4363,10 +4396,10 @@ gfc_generate_function_code (gfc_namespace * ns)
/* Reset recursion-check variable. */
if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) && !is_recursive)
- {
- gfc_add_modify (&block, recurcheckvar, boolean_false_node);
- recurcheckvar = NULL;
- }
+ {
+ gfc_add_modify (&block, recurcheckvar, boolean_false_node);
+ recurcheckvar = NULL;
+ }
if (result == NULL_TREE)
{
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index eb741f8231f..5a45f4f6368 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -1519,15 +1519,142 @@ get_proc_ptr_comp (gfc_expr *e)
e2 = gfc_copy_expr (e);
e2->expr_type = EXPR_VARIABLE;
gfc_conv_expr (&comp_se, e2);
+ gfc_free_expr (e2);
return build_fold_addr_expr_loc (input_location, comp_se.expr);
}
+/* Select a class typebound procedure at runtime. */
+static void
+select_class_proc (gfc_se *se, gfc_class_esym_list *elist,
+ tree declared, gfc_expr *expr)
+{
+ tree end_label;
+ tree label;
+ tree tmp;
+ tree vindex;
+ stmtblock_t body;
+ gfc_class_esym_list *next_elist, *tmp_elist;
+ gfc_se tmpse;
+
+ /* Convert the vindex expression. */
+ gfc_init_se (&tmpse, NULL);
+ gfc_conv_expr (&tmpse, elist->vindex);
+ gfc_add_block_to_block (&se->pre, &tmpse.pre);
+ vindex = gfc_evaluate_now (tmpse.expr, &se->pre);
+ gfc_add_block_to_block (&se->post, &tmpse.post);
+
+ /* Fix the function type to be that of the declared type method. */
+ declared = gfc_create_var (TREE_TYPE (declared), "method");
+
+ end_label = gfc_build_label_decl (NULL_TREE);
+
+ gfc_init_block (&body);
+
+ /* Go through the list of extensions. */
+ for (; elist; elist = next_elist)
+ {
+ /* This case has already been added. */
+ if (elist->derived == NULL)
+ goto free_elist;
+
+ /* Run through the chain picking up all the cases that call the
+ same procedure. */
+ tmp_elist = elist;
+ for (; elist; elist = elist->next)
+ {
+ tree cval;
+
+ if (elist->esym != tmp_elist->esym)
+ continue;
+
+ cval = build_int_cst (TREE_TYPE (vindex),
+ elist->derived->vindex);
+ /* Build a label for the vindex value. */
+ label = gfc_build_label_decl (NULL_TREE);
+ tmp = fold_build3 (CASE_LABEL_EXPR, void_type_node,
+ cval, NULL_TREE, label);
+ gfc_add_expr_to_block (&body, tmp);
+
+ /* Null the reference the derived type so that this case is
+ not used again. */
+ elist->derived = NULL;
+ }
+
+ elist = tmp_elist;
+
+ /* Get a pointer to the procedure, */
+ tmp = gfc_get_symbol_decl (elist->esym);
+ if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
+ {
+ gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
+ tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+ }
+
+ /* Assign the pointer to the appropriate procedure. */
+ gfc_add_modify (&body, declared,
+ fold_convert (TREE_TYPE (declared), tmp));
+
+ /* Break to the end of the construct. */
+ tmp = build1_v (GOTO_EXPR, end_label);
+ gfc_add_expr_to_block (&body, tmp);
+
+ /* Free the elists as we go; freeing them in gfc_free_expr causes
+ segfaults because it occurs too early and too often. */
+ free_elist:
+ next_elist = elist->next;
+ if (elist->vindex)
+ gfc_free_expr (elist->vindex);
+ gfc_free (elist);
+ elist = NULL;
+ }
+
+ /* Default is an error. */
+ label = gfc_build_label_decl (NULL_TREE);
+ tmp = fold_build3 (CASE_LABEL_EXPR, void_type_node,
+ NULL_TREE, NULL_TREE, label);
+ gfc_add_expr_to_block (&body, tmp);
+ tmp = gfc_trans_runtime_error (true, &expr->where,
+ "internal error: bad vindex in dynamic dispatch");
+ gfc_add_expr_to_block (&body, tmp);
+
+ /* Write the switch expression. */
+ tmp = gfc_finish_block (&body);
+ tmp = build3_v (SWITCH_EXPR, vindex, tmp, NULL_TREE);
+ gfc_add_expr_to_block (&se->pre, tmp);
+
+ tmp = build1_v (LABEL_EXPR, end_label);
+ gfc_add_expr_to_block (&se->pre, tmp);
+
+ se->expr = declared;
+ return;
+}
+
+
static void
conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
{
tree tmp;
+ if (expr && expr->symtree
+ && expr->value.function.class_esym)
+ {
+ if (!sym->backend_decl)
+ sym->backend_decl = gfc_get_extern_function_decl (sym);
+
+ tmp = sym->backend_decl;
+
+ if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
+ {
+ gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
+ tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+ }
+
+ select_class_proc (se, expr->value.function.class_esym,
+ tmp, expr);
+ return;
+ }
+
if (gfc_is_proc_ptr_comp (expr, NULL))
tmp = get_proc_ptr_comp (expr);
else if (sym->attr.dummy)
@@ -2651,6 +2778,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
{
tree data;
tree vindex;
+ tree size;
/* The derived type needs to be converted to a temporary
CLASS object. */
@@ -2664,13 +2792,20 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
var, tmp, NULL_TREE);
tmp = fsym->ts.u.derived->components->next->backend_decl;
vindex = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
+ var, tmp, NULL_TREE);
+ tmp = fsym->ts.u.derived->components->next->next->backend_decl;
+ size = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
var, tmp, NULL_TREE);
/* Set the vindex. */
- tmp = build_int_cst (TREE_TYPE (vindex),
- e->ts.u.derived->vindex);
+ tmp = build_int_cst (TREE_TYPE (vindex), e->ts.u.derived->vindex);
gfc_add_modify (&parmse.pre, vindex, tmp);
+ /* Set the size. */
+ tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&e->ts));
+ gfc_add_modify (&parmse.pre, size,
+ fold_convert (TREE_TYPE (size), tmp));
+
/* Now set the data field. */
argss = gfc_walk_expr (e);
if (argss == gfc_ss_terminator)
@@ -2735,8 +2870,11 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
through arg->name. */
conv_arglist_function (&parmse, arg->expr, arg->name);
else if ((e->expr_type == EXPR_FUNCTION)
- && e->symtree->n.sym->attr.pointer
- && fsym && fsym->attr.target)
+ && ((e->value.function.esym
+ && e->value.function.esym->result->attr.pointer)
+ || (!e->value.function.esym
+ && e->symtree->n.sym->attr.pointer))
+ && fsym && fsym->attr.target)
{
gfc_conv_expr (&parmse, e);
parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
@@ -2754,6 +2892,37 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
else
{
gfc_conv_expr_reference (&parmse, e);
+
+ /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
+ allocated on entry, it must be deallocated. */
+ if (fsym && fsym->attr.allocatable
+ && fsym->attr.intent == INTENT_OUT)
+ {
+ stmtblock_t block;
+
+ gfc_init_block (&block);
+ tmp = gfc_deallocate_with_status (parmse.expr, NULL_TREE,
+ true, NULL);
+ gfc_add_expr_to_block (&block, tmp);
+ tmp = fold_build2 (MODIFY_EXPR, void_type_node,
+ parmse.expr, null_pointer_node);
+ gfc_add_expr_to_block (&block, tmp);
+
+ if (fsym->attr.optional
+ && e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->attr.optional)
+ {
+ tmp = fold_build3 (COND_EXPR, void_type_node,
+ gfc_conv_expr_present (e->symtree->n.sym),
+ gfc_finish_block (&block),
+ build_empty_stmt (input_location));
+ }
+ else
+ tmp = gfc_finish_block (&block);
+
+ gfc_add_expr_to_block (&se->pre, tmp);
+ }
+
if (fsym && e->expr_type != EXPR_NULL
&& ((fsym->attr.pointer
&& fsym->attr.flavor != FL_PROCEDURE)
@@ -2761,7 +2930,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
&& !(e->expr_type == EXPR_VARIABLE
&& e->symtree->n.sym->attr.dummy))
|| (e->expr_type == EXPR_VARIABLE
- && gfc_is_proc_ptr_comp (e, NULL))))
+ && gfc_is_proc_ptr_comp (e, NULL))
+ || fsym->attr.allocatable))
{
/* Scalar pointer dummy args require an extra level of
indirection. The null pointer already contains
@@ -2797,17 +2967,22 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
sym->name, NULL);
- /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
- allocated on entry, it must be deallocated. */
- if (fsym && fsym->attr.allocatable
- && fsym->attr.intent == INTENT_OUT)
- {
- tmp = build_fold_indirect_ref_loc (input_location,
- parmse.expr);
- tmp = gfc_trans_dealloc_allocated (tmp);
- gfc_add_expr_to_block (&se->pre, tmp);
- }
-
+ /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
+ allocated on entry, it must be deallocated. */
+ if (fsym && fsym->attr.allocatable
+ && fsym->attr.intent == INTENT_OUT)
+ {
+ tmp = build_fold_indirect_ref_loc (input_location,
+ parmse.expr);
+ tmp = gfc_trans_dealloc_allocated (tmp);
+ if (fsym->attr.optional
+ && e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->attr.optional)
+ tmp = fold_build3 (COND_EXPR, void_type_node,
+ gfc_conv_expr_present (e->symtree->n.sym),
+ tmp, build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&se->pre, tmp);
+ }
}
}
@@ -2819,9 +2994,23 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
if (e && (fsym == NULL || fsym->attr.optional))
{
/* If an optional argument is itself an optional dummy argument,
- check its presence and substitute a null if absent. */
+ check its presence and substitute a null if absent. This is
+ only needed when passing an array to an elemental procedure
+ as then array elements are accessed - or no NULL pointer is
+ allowed and a "1" or "0" should be passed if not present.
+ When passing a non-array-descriptor full array to a
+ non-array-descriptor dummy, no check is needed. For
+ array-descriptor actual to array-descriptor dummy, see
+ PR 41911 for why a check has to be inserted.
+ fsym == NULL is checked as intrinsics required the descriptor
+ but do not always set fsym. */
if (e->expr_type == EXPR_VARIABLE
- && e->symtree->n.sym->attr.optional)
+ && e->symtree->n.sym->attr.optional
+ && ((e->rank > 0 && sym->attr.elemental)
+ || e->representation.length || e->ts.type == BT_CHARACTER
+ || (e->rank > 0
+ && (fsym == NULL || fsym->as->type == AS_ASSUMED_SHAPE
+ || fsym->as->type == AS_DEFERRED))))
gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
e->representation.length);
}
@@ -3015,7 +3204,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
}
}
- else
+ else
{
tree tmp;
@@ -4233,8 +4422,12 @@ gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
}
if (expr->expr_type == EXPR_FUNCTION
- && expr->symtree->n.sym->attr.pointer
- && !expr->symtree->n.sym->attr.dimension)
+ && ((expr->value.function.esym
+ && expr->value.function.esym->result->attr.pointer
+ && !expr->value.function.esym->result->attr.dimension)
+ || (!expr->value.function.esym
+ && expr->symtree->n.sym->attr.pointer
+ && !expr->symtree->n.sym->attr.dimension)))
{
se->want_pointer = 1;
gfc_conv_expr (se, expr);
@@ -4525,12 +4718,11 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
gfc_add_expr_to_block (&block, tmp);
}
}
- else if (ts.type == BT_DERIVED)
+ else if (ts.type == BT_DERIVED || ts.type == BT_CLASS)
{
gfc_add_block_to_block (&block, &lse->pre);
gfc_add_block_to_block (&block, &rse->pre);
- tmp = gfc_evaluate_now (rse->expr, &block);
- tmp = fold_build1 (VIEW_CONVERT_EXPR, TREE_TYPE (lse->expr), tmp);
+ tmp = fold_build1 (VIEW_CONVERT_EXPR, TREE_TYPE (lse->expr), rse->expr);
gfc_add_modify (&block, lse->expr, tmp);
}
else
@@ -5137,3 +5329,75 @@ gfc_trans_assign (gfc_code * code)
{
return gfc_trans_assignment (code->expr1, code->expr2, false);
}
+
+
+/* Translate an assignment to a CLASS object
+ (pointer or ordinary assignment). */
+
+tree
+gfc_trans_class_assign (gfc_code *code)
+{
+ stmtblock_t block;
+ tree tmp;
+
+ gfc_start_block (&block);
+
+ if (code->expr2->ts.type != BT_CLASS)
+ {
+ /* Insert an additional assignment which sets the '$vindex' field. */
+ gfc_expr *lhs,*rhs;
+ lhs = gfc_copy_expr (code->expr1);
+ gfc_add_component_ref (lhs, "$vindex");
+ if (code->expr2->ts.type == BT_DERIVED)
+ /* vindex is constant, determined at compile time. */
+ rhs = gfc_int_expr (code->expr2->ts.u.derived->vindex);
+ else if (code->expr2->expr_type == EXPR_NULL)
+ rhs = gfc_int_expr (0);
+ else
+ gcc_unreachable ();
+ tmp = gfc_trans_assignment (lhs, rhs, false);
+ gfc_add_expr_to_block (&block, tmp);
+
+ /* Insert another assignment which sets the '$size' field. */
+ lhs = gfc_copy_expr (code->expr1);
+ gfc_add_component_ref (lhs, "$size");
+ if (code->expr2->ts.type == BT_DERIVED)
+ {
+ /* Size is fixed at compile time. */
+ gfc_se lse;
+ gfc_init_se (&lse, NULL);
+ gfc_conv_expr (&lse, lhs);
+ tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr2->ts));
+ gfc_add_modify (&block, lse.expr,
+ fold_convert (TREE_TYPE (lse.expr), tmp));
+ }
+ else if (code->expr2->expr_type == EXPR_NULL)
+ {
+ rhs = gfc_int_expr (0);
+ tmp = gfc_trans_assignment (lhs, rhs, false);
+ gfc_add_expr_to_block (&block, tmp);
+ }
+ else
+ gcc_unreachable ();
+
+ gfc_free_expr (lhs);
+ gfc_free_expr (rhs);
+ }
+
+ /* Do the actual CLASS assignment. */
+ if (code->expr2->ts.type == BT_CLASS)
+ code->op = EXEC_ASSIGN;
+ else
+ gfc_add_component_ref (code->expr1, "$data");
+
+ if (code->op == EXEC_ASSIGN)
+ tmp = gfc_trans_assign (code);
+ else if (code->op == EXEC_POINTER_ASSIGN)
+ tmp = gfc_trans_pointer_assign (code);
+ else
+ gcc_unreachable();
+
+ gfc_add_expr_to_block (&block, tmp);
+
+ return gfc_finish_block (&block);
+}
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 1e7b35f5c17..c3d7dfbab3c 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -4490,6 +4490,8 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
scalar_transfer:
extent = fold_build2 (MIN_EXPR, gfc_array_index_type,
dest_word_len, source_bytes);
+ extent = fold_build2 (MAX_EXPR, gfc_array_index_type,
+ extent, gfc_index_zero_node);
if (expr->ts.type == BT_CHARACTER)
{
diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c
index 56534ccdd38..4d461cfa488 100644
--- a/gcc/fortran/trans-openmp.c
+++ b/gcc/fortran/trans-openmp.c
@@ -1641,11 +1641,6 @@ gfc_trans_omp_workshare (gfc_code *code, gfc_omp_clauses *clauses)
if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
{
- if (TREE_CODE (res) == STATEMENT_LIST)
- tree_annotate_all_with_location (&res, input_location);
- else
- SET_EXPR_LOCATION (res, input_location);
-
if (prev_singleunit)
{
if (ompws_flags & OMPWS_CURR_SINGLEUNIT)
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 9d3197d11bc..9b2a6230853 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -159,31 +159,15 @@ gfc_trans_goto (gfc_code * code)
assigned_goto = GFC_DECL_ASSIGN_ADDR (se.expr);
- code = code->block;
- if (code == NULL)
- {
- target = fold_build1 (GOTO_EXPR, void_type_node, assigned_goto);
- gfc_add_expr_to_block (&se.pre, target);
- return gfc_finish_block (&se.pre);
- }
-
- /* Check the label list. */
- do
- {
- target = gfc_get_label_decl (code->label1);
- tmp = gfc_build_addr_expr (pvoid_type_node, target);
- tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, assigned_goto);
- tmp = build3_v (COND_EXPR, tmp,
- fold_build1 (GOTO_EXPR, void_type_node, target),
- build_empty_stmt (input_location));
- gfc_add_expr_to_block (&se.pre, tmp);
- code = code->block;
- }
- while (code != NULL);
- gfc_trans_runtime_check (true, false, boolean_true_node, &se.pre, &loc,
- "Assigned label is not in the list");
-
- return gfc_finish_block (&se.pre);
+ /* We're going to ignore a label list. It does not really change the
+ statement's semantics (because it is just a further restriction on
+ what's legal code); before, we were comparing label addresses here, but
+ that's a very fragile business and may break with optimization. So
+ just ignore it. */
+
+ target = fold_build1 (GOTO_EXPR, void_type_node, assigned_goto);
+ gfc_add_expr_to_block (&se.pre, target);
+ return gfc_finish_block (&se.pre);
}
@@ -3992,19 +3976,20 @@ tree
gfc_trans_allocate (gfc_code * code)
{
gfc_alloc *al;
- gfc_expr *expr, *init_e, *rhs;
+ gfc_expr *expr, *init_e;
gfc_se se;
tree tmp;
tree parm;
tree stat;
tree pstat;
tree error_label;
+ tree memsz;
stmtblock_t block;
if (!code->ext.alloc.list)
return NULL_TREE;
- pstat = stat = error_label = tmp = NULL_TREE;
+ pstat = stat = error_label = tmp = memsz = NULL_TREE;
gfc_start_block (&block);
@@ -4022,7 +4007,10 @@ gfc_trans_allocate (gfc_code * code)
for (al = code->ext.alloc.list; al != NULL; al = al->next)
{
- expr = al->expr;
+ expr = gfc_copy_expr (al->expr);
+
+ if (expr->ts.type == BT_CLASS)
+ gfc_add_component_ref (expr, "$data");
gfc_init_se (&se, NULL);
gfc_start_block (&se.pre);
@@ -4038,25 +4026,26 @@ gfc_trans_allocate (gfc_code * code)
/* Determine allocate size. */
if (code->expr3 && code->expr3->ts.type == BT_CLASS)
{
- gfc_typespec *ts;
- /* TODO: Size must be determined at run time, since it must equal
- the size of the dynamic type of SOURCE, not the declared type. */
- gfc_warning ("Dynamic size allocation at %L not supported yet, "
- "using size of declared type", &code->loc);
- ts = &code->expr3->ts.u.derived->components->ts;
- tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (ts));
+ gfc_expr *sz;
+ gfc_se se_sz;
+ sz = gfc_copy_expr (code->expr3);
+ gfc_add_component_ref (sz, "$size");
+ gfc_init_se (&se_sz, NULL);
+ gfc_conv_expr (&se_sz, sz);
+ gfc_free_expr (sz);
+ memsz = se_sz.expr;
}
else if (code->expr3 && code->expr3->ts.type != BT_CLASS)
- tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr3->ts));
+ memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr3->ts));
else if (code->ext.alloc.ts.type != BT_UNKNOWN)
- tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts));
+ memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts));
else
- tmp = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr)));
+ memsz = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr)));
- if (expr->ts.type == BT_CHARACTER && tmp == NULL_TREE)
- tmp = se.string_length;
+ if (expr->ts.type == BT_CHARACTER && memsz == NULL_TREE)
+ memsz = se.string_length;
- tmp = gfc_allocate_with_status (&se.pre, tmp, pstat);
+ tmp = gfc_allocate_with_status (&se.pre, memsz, pstat);
tmp = fold_build2 (MODIFY_EXPR, void_type_node, se.expr,
fold_convert (TREE_TYPE (se.expr), tmp));
gfc_add_expr_to_block (&se.pre, tmp);
@@ -4086,17 +4075,91 @@ gfc_trans_allocate (gfc_code * code)
/* Initialization via SOURCE block. */
if (code->expr3)
{
- rhs = gfc_copy_expr (code->expr3);
- if (rhs->ts.type == BT_CLASS)
- gfc_add_component_ref (rhs, "$data");
- tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr), rhs, false);
+ gfc_expr *rhs = gfc_copy_expr (code->expr3);
+ if (al->expr->ts.type == BT_CLASS)
+ {
+ gfc_se dst,src;
+ if (rhs->ts.type == BT_CLASS)
+ gfc_add_component_ref (rhs, "$data");
+ gfc_init_se (&dst, NULL);
+ gfc_init_se (&src, NULL);
+ gfc_conv_expr (&dst, expr);
+ gfc_conv_expr (&src, rhs);
+ gfc_add_block_to_block (&block, &src.pre);
+ tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz);
+ }
+ else
+ tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr),
+ rhs, false);
+ gfc_free_expr (rhs);
+ gfc_add_expr_to_block (&block, tmp);
+ }
+ /* Default initializer for CLASS variables. */
+ else if (al->expr->ts.type == BT_CLASS
+ && code->ext.alloc.ts.type == BT_DERIVED
+ && (init_e = gfc_default_initializer (&code->ext.alloc.ts)))
+ {
+ gfc_se dst,src;
+ gfc_init_se (&dst, NULL);
+ gfc_init_se (&src, NULL);
+ gfc_conv_expr (&dst, expr);
+ gfc_conv_expr (&src, init_e);
+ gfc_add_block_to_block (&block, &src.pre);
+ tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz);
gfc_add_expr_to_block (&block, tmp);
}
/* Add default initializer for those derived types that need them. */
- else if (expr->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&expr->ts)))
+ else if (expr->ts.type == BT_DERIVED
+ && (init_e = gfc_default_initializer (&expr->ts)))
+ {
+ tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr),
+ init_e, true);
+ gfc_add_expr_to_block (&block, tmp);
+ }
+
+ /* Allocation of CLASS entities. */
+ gfc_free_expr (expr);
+ expr = al->expr;
+ if (expr->ts.type == BT_CLASS)
{
- tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr), init_e, true);
+ gfc_expr *lhs,*rhs;
+ gfc_se lse;
+ /* Initialize VINDEX for CLASS objects. */
+ lhs = gfc_expr_to_initialize (expr);
+ gfc_add_component_ref (lhs, "$vindex");
+ if (code->expr3 && code->expr3->ts.type == BT_CLASS)
+ {
+ /* vindex must be determined at run time. */
+ rhs = gfc_copy_expr (code->expr3);
+ gfc_add_component_ref (rhs, "$vindex");
+ }
+ else
+ {
+ /* vindex is fixed at compile time. */
+ int vindex;
+ if (code->expr3)
+ vindex = code->expr3->ts.u.derived->vindex;
+ else if (code->ext.alloc.ts.type == BT_DERIVED)
+ vindex = code->ext.alloc.ts.u.derived->vindex;
+ else if (expr->ts.type == BT_CLASS)
+ vindex = expr->ts.u.derived->components->ts.u.derived->vindex;
+ else
+ vindex = expr->ts.u.derived->vindex;
+ rhs = gfc_int_expr (vindex);
+ }
+ tmp = gfc_trans_assignment (lhs, rhs, false);
+ gfc_free_expr (lhs);
+ gfc_free_expr (rhs);
gfc_add_expr_to_block (&block, tmp);
+
+ /* Initialize SIZE for CLASS objects. */
+ lhs = gfc_expr_to_initialize (expr);
+ gfc_add_component_ref (lhs, "$size");
+ gfc_init_se (&lse, NULL);
+ gfc_conv_expr (&lse, lhs);
+ gfc_add_modify (&block, lse.expr,
+ fold_convert (TREE_TYPE (lse.expr), memsz));
+ gfc_free_expr (lhs);
}
}
diff --git a/gcc/fortran/trans-stmt.h b/gcc/fortran/trans-stmt.h
index 0b8461c4e15..e6faacd0022 100644
--- a/gcc/fortran/trans-stmt.h
+++ b/gcc/fortran/trans-stmt.h
@@ -29,6 +29,7 @@ tree gfc_trans_code (gfc_code *);
tree gfc_trans_assign (gfc_code *);
tree gfc_trans_pointer_assign (gfc_code *);
tree gfc_trans_init_assign (gfc_code *);
+tree gfc_trans_class_assign (gfc_code *code);
/* trans-stmt.c */
tree gfc_trans_cycle (gfc_code *);
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index 09b424c378f..42d22388105 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -1079,7 +1079,10 @@ gfc_trans_code (gfc_code * code)
break;
case EXEC_ASSIGN:
- res = gfc_trans_assign (code);
+ if (code->expr1->ts.type == BT_CLASS)
+ res = gfc_trans_class_assign (code);
+ else
+ res = gfc_trans_assign (code);
break;
case EXEC_LABEL_ASSIGN:
@@ -1087,7 +1090,10 @@ gfc_trans_code (gfc_code * code)
break;
case EXEC_POINTER_ASSIGN:
- res = gfc_trans_pointer_assign (code);
+ if (code->expr1->ts.type == BT_CLASS)
+ res = gfc_trans_class_assign (code);
+ else
+ res = gfc_trans_pointer_assign (code);
break;
case EXEC_INIT_ASSIGN:
@@ -1275,9 +1281,7 @@ gfc_trans_code (gfc_code * code)
if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
{
- if (TREE_CODE (res) == STATEMENT_LIST)
- tree_annotate_all_with_location (&res, input_location);
- else
+ if (TREE_CODE (res) != STATEMENT_LIST)
SET_EXPR_LOCATION (res, input_location);
/* Add the new statement to the block. */
View Lorry Controller Status