re PR fortran/40996 ([F03] ALLOCATABLE scalars)
fortran/ 2009-09-30 Janus Weil <janus@gcc.gnu.org> * check.c (gfc_check_same_type_as): New function for checking SAME_TYPE_AS and EXTENDS_TYPE_OF. * decl.c (encapsulate_class_symbol): Set ABSTRACT attribute for class container, if the contained type has it. Add an initializer for the class container. (add_init_expr_to_sym): Handle BT_CLASS. (vindex_counter): New counter for setting vindices. (gfc_match_derived_decl): Set vindex for all derived types, not only those which are being extended. * expr.c (gfc_check_assign_symbol): Handle NULL initialization of class pointers. * gfortran.h (gfc_isym_id): New values GFC_ISYM_SAME_TYPE_AS and GFC_ISYM_EXTENDS_TYPE_OF. (gfc_type_is_extensible): New prototype. * intrinsic.h (gfc_check_same_type_as): New prototype. * intrinsic.c (add_functions): Add SAME_TYPE_AS and EXTENDS_TYPE_OF. * primary.c (gfc_expr_attr): Handle CLASS-valued functions. * resolve.c (resolve_structure_cons): Handle BT_CLASS. (type_is_extensible): Make non-static and rename to 'gfc_type_is_extensible. (resolve_select_type): Renamed type_is_extensible. (resolve_class_assign): Handle NULL pointers. (resolve_fl_variable_derived): Renamed type_is_extensible. (resolve_fl_derived): Ditto. * trans-expr.c (gfc_trans_subcomponent_assign): Handle NULL initialization of class pointer components. (gfc_conv_structure): Handle BT_CLASS. * trans-intrinsic.c (gfc_conv_same_type_as,gfc_conv_extends_type_of): New functions. (gfc_conv_intrinsic_function): Handle SAME_TYPE_AS and EXTENDS_TYPE_OF. 2009-09-30 Janus Weil <janus@gcc.gnu.org> * gfortran.h (type_selector, select_type_tmp): New global variables. * match.c (type_selector, select_type_tmp): New global variables, used for SELECT TYPE statements. (gfc_match_select_type): Better error handling. Remember selector. (gfc_match_type_is): Create temporary variable. * module.c (ab_attribute): New value 'AB_IS_CLASS'. (attr_bits): New string. (mio_symbol_attribute): Handle 'is_class'. * resolve.c (resolve_select_type): Insert pointer assignment statement, to assign temporary to selector. * symbol.c (gfc_get_ha_sym_tree): Replace selector by a temporary in SELECT TYPE statements. 2009-09-30 Janus Weil <janus@gcc.gnu.org> * dump-parse-tree.c (show_code_node): Renamed 'alloc_list'. * gfortran.h (gfc_code): Rename 'alloc_list'. Add member 'ts'. (gfc_expr_to_initialize): New prototype. * match.c (alloc_opt_list): Correctly check type compatibility. Renamed 'alloc_list'. (dealloc_opt_list): Renamed 'alloc_list'. * resolve.c (expr_to_initialize): Rename to 'gfc_expr_to_initialize' and make it non-static. (resolve_allocate_expr): Set vindex for CLASS variables correctly. Move initialization code to gfc_trans_allocate. Renamed 'alloc_list'. (resolve_allocate_deallocate): Renamed 'alloc_list'. (check_class_pointer_assign): Rename to 'resolve_class_assign'. Change argument type. Adjust to work with ordinary assignments. (resolve_code): Call 'resolve_class_assign' for ordinary assignments. Renamed 'check_class_pointer_assign'. * st.c (gfc_free_statement): Renamed 'alloc_list'. * trans-stmt.c (gfc_trans_allocate): Renamed 'alloc_list'. Handle size determination and initialization of CLASS variables. Bugfix for ALLOCATE statements with default initialization and SOURCE block. (gfc_trans_deallocate): Renamed 'alloc_list'. 2009-09-30 Paul Thomas <pault@gcc.gnu.org> * trans-expr.c (gfc_conv_procedure_call): Convert a derived type actual to a class object if the formal argument is a class. 2009-09-30 Janus Weil <janus@gcc.gnu.org> PR fortran/40996 * decl.c (build_struct): Handle allocatable scalar components. * expr.c (gfc_add_component_ref): Correctly set typespec of expression, after inserting component reference. * match.c (gfc_match_type_is,gfc_match_class_is): Make sure that no variables are being used uninitialized. * primary.c (gfc_match_varspec): Handle CLASS array components. * resolve.c (resolve_select_type): Transform EXEC_SELECT_TYPE to EXEC_SELECT. * trans-array.c (structure_alloc_comps,gfc_trans_deferred_array): Handle allocatable scalar components. * trans-expr.c (gfc_conv_component_ref): Ditto. * trans-types.c (gfc_get_derived_type): Ditto. 2009-09-30 Janus Weil <janus@gcc.gnu.org> * decl.c (encapsulate_class_symbol): Modify names of class container components by prefixing with '$'. (gfc_match_end): Handle COMP_SELECT_TYPE. * expr.c (gfc_add_component_ref): Modify names of class container components by prefixing with '$'. * gfortran.h (gfc_statement): Add ST_SELECT_TYPE, ST_TYPE_IS and ST_CLASS_IS. (gfc_case): New field 'ts'. (gfc_exec_op): Add EXEC_SELECT_TYPE. (gfc_type_is_extension_of): New prototype. * match.h (gfc_match_select_type,gfc_match_type_is,gfc_match_class_is): New prototypes. * match.c (match_derived_type_spec): New function. (match_type_spec): Use 'match_derived_type_spec'. (match_case_eos): Modify error message. (gfc_match_select_type): New function. (gfc_match_case): Modify error message. (gfc_match_type_is): New function. (gfc_match_class_is): Ditto. * parse.h (gfc_compile_state): Add COMP_SELECT_TYPE. * parse.c (decode_statement): Handle SELECT TYPE, TYPE IS and CLASS IS statements. (next_statement): Handle ST_SELECT_TYPE. (gfc_ascii_statement): Handle ST_SELECT_TYPE, ST_TYPE_IS, ST_CLASS_IS. (parse_select_type_block): New function. (parse_executable): Handle ST_SELECT_TYPE. * resolve.c (resolve_deallocate_expr): Handle BT_CLASS. Modify names of class container components by prefixing with '$'. (resolve_allocate_expr): Ditto. (resolve_select_type): New function. (gfc_resolve_blocks): Handle EXEC_SELECT_TYPE. (check_class_pointer_assign): Modify names of class container components by prefixing with '$'. (resolve_code): Ditto. * st.c (gfc_free_statement): Ditto. * symbol.c (gfc_type_is_extension_of): New function. (gfc_type_compatible): Use 'gfc_type_is_extension_of', plus a bugfix. * trans.c (gfc_trans_code): Handel EXEC_SELECT_TYPE. 2009-09-30 Janus Weil <janus@gcc.gnu.org> Paul Thomas <pault@gcc.gnu.org> * check.c (gfc_check_move_alloc): Arguments don't have to be arrays. The second argument needs to be type-compatible with the first (not the other way around, which makes a difference for CLASS entities). * decl.c (encapsulate_class_symbol): New function. (build_sym,build_struct): Handle BT_CLASS, call 'encapsulate_class_symbol'. (gfc_match_decl_type_spec): Remove warning, use BT_CLASS. (gfc_match_derived_decl): Set vindex; * expr.c (gfc_add_component_ref): New function. (gfc_copy_expr,gfc_check_pointer_assign,gfc_check_assign_symbol): Handle BT_CLASS. * dump-parse-tree.c (show_symbol): Print vindex. * gfortran.h (bt): New basic type BT_CLASS. (symbol_attribute): New field 'is_class'. (gfc_typespec): Remove field 'is_class'. (gfc_symbol): New field 'vindex'. (gfc_get_ultimate_derived_super_type): New prototype. (gfc_add_component_ref): Ditto. * interface.c (gfc_compare_derived_types): Pointer equality check moved here from gfc_compare_types. (gfc_compare_types): Handle BT_CLASS and use gfc_type_compatible. * match.c (gfc_match_allocate,gfc_match_deallocate,gfc_match_call): Handle BT_CLASS. * misc.c (gfc_clear_ts): Removed is_class. (gfc_basic_typename,gfc_typename): Handle BT_CLASS. * module.c (bt_types,mio_typespec): Handle BT_CLASS. (mio_symbol): Handle vindex. * primary.c (gfc_match_varspec,gfc_variable_attr): Handle BT_CLASS. * resolve.c (find_array_spec,check_typebound_baseobject): Handle BT_CLASS. (resolve_ppc_call,resolve_expr_ppc): Don't call 'gfc_is_proc_ptr_comp' inside 'gcc_assert'. (resolve_deallocate_expr,resolve_allocate_expr): Handle BT_CLASS. (check_class_pointer_assign): New function. (resolve_code): Handle BT_CLASS, call check_class_pointer_assign. (resolve_fl_var_and_proc,type_is_extensible,resolve_fl_variable_derived, resolve_fl_variable): Handle BT_CLASS. (check_generic_tbp_ambiguity): Add special case. (resolve_typebound_procedure,resolve_fl_derived): Handle BT_CLASS. * symbol.c (gfc_get_ultimate_derived_super_type): New function. (gfc_type_compatible): Handle BT_CLASS. * trans-expr.c (conv_parent_component_references): Handle CLASS containers. (gfc_conv_initializer): Handle BT_CLASS. * trans-types.c (gfc_typenode_for_spec,gfc_get_derived_type): Handle BT_CLASS. testsuite/ 2009-09-30 Janus Weil <janus@gcc.gnu.org> * gfortran.dg/same_type_as_1.f03: New test. * gfortran.dg/same_type_as_2.f03: Ditto. 2009-09-30 Janus Weil <janus@gcc.gnu.org> * gfortran.dg/select_type_1.f03: Extended. * gfortran.dg/select_type_3.f03: New test. 2009-09-30 Janus Weil <janus@gcc.gnu.org> * gfortran.dg/class_allocate_1.f03: New test. 2009-09-30 Janus Weil <janus@gcc.gnu.org> PR fortran/40996 * gfortran.dg/allocatable_scalar_3.f90: New test. * gfortran.dg/select_type_2.f03: Ditto. * gfortran.dg/typebound_proc_5.f03: Changed error messages. 2009-09-30 Janus Weil <janus@gcc.gnu.org> * gfortran.dg/block_name_2.f90: Modified error message. * gfortran.dg/select_6.f90: Ditto. * gfortran.dg/select_type_1.f03: New test. 2009-09-30 Janus Weil <janus@gcc.gnu.org> * gfortran.dg/allocate_derived_1.f90: Remove -w option. * gfortran.dg/class_1.f03: Ditto. * gfortran.dg/class_2.f03: Ditto. * gfortran.dg/proc_ptr_comp_pass_1.f90: Ditto. * gfortran.dg/proc_ptr_comp_pass_2.f90: Ditto. * gfortran.dg/proc_ptr_comp_pass_3.f90: Ditto. * gfortran.dg/typebound_call_10.f03: Ditto. * gfortran.dg/typebound_call_2.f03: Ditto. * gfortran.dg/typebound_call_3.f03: Ditto. * gfortran.dg/typebound_call_4.f03: Ditto. * gfortran.dg/typebound_call_9.f03: Ditto. * gfortran.dg/typebound_generic_3.f03: Ditto. * gfortran.dg/typebound_generic_4.f03: Ditto. * gfortran.dg/typebound_operator_1.f03: Ditto. * gfortran.dg/typebound_operator_2.f03: Ditto. * gfortran.dg/typebound_operator_3.f03: Ditto. * gfortran.dg/typebound_operator_4.f03: Ditto. * gfortran.dg/typebound_proc_1.f08: Ditto. * gfortran.dg/typebound_proc_5.f03: Ditto. * gfortran.dg/typebound_proc_6.f03: Ditto. From-SVN: r152345
This commit is contained in:
Tobias Burnus
parent
c39b74e132
commit
cf2b3c22a2
55 changed files with 1845 additions and 323 deletions
|
|
@ -1,3 +1,188 @@
|
|||
2009-09-30 Janus Weil <janus@gcc.gnu.org>
|
||||
|
||||
* check.c (gfc_check_same_type_as): New function for checking
|
||||
SAME_TYPE_AS and EXTENDS_TYPE_OF.
|
||||
* decl.c (encapsulate_class_symbol): Set ABSTRACT attribute for class
|
||||
container, if the contained type has it. Add an initializer for the
|
||||
class container.
|
||||
(add_init_expr_to_sym): Handle BT_CLASS.
|
||||
(vindex_counter): New counter for setting vindices.
|
||||
(gfc_match_derived_decl): Set vindex for all derived types, not only
|
||||
those which are being extended.
|
||||
* expr.c (gfc_check_assign_symbol): Handle NULL initialization of class
|
||||
pointers.
|
||||
* gfortran.h (gfc_isym_id): New values GFC_ISYM_SAME_TYPE_AS and
|
||||
GFC_ISYM_EXTENDS_TYPE_OF.
|
||||
(gfc_type_is_extensible): New prototype.
|
||||
* intrinsic.h (gfc_check_same_type_as): New prototype.
|
||||
* intrinsic.c (add_functions): Add SAME_TYPE_AS and EXTENDS_TYPE_OF.
|
||||
* primary.c (gfc_expr_attr): Handle CLASS-valued functions.
|
||||
* resolve.c (resolve_structure_cons): Handle BT_CLASS.
|
||||
(type_is_extensible): Make non-static and rename to
|
||||
'gfc_type_is_extensible.
|
||||
(resolve_select_type): Renamed type_is_extensible.
|
||||
(resolve_class_assign): Handle NULL pointers.
|
||||
(resolve_fl_variable_derived): Renamed type_is_extensible.
|
||||
(resolve_fl_derived): Ditto.
|
||||
* trans-expr.c (gfc_trans_subcomponent_assign): Handle NULL
|
||||
initialization of class pointer components.
|
||||
(gfc_conv_structure): Handle BT_CLASS.
|
||||
* trans-intrinsic.c (gfc_conv_same_type_as,gfc_conv_extends_type_of):
|
||||
New functions.
|
||||
(gfc_conv_intrinsic_function): Handle SAME_TYPE_AS and EXTENDS_TYPE_OF.
|
||||
|
||||
2009-09-30 Janus Weil <janus@gcc.gnu.org>
|
||||
|
||||
* gfortran.h (type_selector, select_type_tmp): New global variables.
|
||||
* match.c (type_selector, select_type_tmp): New global variables,
|
||||
used for SELECT TYPE statements.
|
||||
(gfc_match_select_type): Better error handling. Remember selector.
|
||||
(gfc_match_type_is): Create temporary variable.
|
||||
* module.c (ab_attribute): New value 'AB_IS_CLASS'.
|
||||
(attr_bits): New string.
|
||||
(mio_symbol_attribute): Handle 'is_class'.
|
||||
* resolve.c (resolve_select_type): Insert pointer assignment statement,
|
||||
to assign temporary to selector.
|
||||
* symbol.c (gfc_get_ha_sym_tree): Replace selector by a temporary
|
||||
in SELECT TYPE statements.
|
||||
|
||||
2009-09-30 Janus Weil <janus@gcc.gnu.org>
|
||||
|
||||
* dump-parse-tree.c (show_code_node): Renamed 'alloc_list'.
|
||||
* gfortran.h (gfc_code): Rename 'alloc_list'. Add member 'ts'.
|
||||
(gfc_expr_to_initialize): New prototype.
|
||||
* match.c (alloc_opt_list): Correctly check type compatibility.
|
||||
Renamed 'alloc_list'.
|
||||
(dealloc_opt_list): Renamed 'alloc_list'.
|
||||
* resolve.c (expr_to_initialize): Rename to 'gfc_expr_to_initialize'
|
||||
and make it non-static.
|
||||
(resolve_allocate_expr): Set vindex for CLASS variables correctly.
|
||||
Move initialization code to gfc_trans_allocate. Renamed 'alloc_list'.
|
||||
(resolve_allocate_deallocate): Renamed 'alloc_list'.
|
||||
(check_class_pointer_assign): Rename to 'resolve_class_assign'. Change
|
||||
argument type. Adjust to work with ordinary assignments.
|
||||
(resolve_code): Call 'resolve_class_assign' for ordinary assignments.
|
||||
Renamed 'check_class_pointer_assign'.
|
||||
* st.c (gfc_free_statement): Renamed 'alloc_list'.
|
||||
* trans-stmt.c (gfc_trans_allocate): Renamed 'alloc_list'. Handle
|
||||
size determination and initialization of CLASS variables. Bugfix for
|
||||
ALLOCATE statements with default initialization and SOURCE block.
|
||||
(gfc_trans_deallocate): Renamed 'alloc_list'.
|
||||
|
||||
2009-09-30 Paul Thomas <pault@gcc.gnu.org>
|
||||
|
||||
* trans-expr.c (gfc_conv_procedure_call): Convert a derived
|
||||
type actual to a class object if the formal argument is a
|
||||
class.
|
||||
|
||||
2009-09-30 Janus Weil <janus@gcc.gnu.org>
|
||||
|
||||
PR fortran/40996
|
||||
* decl.c (build_struct): Handle allocatable scalar components.
|
||||
* expr.c (gfc_add_component_ref): Correctly set typespec of expression,
|
||||
after inserting component reference.
|
||||
* match.c (gfc_match_type_is,gfc_match_class_is): Make sure that no
|
||||
variables are being used uninitialized.
|
||||
* primary.c (gfc_match_varspec): Handle CLASS array components.
|
||||
* resolve.c (resolve_select_type): Transform EXEC_SELECT_TYPE to
|
||||
EXEC_SELECT.
|
||||
* trans-array.c (structure_alloc_comps,gfc_trans_deferred_array):
|
||||
Handle allocatable scalar components.
|
||||
* trans-expr.c (gfc_conv_component_ref): Ditto.
|
||||
* trans-types.c (gfc_get_derived_type): Ditto.
|
||||
|
||||
2009-09-30 Janus Weil <janus@gcc.gnu.org>
|
||||
|
||||
* decl.c (encapsulate_class_symbol): Modify names of class container
|
||||
components by prefixing with '$'.
|
||||
(gfc_match_end): Handle COMP_SELECT_TYPE.
|
||||
* expr.c (gfc_add_component_ref): Modify names of class container
|
||||
components by prefixing with '$'.
|
||||
* gfortran.h (gfc_statement): Add ST_SELECT_TYPE, ST_TYPE_IS and
|
||||
ST_CLASS_IS.
|
||||
(gfc_case): New field 'ts'.
|
||||
(gfc_exec_op): Add EXEC_SELECT_TYPE.
|
||||
(gfc_type_is_extension_of): New prototype.
|
||||
* match.h (gfc_match_select_type,gfc_match_type_is,gfc_match_class_is):
|
||||
New prototypes.
|
||||
* match.c (match_derived_type_spec): New function.
|
||||
(match_type_spec): Use 'match_derived_type_spec'.
|
||||
(match_case_eos): Modify error message.
|
||||
(gfc_match_select_type): New function.
|
||||
(gfc_match_case): Modify error message.
|
||||
(gfc_match_type_is): New function.
|
||||
(gfc_match_class_is): Ditto.
|
||||
* parse.h (gfc_compile_state): Add COMP_SELECT_TYPE.
|
||||
* parse.c (decode_statement): Handle SELECT TYPE, TYPE IS and CLASS IS
|
||||
statements.
|
||||
(next_statement): Handle ST_SELECT_TYPE.
|
||||
(gfc_ascii_statement): Handle ST_SELECT_TYPE, ST_TYPE_IS, ST_CLASS_IS.
|
||||
(parse_select_type_block): New function.
|
||||
(parse_executable): Handle ST_SELECT_TYPE.
|
||||
* resolve.c (resolve_deallocate_expr): Handle BT_CLASS. Modify names of
|
||||
class container components by prefixing with '$'.
|
||||
(resolve_allocate_expr): Ditto.
|
||||
(resolve_select_type): New function.
|
||||
(gfc_resolve_blocks): Handle EXEC_SELECT_TYPE.
|
||||
(check_class_pointer_assign): Modify names of class container
|
||||
components by prefixing with '$'.
|
||||
(resolve_code): Ditto.
|
||||
* st.c (gfc_free_statement): Ditto.
|
||||
* symbol.c (gfc_type_is_extension_of): New function.
|
||||
(gfc_type_compatible): Use 'gfc_type_is_extension_of', plus a bugfix.
|
||||
* trans.c (gfc_trans_code): Handel EXEC_SELECT_TYPE.
|
||||
|
||||
2009-09-30 Janus Weil <janus@gcc.gnu.org>
|
||||
Paul Thomas <pault@gcc.gnu.org>
|
||||
|
||||
* check.c (gfc_check_move_alloc): Arguments don't have to be arrays.
|
||||
The second argument needs to be type-compatible with the first (not the
|
||||
other way around, which makes a difference for CLASS entities).
|
||||
* decl.c (encapsulate_class_symbol): New function.
|
||||
(build_sym,build_struct): Handle BT_CLASS, call
|
||||
'encapsulate_class_symbol'.
|
||||
(gfc_match_decl_type_spec): Remove warning, use BT_CLASS.
|
||||
(gfc_match_derived_decl): Set vindex;
|
||||
* expr.c (gfc_add_component_ref): New function.
|
||||
(gfc_copy_expr,gfc_check_pointer_assign,gfc_check_assign_symbol):
|
||||
Handle BT_CLASS.
|
||||
* dump-parse-tree.c (show_symbol): Print vindex.
|
||||
* gfortran.h (bt): New basic type BT_CLASS.
|
||||
(symbol_attribute): New field 'is_class'.
|
||||
(gfc_typespec): Remove field 'is_class'.
|
||||
(gfc_symbol): New field 'vindex'.
|
||||
(gfc_get_ultimate_derived_super_type): New prototype.
|
||||
(gfc_add_component_ref): Ditto.
|
||||
* interface.c (gfc_compare_derived_types): Pointer equality check
|
||||
moved here from gfc_compare_types.
|
||||
(gfc_compare_types): Handle BT_CLASS and use
|
||||
gfc_type_compatible.
|
||||
* match.c (gfc_match_allocate,gfc_match_deallocate,gfc_match_call):
|
||||
Handle BT_CLASS.
|
||||
* misc.c (gfc_clear_ts): Removed is_class.
|
||||
(gfc_basic_typename,gfc_typename): Handle BT_CLASS.
|
||||
* module.c (bt_types,mio_typespec): Handle BT_CLASS.
|
||||
(mio_symbol): Handle vindex.
|
||||
* primary.c (gfc_match_varspec,gfc_variable_attr): Handle BT_CLASS.
|
||||
* resolve.c (find_array_spec,check_typebound_baseobject):
|
||||
Handle BT_CLASS.
|
||||
(resolve_ppc_call,resolve_expr_ppc): Don't call 'gfc_is_proc_ptr_comp'
|
||||
inside 'gcc_assert'.
|
||||
(resolve_deallocate_expr,resolve_allocate_expr): Handle BT_CLASS.
|
||||
(check_class_pointer_assign): New function.
|
||||
(resolve_code): Handle BT_CLASS, call check_class_pointer_assign.
|
||||
(resolve_fl_var_and_proc,type_is_extensible,resolve_fl_variable_derived,
|
||||
resolve_fl_variable): Handle BT_CLASS.
|
||||
(check_generic_tbp_ambiguity): Add special case.
|
||||
(resolve_typebound_procedure,resolve_fl_derived): Handle BT_CLASS.
|
||||
* symbol.c (gfc_get_ultimate_derived_super_type): New function.
|
||||
(gfc_type_compatible): Handle BT_CLASS.
|
||||
* trans-expr.c (conv_parent_component_references): Handle CLASS
|
||||
containers.
|
||||
(gfc_conv_initializer): Handle BT_CLASS.
|
||||
* trans-types.c (gfc_typenode_for_spec,gfc_get_derived_type):
|
||||
Handle BT_CLASS.
|
||||
|
||||
2009-09-29 Daniel Kraft <d@domob.eu>
|
||||
|
||||
PR fortran/39626
|
||||
|
|
|
|||
|
|
@ -2135,9 +2135,6 @@ gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
|
|||
if (variable_check (from, 0) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (array_check (from, 0) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
attr = gfc_variable_attr (from, NULL);
|
||||
if (!attr.allocatable)
|
||||
{
|
||||
|
|
@ -2150,9 +2147,6 @@ gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
|
|||
if (variable_check (to, 0) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (array_check (to, 0) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
attr = gfc_variable_attr (to, NULL);
|
||||
if (!attr.allocatable)
|
||||
{
|
||||
|
|
@ -2162,7 +2156,7 @@ gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
|
|||
return FAILURE;
|
||||
}
|
||||
|
||||
if (same_type_check (from, 0, to, 1) == FAILURE)
|
||||
if (same_type_check (to, 1, from, 0) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (to->rank != from->rank)
|
||||
|
|
@ -2646,6 +2640,46 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
|
|||
}
|
||||
|
||||
|
||||
gfc_try
|
||||
gfc_check_same_type_as (gfc_expr *a, gfc_expr *b)
|
||||
{
|
||||
|
||||
if (a->ts.type != BT_DERIVED && a->ts.type != BT_CLASS)
|
||||
{
|
||||
gfc_error ("'%s' argument of '%s' intrinsic at %L "
|
||||
"must be of a derived type", gfc_current_intrinsic_arg[0],
|
||||
gfc_current_intrinsic, &a->where);
|
||||
return FAILURE;
|
||||
}
|
||||
|
||||
if (!gfc_type_is_extensible (a->ts.u.derived))
|
||||
{
|
||||
gfc_error ("'%s' argument of '%s' intrinsic at %L "
|
||||
"must be of an extensible type", gfc_current_intrinsic_arg[0],
|
||||
gfc_current_intrinsic, &a->where);
|
||||
return FAILURE;
|
||||
}
|
||||
|
||||
if (b->ts.type != BT_DERIVED && b->ts.type != BT_CLASS)
|
||||
{
|
||||
gfc_error ("'%s' argument of '%s' intrinsic at %L "
|
||||
"must be of a derived type", gfc_current_intrinsic_arg[1],
|
||||
gfc_current_intrinsic, &b->where);
|
||||
return FAILURE;
|
||||
}
|
||||
|
||||
if (!gfc_type_is_extensible (b->ts.u.derived))
|
||||
{
|
||||
gfc_error ("'%s' argument of '%s' intrinsic at %L "
|
||||
"must be of an extensible type", gfc_current_intrinsic_arg[1],
|
||||
gfc_current_intrinsic, &b->where);
|
||||
return FAILURE;
|
||||
}
|
||||
|
||||
return SUCCESS;
|
||||
}
|
||||
|
||||
|
||||
gfc_try
|
||||
gfc_check_scale (gfc_expr *x, gfc_expr *i)
|
||||
{
|
||||
|
|
|
|||
|
|
@ -1025,6 +1025,79 @@ 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. */
|
||||
|
||||
static gfc_try
|
||||
encapsulate_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
|
||||
gfc_array_spec **as)
|
||||
{
|
||||
char name[GFC_MAX_SYMBOL_LEN + 5];
|
||||
gfc_symbol *fclass;
|
||||
gfc_component *c;
|
||||
|
||||
/* Determine the name of the encapsulating type. */
|
||||
if ((*as) && (*as)->rank && attr->allocatable)
|
||||
sprintf (name, ".class.%s.%d.a", ts->u.derived->name, (*as)->rank);
|
||||
else if ((*as) && (*as)->rank)
|
||||
sprintf (name, ".class.%s.%d", ts->u.derived->name, (*as)->rank);
|
||||
else if (attr->allocatable)
|
||||
sprintf (name, ".class.%s.a", ts->u.derived->name);
|
||||
else
|
||||
sprintf (name, ".class.%s", ts->u.derived->name);
|
||||
|
||||
gfc_find_symbol (name, ts->u.derived->ns, 0, &fclass);
|
||||
if (fclass == NULL)
|
||||
{
|
||||
gfc_symtree *st;
|
||||
/* If not there, create a new symbol. */
|
||||
fclass = gfc_new_symbol (name, ts->u.derived->ns);
|
||||
st = gfc_new_symtree (&ts->u.derived->ns->sym_root, name);
|
||||
st->n.sym = fclass;
|
||||
gfc_set_sym_referenced (fclass);
|
||||
fclass->refs++;
|
||||
fclass->ts.type = BT_UNKNOWN;
|
||||
fclass->vindex = ts->u.derived->vindex;
|
||||
fclass->attr.abstract = ts->u.derived->attr.abstract;
|
||||
if (ts->u.derived->f2k_derived)
|
||||
fclass->f2k_derived = gfc_get_namespace (NULL, 0);
|
||||
if (gfc_add_flavor (&fclass->attr, FL_DERIVED,
|
||||
NULL, &gfc_current_locus) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
/* Add component '$data'. */
|
||||
if (gfc_add_component (fclass, "$data", &c) == FAILURE)
|
||||
return FAILURE;
|
||||
c->ts = *ts;
|
||||
c->ts.type = BT_DERIVED;
|
||||
c->attr.access = ACCESS_PRIVATE;
|
||||
c->ts.u.derived = ts->u.derived;
|
||||
c->attr.pointer = attr->pointer || attr->dummy;
|
||||
c->attr.allocatable = attr->allocatable;
|
||||
c->attr.dimension = attr->dimension;
|
||||
c->as = (*as);
|
||||
c->initializer = gfc_get_expr ();
|
||||
c->initializer->expr_type = EXPR_NULL;
|
||||
|
||||
/* Add component '$vindex'. */
|
||||
if (gfc_add_component (fclass, "$vindex", &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;
|
||||
fclass->attr.is_class = 1;
|
||||
ts->u.derived = fclass;
|
||||
attr->allocatable = attr->pointer = attr->dimension = 0;
|
||||
(*as) = NULL; /* XXX */
|
||||
return SUCCESS;
|
||||
}
|
||||
|
||||
/* Function called by variable_decl() that adds a name to the symbol table. */
|
||||
|
||||
static gfc_try
|
||||
|
|
@ -1097,6 +1170,9 @@ 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);
|
||||
|
||||
return SUCCESS;
|
||||
}
|
||||
|
||||
|
|
@ -1250,6 +1326,7 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus)
|
|||
/* Check if the assignment can happen. This has to be put off
|
||||
until later for a derived type variable. */
|
||||
if (sym->ts.type != BT_DERIVED && init->ts.type != BT_DERIVED
|
||||
&& sym->ts.type != BT_CLASS && init->ts.type != BT_CLASS
|
||||
&& gfc_check_assign_symbol (sym, init) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
|
|
@ -1467,17 +1544,12 @@ 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)
|
||||
{
|
||||
if (c->attr.allocatable)
|
||||
{
|
||||
gfc_error ("Allocatable component at %C must be an array");
|
||||
return FAILURE;
|
||||
}
|
||||
else
|
||||
return SUCCESS;
|
||||
}
|
||||
return SUCCESS;
|
||||
|
||||
if (c->attr.pointer)
|
||||
{
|
||||
|
|
@ -2370,24 +2442,20 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
|
|||
}
|
||||
|
||||
m = gfc_match (" type ( %n )", name);
|
||||
if (m != MATCH_YES)
|
||||
if (m == MATCH_YES)
|
||||
ts->type = BT_DERIVED;
|
||||
else
|
||||
{
|
||||
m = gfc_match (" class ( %n )", name);
|
||||
if (m != MATCH_YES)
|
||||
return m;
|
||||
ts->is_class = 1;
|
||||
ts->type = BT_CLASS;
|
||||
|
||||
if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: CLASS statement at %C")
|
||||
== FAILURE)
|
||||
return MATCH_ERROR;
|
||||
|
||||
/* TODO: Implement Polymorphism. */
|
||||
gfc_warning ("Polymorphic entities are not yet implemented. "
|
||||
"CLASS will be treated like TYPE at %C");
|
||||
}
|
||||
|
||||
ts->type = BT_DERIVED;
|
||||
|
||||
/* Defer association of the derived type until the end of the
|
||||
specification block. However, if the derived type can be
|
||||
found, add it to the typespec. */
|
||||
|
|
@ -5441,6 +5509,7 @@ gfc_match_end (gfc_statement *st)
|
|||
break;
|
||||
|
||||
case COMP_SELECT:
|
||||
case COMP_SELECT_TYPE:
|
||||
*st = ST_END_SELECT;
|
||||
target = " select";
|
||||
eos_ok = 0;
|
||||
|
|
@ -6703,6 +6772,10 @@ 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;
|
||||
|
||||
|
||||
/* Match the beginning of a derived type declaration. If a type name
|
||||
was the result of a function, then it is possible to have a symbol
|
||||
already to be known as a derived type yet have no components. */
|
||||
|
|
@ -6823,6 +6896,10 @@ gfc_match_derived_decl (void)
|
|||
st->n.sym = sym;
|
||||
}
|
||||
|
||||
if (!sym->vindex)
|
||||
/* Set the vindex for this type and increment the counter. */
|
||||
sym->vindex = ++vindex_counter;
|
||||
|
||||
/* Take over the ABSTRACT attribute. */
|
||||
sym->attr.abstract = attr.abstract;
|
||||
|
||||
|
|
|
|||
|
|
@ -825,7 +825,12 @@ show_symbol (gfc_symbol *sym)
|
|||
}
|
||||
|
||||
if (sym->f2k_derived)
|
||||
show_f2k_derived (sym->f2k_derived);
|
||||
{
|
||||
show_indent ();
|
||||
if (sym->vindex)
|
||||
fprintf (dumpfile, "vindex: %d", sym->vindex);
|
||||
show_f2k_derived (sym->f2k_derived);
|
||||
}
|
||||
|
||||
if (sym->formal)
|
||||
{
|
||||
|
|
@ -1448,7 +1453,7 @@ show_code_node (int level, gfc_code *c)
|
|||
show_expr (c->expr2);
|
||||
}
|
||||
|
||||
for (a = c->ext.alloc_list; a; a = a->next)
|
||||
for (a = c->ext.alloc.list; a; a = a->next)
|
||||
{
|
||||
fputc (' ', dumpfile);
|
||||
show_expr (a->expr);
|
||||
|
|
@ -1470,7 +1475,7 @@ show_code_node (int level, gfc_code *c)
|
|||
show_expr (c->expr2);
|
||||
}
|
||||
|
||||
for (a = c->ext.alloc_list; a; a = a->next)
|
||||
for (a = c->ext.alloc.list; a; a = a->next)
|
||||
{
|
||||
fputc (' ', dumpfile);
|
||||
show_expr (a->expr);
|
||||
|
|
|
|||
|
|
@ -330,6 +330,36 @@ gfc_has_vector_index (gfc_expr *e)
|
|||
}
|
||||
|
||||
|
||||
/* Insert a reference to the component of the given name.
|
||||
Only to be used with CLASS containers. */
|
||||
|
||||
void
|
||||
gfc_add_component_ref (gfc_expr *e, const char *name)
|
||||
{
|
||||
gfc_ref **tail = &(e->ref);
|
||||
gfc_ref *next = NULL;
|
||||
gfc_symbol *derived = e->symtree->n.sym->ts.u.derived;
|
||||
while (*tail != NULL)
|
||||
{
|
||||
if ((*tail)->type == REF_COMPONENT)
|
||||
derived = (*tail)->u.c.component->ts.u.derived;
|
||||
if ((*tail)->type == REF_ARRAY && (*tail)->next == NULL)
|
||||
break;
|
||||
tail = &((*tail)->next);
|
||||
}
|
||||
if (*tail != NULL && strcmp (name, "$data") == 0)
|
||||
next = *tail;
|
||||
(*tail) = gfc_get_ref();
|
||||
(*tail)->next = next;
|
||||
(*tail)->type = REF_COMPONENT;
|
||||
(*tail)->u.c.sym = derived;
|
||||
(*tail)->u.c.component = gfc_find_component (derived, name, true, true);
|
||||
gcc_assert((*tail)->u.c.component);
|
||||
if (!next)
|
||||
e->ts = (*tail)->u.c.component->ts;
|
||||
}
|
||||
|
||||
|
||||
/* Copy a shape array. */
|
||||
|
||||
mpz_t *
|
||||
|
|
@ -481,6 +511,7 @@ gfc_copy_expr (gfc_expr *p)
|
|||
case BT_HOLLERITH:
|
||||
case BT_LOGICAL:
|
||||
case BT_DERIVED:
|
||||
case BT_CLASS:
|
||||
break; /* Already done. */
|
||||
|
||||
case BT_PROCEDURE:
|
||||
|
|
@ -3124,7 +3155,9 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
|
|||
return FAILURE;
|
||||
}
|
||||
|
||||
if (!pointer && !proc_pointer)
|
||||
if (!pointer && !proc_pointer
|
||||
&& !(lvalue->ts.type == BT_CLASS
|
||||
&& lvalue->ts.u.derived->components->attr.pointer))
|
||||
{
|
||||
gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where);
|
||||
return FAILURE;
|
||||
|
|
@ -3244,7 +3277,8 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
|
|||
return SUCCESS;
|
||||
}
|
||||
|
||||
if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
|
||||
if (lvalue->ts.type != BT_CLASS && lvalue->symtree->n.sym->ts.type != BT_CLASS
|
||||
&& !gfc_compare_types (&lvalue->ts, &rvalue->ts))
|
||||
{
|
||||
gfc_error ("Different types in pointer assignment at %L; attempted "
|
||||
"assignment of %s to %s", &lvalue->where,
|
||||
|
|
@ -3252,7 +3286,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
|
|||
return FAILURE;
|
||||
}
|
||||
|
||||
if (lvalue->ts.kind != rvalue->ts.kind)
|
||||
if (lvalue->ts.type != BT_CLASS && lvalue->ts.kind != rvalue->ts.kind)
|
||||
{
|
||||
gfc_error ("Different kind type parameters in pointer "
|
||||
"assignment at %L", &lvalue->where);
|
||||
|
|
@ -3332,7 +3366,10 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
|
|||
lvalue.symtree->n.sym = sym;
|
||||
lvalue.where = sym->declared_at;
|
||||
|
||||
if (sym->attr.pointer || sym->attr.proc_pointer)
|
||||
if (sym->attr.pointer || sym->attr.proc_pointer
|
||||
|| (sym->ts.type == BT_CLASS
|
||||
&& sym->ts.u.derived->components->attr.pointer
|
||||
&& rvalue->expr_type == EXPR_NULL))
|
||||
r = gfc_check_pointer_assign (&lvalue, rvalue);
|
||||
else
|
||||
r = gfc_check_assign (&lvalue, rvalue, 1);
|
||||
|
|
|
|||
|
|
@ -142,9 +142,8 @@ gfc_source_form;
|
|||
/* Basic types. BT_VOID is used by ISO C Binding so funcs like c_f_pointer
|
||||
can take any arg with the pointer attribute as a param. */
|
||||
typedef enum
|
||||
{ BT_UNKNOWN = 1, BT_INTEGER, BT_REAL, BT_COMPLEX,
|
||||
BT_LOGICAL, BT_CHARACTER, BT_DERIVED, BT_PROCEDURE, BT_HOLLERITH,
|
||||
BT_VOID
|
||||
{ BT_UNKNOWN = 1, BT_INTEGER, BT_REAL, BT_COMPLEX, BT_LOGICAL, BT_CHARACTER,
|
||||
BT_DERIVED, BT_CLASS, BT_PROCEDURE, BT_HOLLERITH, BT_VOID
|
||||
}
|
||||
bt;
|
||||
|
||||
|
|
@ -222,7 +221,7 @@ typedef enum
|
|||
ST_STOP, ST_SUBROUTINE, ST_TYPE, ST_USE, ST_WHERE_BLOCK, ST_WHERE, ST_WAIT,
|
||||
ST_WRITE, ST_ASSIGNMENT, ST_POINTER_ASSIGNMENT, ST_SELECT_CASE, ST_SEQUENCE,
|
||||
ST_SIMPLE_IF, ST_STATEMENT_FUNCTION, ST_DERIVED_DECL, ST_LABEL_ASSIGNMENT,
|
||||
ST_ENUM, ST_ENUMERATOR, ST_END_ENUM,
|
||||
ST_ENUM, ST_ENUMERATOR, ST_END_ENUM, ST_SELECT_TYPE, ST_TYPE_IS, ST_CLASS_IS,
|
||||
ST_OMP_ATOMIC, ST_OMP_BARRIER, ST_OMP_CRITICAL, ST_OMP_END_CRITICAL,
|
||||
ST_OMP_END_DO, ST_OMP_END_MASTER, ST_OMP_END_ORDERED, ST_OMP_END_PARALLEL,
|
||||
ST_OMP_END_PARALLEL_DO, ST_OMP_END_PARALLEL_SECTIONS,
|
||||
|
|
@ -364,6 +363,7 @@ enum gfc_isym_id
|
|||
GFC_ISYM_EXIT,
|
||||
GFC_ISYM_EXP,
|
||||
GFC_ISYM_EXPONENT,
|
||||
GFC_ISYM_EXTENDS_TYPE_OF,
|
||||
GFC_ISYM_FDATE,
|
||||
GFC_ISYM_FGET,
|
||||
GFC_ISYM_FGETC,
|
||||
|
|
@ -478,6 +478,7 @@ enum gfc_isym_id
|
|||
GFC_ISYM_RESHAPE,
|
||||
GFC_ISYM_RRSPACING,
|
||||
GFC_ISYM_RSHIFT,
|
||||
GFC_ISYM_SAME_TYPE_AS,
|
||||
GFC_ISYM_SC_KIND,
|
||||
GFC_ISYM_SCALE,
|
||||
GFC_ISYM_SCAN,
|
||||
|
|
@ -670,6 +671,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. */
|
||||
|
||||
/* These flags are both in the typespec and attribute. The attribute
|
||||
list is what gets read from/written to a module file. The typespec
|
||||
|
|
@ -849,7 +851,6 @@ typedef struct
|
|||
u;
|
||||
|
||||
struct gfc_symbol *interface; /* For PROCEDURE declarations. */
|
||||
unsigned int is_class:1;
|
||||
int is_c_interop;
|
||||
int is_iso_c;
|
||||
bt f90_type;
|
||||
|
|
@ -1133,6 +1134,11 @@ typedef struct gfc_symbol
|
|||
/* Defined only for Cray pointees; points to their pointer. */
|
||||
struct gfc_symbol *cp_pointer;
|
||||
|
||||
int entry_id; /* Used in resolve.c for entries. */
|
||||
|
||||
/* CLASS vindex for declared and dynamic types in the class. */
|
||||
int vindex;
|
||||
|
||||
struct gfc_symbol *common_next; /* Links for COMMON syms */
|
||||
|
||||
/* This is in fact a gfc_common_head but it is only used for pointer
|
||||
|
|
@ -1143,8 +1149,6 @@ typedef struct gfc_symbol
|
|||
order. */
|
||||
int dummy_order;
|
||||
|
||||
int entry_id;
|
||||
|
||||
gfc_namelist *namelist, *namelist_tail;
|
||||
|
||||
/* Change management fields. Symbols that might be modified by the
|
||||
|
|
@ -1856,6 +1860,9 @@ typedef struct gfc_case
|
|||
represents the default case. */
|
||||
gfc_expr *low, *high;
|
||||
|
||||
/* Only used for SELECT TYPE. */
|
||||
gfc_typespec ts;
|
||||
|
||||
/* Next case label in the list of cases for a single CASE label. */
|
||||
struct gfc_case *next;
|
||||
|
||||
|
|
@ -1972,7 +1979,7 @@ typedef enum
|
|||
EXEC_ENTRY, EXEC_PAUSE, EXEC_STOP, EXEC_CONTINUE, EXEC_INIT_ASSIGN,
|
||||
EXEC_IF, EXEC_ARITHMETIC_IF, EXEC_DO, EXEC_DO_WHILE, EXEC_SELECT, EXEC_BLOCK,
|
||||
EXEC_FORALL, EXEC_WHERE, EXEC_CYCLE, EXEC_EXIT, EXEC_CALL_PPC,
|
||||
EXEC_ALLOCATE, EXEC_DEALLOCATE, EXEC_END_PROCEDURE,
|
||||
EXEC_ALLOCATE, EXEC_DEALLOCATE, EXEC_END_PROCEDURE, EXEC_SELECT_TYPE,
|
||||
EXEC_OPEN, EXEC_CLOSE, EXEC_WAIT,
|
||||
EXEC_READ, EXEC_WRITE, EXEC_IOLENGTH, EXEC_TRANSFER, EXEC_DT_END,
|
||||
EXEC_BACKSPACE, EXEC_ENDFILE, EXEC_INQUIRE, EXEC_REWIND, EXEC_FLUSH,
|
||||
|
|
@ -2006,7 +2013,14 @@ typedef struct gfc_code
|
|||
gfc_actual_arglist *actual;
|
||||
gfc_case *case_list;
|
||||
gfc_iterator *iterator;
|
||||
gfc_alloc *alloc_list;
|
||||
|
||||
struct
|
||||
{
|
||||
gfc_typespec ts;
|
||||
gfc_alloc *list;
|
||||
}
|
||||
alloc;
|
||||
|
||||
gfc_open *open;
|
||||
gfc_close *close;
|
||||
gfc_filepos *filepos;
|
||||
|
|
@ -2476,6 +2490,8 @@ gfc_gsymbol *gfc_find_gsymbol (gfc_gsymbol *, const char *);
|
|||
|
||||
gfc_typebound_proc* gfc_get_typebound_proc (void);
|
||||
gfc_symbol* gfc_get_derived_super_type (gfc_symbol*);
|
||||
gfc_symbol* gfc_get_ultimate_derived_super_type (gfc_symbol*);
|
||||
bool gfc_type_is_extension_of (gfc_symbol *, gfc_symbol *);
|
||||
bool gfc_type_compatible (gfc_typespec *, gfc_typespec *);
|
||||
gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, gfc_try*,
|
||||
const char*, bool, locus*);
|
||||
|
|
@ -2534,6 +2550,10 @@ 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 *);
|
||||
|
||||
|
|
@ -2548,9 +2568,9 @@ void gfc_resolve_omp_do_blocks (gfc_code *, gfc_namespace *);
|
|||
void gfc_free_actual_arglist (gfc_actual_arglist *);
|
||||
gfc_actual_arglist *gfc_copy_actual_arglist (gfc_actual_arglist *);
|
||||
const char *gfc_extract_int (gfc_expr *, int *);
|
||||
gfc_expr *gfc_expr_to_initialize (gfc_expr *);
|
||||
bool is_subref_array (gfc_expr *);
|
||||
|
||||
void gfc_add_component_ref (gfc_expr *, const char *);
|
||||
gfc_expr *gfc_build_conversion (gfc_expr *);
|
||||
void gfc_free_ref_list (gfc_ref *);
|
||||
void gfc_type_convert_binary (gfc_expr *);
|
||||
|
|
@ -2614,6 +2634,8 @@ gfc_try gfc_resolve_dim_arg (gfc_expr *);
|
|||
int gfc_is_formal_arg (void);
|
||||
void gfc_resolve_substring_charlen (gfc_expr *);
|
||||
match gfc_iso_c_sub_interface(gfc_code *, gfc_symbol *);
|
||||
gfc_expr *gfc_expr_to_initialize (gfc_expr *);
|
||||
bool gfc_type_is_extensible (gfc_symbol *sym);
|
||||
|
||||
|
||||
/* array.c */
|
||||
|
|
|
|||
|
|
@ -360,6 +360,9 @@ gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2)
|
|||
{
|
||||
gfc_component *dt1, *dt2;
|
||||
|
||||
if (derived1 == derived2)
|
||||
return 1;
|
||||
|
||||
/* Special case for comparing derived types across namespaces. If the
|
||||
true names and module names are the same and the module name is
|
||||
nonnull, then they are equal. */
|
||||
|
|
@ -448,13 +451,15 @@ gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2)
|
|||
if (ts1->type == BT_VOID || ts2->type == BT_VOID)
|
||||
return 1;
|
||||
|
||||
if (ts1->type != ts2->type)
|
||||
if (ts1->type != ts2->type
|
||||
&& ((ts1->type != BT_DERIVED && ts1->type != BT_CLASS)
|
||||
|| (ts2->type != BT_DERIVED && ts2->type != BT_CLASS)))
|
||||
return 0;
|
||||
if (ts1->type != BT_DERIVED)
|
||||
if (ts1->type != BT_DERIVED && ts1->type != BT_CLASS)
|
||||
return (ts1->kind == ts2->kind);
|
||||
|
||||
/* Compare derived types. */
|
||||
if (ts1->u.derived == ts2->u.derived)
|
||||
if (gfc_type_compatible (ts1, ts2))
|
||||
return 1;
|
||||
|
||||
return gfc_compare_derived_types (ts1->u.derived ,ts2->u.derived);
|
||||
|
|
|
|||
|
|
@ -1599,6 +1599,12 @@ add_functions (void)
|
|||
|
||||
make_generic ("exponent", GFC_ISYM_EXPONENT, GFC_STD_F95);
|
||||
|
||||
add_sym_2 ("extends_type_of", GFC_ISYM_EXTENDS_TYPE_OF, CLASS_INQUIRY,
|
||||
ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F2003,
|
||||
gfc_check_same_type_as, NULL, NULL,
|
||||
a, BT_UNKNOWN, 0, REQUIRED,
|
||||
mo, BT_UNKNOWN, 0, REQUIRED);
|
||||
|
||||
add_sym_0 ("fdate", GFC_ISYM_FDATE, NO_CLASS, ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_GNU,
|
||||
NULL, NULL, gfc_resolve_fdate);
|
||||
|
||||
|
|
@ -2307,6 +2313,12 @@ add_functions (void)
|
|||
|
||||
make_generic ("rrspacing", GFC_ISYM_RRSPACING, GFC_STD_F95);
|
||||
|
||||
add_sym_2 ("same_type_as", GFC_ISYM_SAME_TYPE_AS, CLASS_INQUIRY, ACTUAL_NO,
|
||||
BT_LOGICAL, dl, GFC_STD_F2003,
|
||||
gfc_check_same_type_as, NULL, NULL,
|
||||
a, BT_UNKNOWN, 0, REQUIRED,
|
||||
b, BT_UNKNOWN, 0, REQUIRED);
|
||||
|
||||
add_sym_2 ("scale", GFC_ISYM_SCALE, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
|
||||
gfc_check_scale, gfc_simplify_scale, gfc_resolve_scale,
|
||||
x, BT_REAL, dr, REQUIRED, i, BT_INTEGER, di, REQUIRED);
|
||||
|
|
|
|||
|
|
@ -119,6 +119,7 @@ gfc_try gfc_check_real (gfc_expr *, gfc_expr *);
|
|||
gfc_try gfc_check_rename (gfc_expr *, gfc_expr *);
|
||||
gfc_try gfc_check_repeat (gfc_expr *, gfc_expr *);
|
||||
gfc_try gfc_check_reshape (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
gfc_try gfc_check_same_type_as (gfc_expr *, gfc_expr *);
|
||||
gfc_try gfc_check_scale (gfc_expr *, gfc_expr *);
|
||||
gfc_try gfc_check_scan (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
gfc_try gfc_check_second_sub (gfc_expr *);
|
||||
|
|
|
|||
|
|
@ -29,6 +29,10 @@ 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;
|
||||
|
||||
/* For debugging and diagnostic purposes. Return the textual representation
|
||||
of the intrinsic operator OP. */
|
||||
const char *
|
||||
|
|
@ -2245,6 +2249,39 @@ gfc_free_alloc_list (gfc_alloc *p)
|
|||
}
|
||||
|
||||
|
||||
/* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of
|
||||
an accessible derived type. */
|
||||
|
||||
static match
|
||||
match_derived_type_spec (gfc_typespec *ts)
|
||||
{
|
||||
locus old_locus;
|
||||
gfc_symbol *derived;
|
||||
|
||||
old_locus = gfc_current_locus;
|
||||
|
||||
if (gfc_match_symbol (&derived, 1) == MATCH_YES)
|
||||
{
|
||||
if (derived->attr.flavor == FL_DERIVED)
|
||||
{
|
||||
ts->type = BT_DERIVED;
|
||||
ts->u.derived = derived;
|
||||
return MATCH_YES;
|
||||
}
|
||||
else
|
||||
{
|
||||
/* Enforce F03:C476. */
|
||||
gfc_error ("'%s' at %L is not an accessible derived type",
|
||||
derived->name, &gfc_current_locus);
|
||||
return MATCH_ERROR;
|
||||
}
|
||||
}
|
||||
|
||||
gfc_current_locus = old_locus;
|
||||
return MATCH_NO;
|
||||
}
|
||||
|
||||
|
||||
/* Match a Fortran 2003 type-spec (F03:R401). This is similar to
|
||||
gfc_match_decl_type_spec() from decl.c, with the following exceptions:
|
||||
It only includes the intrinsic types from the Fortran 2003 standard
|
||||
|
|
@ -2256,7 +2293,6 @@ static match
|
|||
match_type_spec (gfc_typespec *ts)
|
||||
{
|
||||
match m;
|
||||
gfc_symbol *derived;
|
||||
locus old_locus;
|
||||
|
||||
gfc_clear_ts (ts);
|
||||
|
|
@ -2303,43 +2339,27 @@ match_type_spec (gfc_typespec *ts)
|
|||
goto kind_selector;
|
||||
}
|
||||
|
||||
if (gfc_match_symbol (&derived, 1) == MATCH_YES)
|
||||
m = match_derived_type_spec (ts);
|
||||
if (m == MATCH_YES)
|
||||
{
|
||||
if (derived->attr.flavor == FL_DERIVED)
|
||||
old_locus = gfc_current_locus;
|
||||
if (gfc_match (" :: ") != MATCH_YES)
|
||||
return MATCH_ERROR;
|
||||
gfc_current_locus = old_locus;
|
||||
/* Enfore F03:C401. */
|
||||
if (ts->u.derived->attr.abstract)
|
||||
{
|
||||
old_locus = gfc_current_locus;
|
||||
if (gfc_match (" :: ") != MATCH_YES)
|
||||
return MATCH_ERROR;
|
||||
gfc_current_locus = old_locus;
|
||||
ts->type = BT_DERIVED;
|
||||
ts->u.derived = derived;
|
||||
/* Enfore F03:C401. */
|
||||
if (derived->attr.abstract)
|
||||
{
|
||||
gfc_error ("Derived type '%s' at %L may not be ABSTRACT",
|
||||
derived->name, &old_locus);
|
||||
return MATCH_ERROR;
|
||||
}
|
||||
return MATCH_YES;
|
||||
}
|
||||
else
|
||||
{
|
||||
if (gfc_match (" :: ") == MATCH_YES)
|
||||
{
|
||||
/* Enforce F03:C476. */
|
||||
gfc_error ("'%s' at %L is not an accessible derived type",
|
||||
derived->name, &old_locus);
|
||||
return MATCH_ERROR;
|
||||
}
|
||||
else
|
||||
{
|
||||
gfc_current_locus = old_locus;
|
||||
return MATCH_NO;
|
||||
}
|
||||
gfc_error ("Derived type '%s' at %L may not be ABSTRACT",
|
||||
ts->u.derived->name, &old_locus);
|
||||
return MATCH_ERROR;
|
||||
}
|
||||
return MATCH_YES;
|
||||
}
|
||||
else if (m == MATCH_ERROR && gfc_match (" :: ") == MATCH_YES)
|
||||
return MATCH_ERROR;
|
||||
|
||||
/* If a type is not matched, simply return MATCH_NO. */
|
||||
/* If a type is not matched, simply return MATCH_NO. */
|
||||
gfc_current_locus = old_locus;
|
||||
return MATCH_NO;
|
||||
|
||||
kind_selector:
|
||||
|
|
@ -2429,6 +2449,7 @@ gfc_match_allocate (void)
|
|||
gfc_alloc *head, *tail;
|
||||
gfc_expr *stat, *errmsg, *tmp, *source;
|
||||
gfc_typespec ts;
|
||||
gfc_symbol *sym;
|
||||
match m;
|
||||
locus old_locus;
|
||||
bool saw_stat, saw_errmsg, saw_source, b1, b2, b3;
|
||||
|
|
@ -2513,19 +2534,20 @@ gfc_match_allocate (void)
|
|||
tail->expr->ts.u.derived = gfc_use_derived (tail->expr->ts.u.derived);
|
||||
|
||||
/* FIXME: disable the checking on derived types and arrays. */
|
||||
sym = tail->expr->symtree->n.sym;
|
||||
b1 = !(tail->expr->ref
|
||||
&& (tail->expr->ref->type == REF_COMPONENT
|
||||
|| tail->expr->ref->type == REF_ARRAY));
|
||||
b2 = tail->expr->symtree->n.sym
|
||||
&& !(tail->expr->symtree->n.sym->attr.allocatable
|
||||
|| tail->expr->symtree->n.sym->attr.pointer
|
||||
|| tail->expr->symtree->n.sym->attr.proc_pointer);
|
||||
b3 = tail->expr->symtree->n.sym
|
||||
&& tail->expr->symtree->n.sym->ns
|
||||
&& tail->expr->symtree->n.sym->ns->proc_name
|
||||
&& (tail->expr->symtree->n.sym->ns->proc_name->attr.allocatable
|
||||
|| tail->expr->symtree->n.sym->ns->proc_name->attr.pointer
|
||||
|| tail->expr->symtree->n.sym->ns->proc_name->attr.proc_pointer);
|
||||
if (sym && sym->ts.type == BT_CLASS)
|
||||
b2 = !(sym->ts.u.derived->components->attr.allocatable
|
||||
|| sym->ts.u.derived->components->attr.pointer);
|
||||
else
|
||||
b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
|
||||
|| sym->attr.proc_pointer);
|
||||
b3 = sym && sym->ns && sym->ns->proc_name
|
||||
&& (sym->ns->proc_name->attr.allocatable
|
||||
|| sym->ns->proc_name->attr.pointer
|
||||
|| sym->ns->proc_name->attr.proc_pointer);
|
||||
if (b1 && b2 && !b3)
|
||||
{
|
||||
gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
|
||||
|
|
@ -2616,7 +2638,7 @@ alloc_opt_list:
|
|||
|
||||
gfc_resolve_expr (tmp);
|
||||
|
||||
if (head->expr->ts.type != tmp->ts.type)
|
||||
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);
|
||||
|
|
@ -2657,7 +2679,8 @@ alloc_opt_list:
|
|||
new_st.expr1 = stat;
|
||||
new_st.expr2 = errmsg;
|
||||
new_st.expr3 = source;
|
||||
new_st.ext.alloc_list = head;
|
||||
new_st.ext.alloc.list = head;
|
||||
new_st.ext.alloc.ts = ts;
|
||||
|
||||
return MATCH_YES;
|
||||
|
||||
|
|
@ -2754,8 +2777,9 @@ gfc_match_deallocate (void)
|
|||
{
|
||||
gfc_alloc *head, *tail;
|
||||
gfc_expr *stat, *errmsg, *tmp;
|
||||
gfc_symbol *sym;
|
||||
match m;
|
||||
bool saw_stat, saw_errmsg;
|
||||
bool saw_stat, saw_errmsg, b1, b2;
|
||||
|
||||
head = tail = NULL;
|
||||
stat = errmsg = tmp = NULL;
|
||||
|
|
@ -2783,20 +2807,25 @@ gfc_match_deallocate (void)
|
|||
if (gfc_check_do_variable (tail->expr->symtree))
|
||||
goto cleanup;
|
||||
|
||||
if (gfc_pure (NULL) && gfc_impure_variable (tail->expr->symtree->n.sym))
|
||||
sym = tail->expr->symtree->n.sym;
|
||||
|
||||
if (gfc_pure (NULL) && gfc_impure_variable (sym))
|
||||
{
|
||||
gfc_error ("Illegal allocate-object at %C for a PURE procedure");
|
||||
goto cleanup;
|
||||
}
|
||||
|
||||
/* FIXME: disable the checking on derived types. */
|
||||
if (!(tail->expr->ref
|
||||
b1 = !(tail->expr->ref
|
||||
&& (tail->expr->ref->type == REF_COMPONENT
|
||||
|| tail->expr->ref->type == REF_ARRAY))
|
||||
&& tail->expr->symtree->n.sym
|
||||
&& !(tail->expr->symtree->n.sym->attr.allocatable
|
||||
|| tail->expr->symtree->n.sym->attr.pointer
|
||||
|| tail->expr->symtree->n.sym->attr.proc_pointer))
|
||||
|| tail->expr->ref->type == REF_ARRAY));
|
||||
if (sym && sym->ts.type == BT_CLASS)
|
||||
b2 = !(sym->ts.u.derived->components->attr.allocatable
|
||||
|| sym->ts.u.derived->components->attr.pointer);
|
||||
else
|
||||
b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
|
||||
|| sym->attr.proc_pointer);
|
||||
if (b1 && b2)
|
||||
{
|
||||
gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
|
||||
"or an allocatable variable");
|
||||
|
|
@ -2865,7 +2894,7 @@ dealloc_opt_list:
|
|||
new_st.op = EXEC_DEALLOCATE;
|
||||
new_st.expr1 = stat;
|
||||
new_st.expr2 = errmsg;
|
||||
new_st.ext.alloc_list = head;
|
||||
new_st.ext.alloc.list = head;
|
||||
|
||||
return MATCH_YES;
|
||||
|
||||
|
|
@ -3021,7 +3050,8 @@ gfc_match_call (void)
|
|||
|
||||
/* If this is a variable of derived-type, it probably starts a type-bound
|
||||
procedure call. */
|
||||
if (sym->attr.flavor != FL_PROCEDURE && sym->ts.type == BT_DERIVED)
|
||||
if (sym->attr.flavor != FL_PROCEDURE
|
||||
&& (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS))
|
||||
return match_typebound_call (st);
|
||||
|
||||
/* If it does not seem to be callable (include functions so that the
|
||||
|
|
@ -3949,10 +3979,7 @@ match_case_eos (void)
|
|||
/* If the case construct doesn't have a case-construct-name, we
|
||||
should have matched the EOS. */
|
||||
if (!gfc_current_block ())
|
||||
{
|
||||
gfc_error ("Expected the name of the SELECT CASE construct at %C");
|
||||
return MATCH_ERROR;
|
||||
}
|
||||
return MATCH_NO;
|
||||
|
||||
gfc_gobble_whitespace ();
|
||||
|
||||
|
|
@ -3962,7 +3989,7 @@ match_case_eos (void)
|
|||
|
||||
if (strcmp (name, gfc_current_block ()->name) != 0)
|
||||
{
|
||||
gfc_error ("Expected case name of '%s' at %C",
|
||||
gfc_error ("Expected block name '%s' of SELECT construct at %C",
|
||||
gfc_current_block ()->name);
|
||||
return MATCH_ERROR;
|
||||
}
|
||||
|
|
@ -3994,6 +4021,61 @@ gfc_match_select (void)
|
|||
}
|
||||
|
||||
|
||||
/* Match a SELECT TYPE statement. */
|
||||
|
||||
match
|
||||
gfc_match_select_type (void)
|
||||
{
|
||||
gfc_expr *expr;
|
||||
match m;
|
||||
|
||||
m = gfc_match_label ();
|
||||
if (m == MATCH_ERROR)
|
||||
return m;
|
||||
|
||||
m = gfc_match (" select type ( %e ", &expr);
|
||||
if (m != MATCH_YES)
|
||||
return m;
|
||||
|
||||
/* TODO: Implement ASSOCIATE. */
|
||||
m = gfc_match (" => ");
|
||||
if (m == MATCH_YES)
|
||||
{
|
||||
gfc_error ("Associate-name in SELECT TYPE statement at %C "
|
||||
"is not yet supported");
|
||||
return MATCH_ERROR;
|
||||
}
|
||||
|
||||
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)
|
||||
{
|
||||
gfc_error ("Selector must be a named variable in SELECT TYPE statement "
|
||||
"at %C");
|
||||
return MATCH_ERROR;
|
||||
}
|
||||
|
||||
/* Check for F03:C813. */
|
||||
if (expr->ts.type != BT_CLASS)
|
||||
{
|
||||
gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
|
||||
"at %C");
|
||||
return MATCH_ERROR;
|
||||
}
|
||||
|
||||
new_st.op = EXEC_SELECT_TYPE;
|
||||
new_st.expr1 = expr;
|
||||
|
||||
type_selector = expr->symtree->n.sym;
|
||||
|
||||
return MATCH_YES;
|
||||
}
|
||||
|
||||
|
||||
/* Match a CASE statement. */
|
||||
|
||||
match
|
||||
|
|
@ -4058,13 +4140,142 @@ gfc_match_case (void)
|
|||
return MATCH_YES;
|
||||
|
||||
syntax:
|
||||
gfc_error ("Syntax error in CASE-specification at %C");
|
||||
gfc_error ("Syntax error in CASE specification at %C");
|
||||
|
||||
cleanup:
|
||||
gfc_free_case_list (head); /* new_st is cleaned up in parse.c. */
|
||||
return MATCH_ERROR;
|
||||
}
|
||||
|
||||
|
||||
/* Match a TYPE IS statement. */
|
||||
|
||||
match
|
||||
gfc_match_type_is (void)
|
||||
{
|
||||
gfc_case *c = NULL;
|
||||
match m;
|
||||
char name[GFC_MAX_SYMBOL_LEN];
|
||||
|
||||
if (gfc_current_state () != COMP_SELECT_TYPE)
|
||||
{
|
||||
gfc_error ("Unexpected TYPE IS statement at %C");
|
||||
return MATCH_ERROR;
|
||||
}
|
||||
|
||||
if (gfc_match_char ('(') != MATCH_YES)
|
||||
goto syntax;
|
||||
|
||||
c = gfc_get_case ();
|
||||
c->where = gfc_current_locus;
|
||||
|
||||
/* TODO: Once unlimited polymorphism is implemented, we will need to call
|
||||
match_type_spec here. */
|
||||
if (match_derived_type_spec (&c->ts) == MATCH_ERROR)
|
||||
goto cleanup;
|
||||
|
||||
if (gfc_match_char (')') != MATCH_YES)
|
||||
goto syntax;
|
||||
|
||||
m = match_case_eos ();
|
||||
if (m == MATCH_NO)
|
||||
goto syntax;
|
||||
if (m == MATCH_ERROR)
|
||||
goto cleanup;
|
||||
|
||||
new_st.op = EXEC_SELECT_TYPE;
|
||||
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;
|
||||
|
||||
return MATCH_YES;
|
||||
|
||||
syntax:
|
||||
gfc_error ("Syntax error in TYPE IS specification at %C");
|
||||
|
||||
cleanup:
|
||||
if (c != NULL)
|
||||
gfc_free_case_list (c); /* new_st is cleaned up in parse.c. */
|
||||
return MATCH_ERROR;
|
||||
}
|
||||
|
||||
|
||||
/* Match a CLASS IS or CLASS DEFAULT statement. */
|
||||
|
||||
match
|
||||
gfc_match_class_is (void)
|
||||
{
|
||||
gfc_case *c = NULL;
|
||||
match m;
|
||||
|
||||
if (gfc_current_state () != COMP_SELECT_TYPE)
|
||||
return MATCH_NO;
|
||||
|
||||
if (gfc_match ("% default") == MATCH_YES)
|
||||
{
|
||||
m = match_case_eos ();
|
||||
if (m == MATCH_NO)
|
||||
goto syntax;
|
||||
if (m == MATCH_ERROR)
|
||||
goto cleanup;
|
||||
|
||||
new_st.op = EXEC_SELECT_TYPE;
|
||||
c = gfc_get_case ();
|
||||
c->where = gfc_current_locus;
|
||||
c->ts.type = BT_UNKNOWN;
|
||||
new_st.ext.case_list = c;
|
||||
return MATCH_YES;
|
||||
}
|
||||
|
||||
m = gfc_match ("% is");
|
||||
if (m == MATCH_NO)
|
||||
goto syntax;
|
||||
if (m == MATCH_ERROR)
|
||||
goto cleanup;
|
||||
|
||||
if (gfc_match_char ('(') != MATCH_YES)
|
||||
goto syntax;
|
||||
|
||||
c = gfc_get_case ();
|
||||
c->where = gfc_current_locus;
|
||||
|
||||
if (match_derived_type_spec (&c->ts) == MATCH_ERROR)
|
||||
goto cleanup;
|
||||
|
||||
if (c->ts.type == BT_DERIVED)
|
||||
c->ts.type = BT_CLASS;
|
||||
|
||||
if (gfc_match_char (')') != MATCH_YES)
|
||||
goto syntax;
|
||||
|
||||
m = match_case_eos ();
|
||||
if (m == MATCH_NO)
|
||||
goto syntax;
|
||||
if (m == MATCH_ERROR)
|
||||
goto cleanup;
|
||||
|
||||
new_st.op = EXEC_SELECT_TYPE;
|
||||
new_st.ext.case_list = c;
|
||||
|
||||
gfc_error_now ("CLASS IS specification at %C is not yet supported");
|
||||
|
||||
return MATCH_YES;
|
||||
|
||||
syntax:
|
||||
gfc_error ("Syntax error in CLASS IS specification at %C");
|
||||
|
||||
cleanup:
|
||||
if (c != NULL)
|
||||
gfc_free_case_list (c); /* new_st is cleaned up in parse.c. */
|
||||
return MATCH_ERROR;
|
||||
}
|
||||
|
||||
|
||||
/********************* WHERE subroutines ********************/
|
||||
|
||||
/* Match the rest of a simple WHERE statement that follows an IF statement.
|
||||
|
|
|
|||
|
|
@ -101,6 +101,9 @@ match gfc_match_equivalence (void);
|
|||
match gfc_match_st_function (void);
|
||||
match gfc_match_case (void);
|
||||
match gfc_match_select (void);
|
||||
match gfc_match_select_type (void);
|
||||
match gfc_match_type_is (void);
|
||||
match gfc_match_class_is (void);
|
||||
match gfc_match_where (gfc_statement *);
|
||||
match gfc_match_elsewhere (void);
|
||||
match gfc_match_forall (gfc_statement *);
|
||||
|
|
|
|||
|
|
@ -71,7 +71,6 @@ gfc_clear_ts (gfc_typespec *ts)
|
|||
ts->kind = 0;
|
||||
ts->u.cl = NULL;
|
||||
ts->interface = NULL;
|
||||
ts->is_class = 0;
|
||||
/* flag that says if the type is C interoperable */
|
||||
ts->is_c_interop = 0;
|
||||
/* says what f90 type the C kind interops with */
|
||||
|
|
@ -131,6 +130,9 @@ gfc_basic_typename (bt type)
|
|||
case BT_DERIVED:
|
||||
p = "DERIVED";
|
||||
break;
|
||||
case BT_CLASS:
|
||||
p = "CLASS";
|
||||
break;
|
||||
case BT_PROCEDURE:
|
||||
p = "PROCEDURE";
|
||||
break;
|
||||
|
|
@ -186,6 +188,10 @@ gfc_typename (gfc_typespec *ts)
|
|||
case BT_DERIVED:
|
||||
sprintf (buffer, "TYPE(%s)", ts->u.derived->name);
|
||||
break;
|
||||
case BT_CLASS:
|
||||
sprintf (buffer, "CLASS(%s)",
|
||||
ts->u.derived->components->ts.u.derived->name);
|
||||
break;
|
||||
case BT_PROCEDURE:
|
||||
strcpy (buffer, "PROCEDURE");
|
||||
break;
|
||||
|
|
|
|||
|
|
@ -1672,7 +1672,7 @@ typedef enum
|
|||
AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE, AB_ALLOC_COMP,
|
||||
AB_POINTER_COMP, AB_PRIVATE_COMP, AB_VALUE, AB_VOLATILE, AB_PROTECTED,
|
||||
AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP,
|
||||
AB_EXTENSION, AB_PROCEDURE, AB_PROC_POINTER
|
||||
AB_EXTENSION, AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER
|
||||
}
|
||||
ab_attribute;
|
||||
|
||||
|
|
@ -1713,6 +1713,7 @@ static const mstring attr_bits[] =
|
|||
minit ("PROTECTED", AB_PROTECTED),
|
||||
minit ("ABSTRACT", AB_ABSTRACT),
|
||||
minit ("EXTENSION", AB_EXTENSION),
|
||||
minit ("IS_CLASS", AB_IS_CLASS),
|
||||
minit ("PROCEDURE", AB_PROCEDURE),
|
||||
minit ("PROC_POINTER", AB_PROC_POINTER),
|
||||
minit (NULL, -1)
|
||||
|
|
@ -1860,6 +1861,8 @@ mio_symbol_attribute (symbol_attribute *attr)
|
|||
MIO_NAME (ab_attribute) (AB_ZERO_COMP, attr_bits);
|
||||
if (attr->extension)
|
||||
MIO_NAME (ab_attribute) (AB_EXTENSION, attr_bits);
|
||||
if (attr->is_class)
|
||||
MIO_NAME (ab_attribute) (AB_IS_CLASS, attr_bits);
|
||||
if (attr->procedure)
|
||||
MIO_NAME (ab_attribute) (AB_PROCEDURE, attr_bits);
|
||||
if (attr->proc_pointer)
|
||||
|
|
@ -1985,6 +1988,9 @@ mio_symbol_attribute (symbol_attribute *attr)
|
|||
case AB_EXTENSION:
|
||||
attr->extension = 1;
|
||||
break;
|
||||
case AB_IS_CLASS:
|
||||
attr->is_class = 1;
|
||||
break;
|
||||
case AB_PROCEDURE:
|
||||
attr->procedure = 1;
|
||||
break;
|
||||
|
|
@ -2004,6 +2010,7 @@ static const mstring bt_types[] = {
|
|||
minit ("LOGICAL", BT_LOGICAL),
|
||||
minit ("CHARACTER", BT_CHARACTER),
|
||||
minit ("DERIVED", BT_DERIVED),
|
||||
minit ("CLASS", BT_CLASS),
|
||||
minit ("PROCEDURE", BT_PROCEDURE),
|
||||
minit ("UNKNOWN", BT_UNKNOWN),
|
||||
minit ("VOID", BT_VOID),
|
||||
|
|
@ -2054,7 +2061,7 @@ mio_typespec (gfc_typespec *ts)
|
|||
|
||||
ts->type = MIO_NAME (bt) (ts->type, bt_types);
|
||||
|
||||
if (ts->type != BT_DERIVED)
|
||||
if (ts->type != BT_DERIVED && ts->type != BT_CLASS)
|
||||
mio_integer (&ts->kind);
|
||||
else
|
||||
mio_symbol_ref (&ts->u.derived);
|
||||
|
|
@ -3566,7 +3573,10 @@ mio_symbol (gfc_symbol *sym)
|
|||
}
|
||||
|
||||
mio_integer (&(sym->intmod_sym_id));
|
||||
|
||||
|
||||
if (sym->attr.flavor == FL_DERIVED)
|
||||
mio_integer (&(sym->vindex));
|
||||
|
||||
mio_rparen ();
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -312,6 +312,7 @@ decode_statement (void)
|
|||
match (NULL, gfc_match_block, ST_BLOCK);
|
||||
match (NULL, gfc_match_do, ST_DO);
|
||||
match (NULL, gfc_match_select, ST_SELECT_CASE);
|
||||
match (NULL, gfc_match_select_type, ST_SELECT_TYPE);
|
||||
|
||||
/* General statement matching: Instead of testing every possible
|
||||
statement, we eliminate most possibilities by peeking at the
|
||||
|
|
@ -343,6 +344,7 @@ decode_statement (void)
|
|||
match ("case", gfc_match_case, ST_CASE);
|
||||
match ("common", gfc_match_common, ST_COMMON);
|
||||
match ("contains", gfc_match_eos, ST_CONTAINS);
|
||||
match ("class", gfc_match_class_is, ST_CLASS_IS);
|
||||
break;
|
||||
|
||||
case 'd':
|
||||
|
|
@ -432,6 +434,7 @@ decode_statement (void)
|
|||
case 't':
|
||||
match ("target", gfc_match_target, ST_ATTR_DECL);
|
||||
match ("type", gfc_match_derived_decl, ST_DERIVED_DECL);
|
||||
match ("type is", gfc_match_type_is, ST_TYPE_IS);
|
||||
break;
|
||||
|
||||
case 'u':
|
||||
|
|
@ -936,7 +939,8 @@ next_statement (void)
|
|||
|
||||
#define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: \
|
||||
case ST_IF_BLOCK: case ST_BLOCK: \
|
||||
case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_OMP_PARALLEL: \
|
||||
case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_SELECT_TYPE: \
|
||||
case ST_OMP_PARALLEL: \
|
||||
case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \
|
||||
case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \
|
||||
case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \
|
||||
|
|
@ -1360,6 +1364,15 @@ gfc_ascii_statement (gfc_statement st)
|
|||
case ST_SELECT_CASE:
|
||||
p = "SELECT CASE";
|
||||
break;
|
||||
case ST_SELECT_TYPE:
|
||||
p = "SELECT TYPE";
|
||||
break;
|
||||
case ST_TYPE_IS:
|
||||
p = "TYPE IS";
|
||||
break;
|
||||
case ST_CLASS_IS:
|
||||
p = "CLASS IS";
|
||||
break;
|
||||
case ST_SEQUENCE:
|
||||
p = "SEQUENCE";
|
||||
break;
|
||||
|
|
@ -2874,6 +2887,83 @@ parse_select_block (void)
|
|||
}
|
||||
|
||||
|
||||
/* Parse a SELECT TYPE construct (F03:R821). */
|
||||
|
||||
static void
|
||||
parse_select_type_block (void)
|
||||
{
|
||||
gfc_statement st;
|
||||
gfc_code *cp;
|
||||
gfc_state_data s;
|
||||
|
||||
accept_statement (ST_SELECT_TYPE);
|
||||
|
||||
cp = gfc_state_stack->tail;
|
||||
push_state (&s, COMP_SELECT_TYPE, gfc_new_block);
|
||||
|
||||
/* Make sure that the next statement is a TYPE IS, CLASS IS, CLASS DEFAULT
|
||||
or END SELECT. */
|
||||
for (;;)
|
||||
{
|
||||
st = next_statement ();
|
||||
if (st == ST_NONE)
|
||||
unexpected_eof ();
|
||||
if (st == ST_END_SELECT)
|
||||
{
|
||||
/* Empty SELECT CASE is OK. */
|
||||
accept_statement (st);
|
||||
pop_state ();
|
||||
return;
|
||||
}
|
||||
if (st == ST_TYPE_IS || st == ST_CLASS_IS)
|
||||
break;
|
||||
|
||||
gfc_error ("Expected TYPE IS, CLASS IS or END SELECT statement "
|
||||
"following SELECT TYPE at %C");
|
||||
|
||||
reject_statement ();
|
||||
}
|
||||
|
||||
/* At this point, we're got a nonempty select block. */
|
||||
cp = new_level (cp);
|
||||
*cp = new_st;
|
||||
|
||||
accept_statement (st);
|
||||
|
||||
do
|
||||
{
|
||||
st = parse_executable (ST_NONE);
|
||||
switch (st)
|
||||
{
|
||||
case ST_NONE:
|
||||
unexpected_eof ();
|
||||
|
||||
case ST_TYPE_IS:
|
||||
case ST_CLASS_IS:
|
||||
cp = new_level (gfc_state_stack->head);
|
||||
*cp = new_st;
|
||||
gfc_clear_new_st ();
|
||||
|
||||
accept_statement (st);
|
||||
/* Fall through */
|
||||
|
||||
case ST_END_SELECT:
|
||||
break;
|
||||
|
||||
/* Can't have an executable statement because of
|
||||
parse_executable(). */
|
||||
default:
|
||||
unexpected_statement (st);
|
||||
break;
|
||||
}
|
||||
}
|
||||
while (st != ST_END_SELECT);
|
||||
|
||||
pop_state ();
|
||||
accept_statement (st);
|
||||
}
|
||||
|
||||
|
||||
/* Given a symbol, make sure it is not an iteration variable for a DO
|
||||
statement. This subroutine is called when the symbol is seen in a
|
||||
context that causes it to become redefined. If the symbol is an
|
||||
|
|
@ -3395,6 +3485,10 @@ parse_executable (gfc_statement st)
|
|||
parse_select_block ();
|
||||
break;
|
||||
|
||||
case ST_SELECT_TYPE:
|
||||
parse_select_type_block();
|
||||
break;
|
||||
|
||||
case ST_DO:
|
||||
parse_do_block ();
|
||||
if (check_do_closure () == 1)
|
||||
|
|
|
|||
|
|
@ -32,7 +32,7 @@ typedef enum
|
|||
COMP_BLOCK_DATA, COMP_INTERFACE, COMP_DERIVED, COMP_DERIVED_CONTAINS,
|
||||
COMP_BLOCK, COMP_IF,
|
||||
COMP_DO, COMP_SELECT, COMP_FORALL, COMP_WHERE, COMP_CONTAINS, COMP_ENUM,
|
||||
COMP_OMP_STRUCTURED_BLOCK
|
||||
COMP_SELECT_TYPE, COMP_OMP_STRUCTURED_BLOCK
|
||||
}
|
||||
gfc_compile_state;
|
||||
|
||||
|
|
|
|||
|
|
@ -1733,7 +1733,9 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
|
|||
|| (sym->attr.dimension && !sym->attr.proc_pointer
|
||||
&& !gfc_is_proc_ptr_comp (primary, NULL)
|
||||
&& !(gfc_matching_procptr_assignment
|
||||
&& sym->attr.flavor == FL_PROCEDURE)))
|
||||
&& sym->attr.flavor == FL_PROCEDURE))
|
||||
|| (sym->ts.type == BT_CLASS
|
||||
&& sym->ts.u.derived->components->attr.dimension))
|
||||
{
|
||||
/* In EQUIVALENCE, we don't know yet whether we are seeing
|
||||
an array, character variable or array of character
|
||||
|
|
@ -1767,7 +1769,8 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
|
|||
&& gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
|
||||
gfc_set_default_type (sym, 0, sym->ns);
|
||||
|
||||
if (sym->ts.type != BT_DERIVED || gfc_match_char ('%') != MATCH_YES)
|
||||
if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
|
||||
|| gfc_match_char ('%') != MATCH_YES)
|
||||
goto check_substring;
|
||||
|
||||
sym = sym->ts.u.derived;
|
||||
|
|
@ -1865,8 +1868,21 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
|
|||
if (m != MATCH_YES)
|
||||
return m;
|
||||
}
|
||||
else if (component->ts.type == BT_CLASS
|
||||
&& component->ts.u.derived->components->as != NULL
|
||||
&& !component->attr.proc_pointer)
|
||||
{
|
||||
tail = extend_ref (primary, tail);
|
||||
tail->type = REF_ARRAY;
|
||||
|
||||
if (component->ts.type != BT_DERIVED
|
||||
m = gfc_match_array_ref (&tail->u.ar,
|
||||
component->ts.u.derived->components->as,
|
||||
equiv_flag);
|
||||
if (m != MATCH_YES)
|
||||
return m;
|
||||
}
|
||||
|
||||
if ((component->ts.type != BT_DERIVED && component->ts.type != BT_CLASS)
|
||||
|| gfc_match_char ('%') != MATCH_YES)
|
||||
break;
|
||||
|
||||
|
|
@ -1875,7 +1891,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
|
|||
|
||||
check_substring:
|
||||
unknown = false;
|
||||
if (primary->ts.type == BT_UNKNOWN)
|
||||
if (primary->ts.type == BT_UNKNOWN && sym->attr.flavor != FL_DERIVED)
|
||||
{
|
||||
if (gfc_get_default_type (sym->name, sym->ns)->type == BT_CHARACTER)
|
||||
{
|
||||
|
|
@ -1943,23 +1959,35 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
|
|||
int dimension, pointer, allocatable, target;
|
||||
symbol_attribute attr;
|
||||
gfc_ref *ref;
|
||||
gfc_symbol *sym;
|
||||
gfc_component *comp;
|
||||
|
||||
if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION)
|
||||
gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
|
||||
|
||||
ref = expr->ref;
|
||||
attr = expr->symtree->n.sym->attr;
|
||||
sym = expr->symtree->n.sym;
|
||||
attr = sym->attr;
|
||||
|
||||
dimension = attr.dimension;
|
||||
pointer = attr.pointer;
|
||||
allocatable = attr.allocatable;
|
||||
if (sym->ts.type == BT_CLASS)
|
||||
{
|
||||
dimension = sym->ts.u.derived->components->attr.dimension;
|
||||
pointer = sym->ts.u.derived->components->attr.pointer;
|
||||
allocatable = sym->ts.u.derived->components->attr.allocatable;
|
||||
}
|
||||
else
|
||||
{
|
||||
dimension = attr.dimension;
|
||||
pointer = attr.pointer;
|
||||
allocatable = attr.allocatable;
|
||||
}
|
||||
|
||||
target = attr.target;
|
||||
if (pointer || attr.proc_pointer)
|
||||
target = 1;
|
||||
|
||||
if (ts != NULL && expr->ts.type == BT_UNKNOWN)
|
||||
*ts = expr->symtree->n.sym->ts;
|
||||
*ts = sym->ts;
|
||||
|
||||
for (; ref; ref = ref->next)
|
||||
switch (ref->type)
|
||||
|
|
@ -1988,10 +2016,11 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
|
|||
break;
|
||||
|
||||
case REF_COMPONENT:
|
||||
attr = ref->u.c.component->attr;
|
||||
comp = ref->u.c.component;
|
||||
attr = comp->attr;
|
||||
if (ts != NULL)
|
||||
{
|
||||
*ts = ref->u.c.component->ts;
|
||||
*ts = comp->ts;
|
||||
/* Don't set the string length if a substring reference
|
||||
follows. */
|
||||
if (ts->type == BT_CHARACTER
|
||||
|
|
@ -1999,8 +2028,16 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
|
|||
ts->u.cl = NULL;
|
||||
}
|
||||
|
||||
pointer = ref->u.c.component->attr.pointer;
|
||||
allocatable = ref->u.c.component->attr.allocatable;
|
||||
if (comp->ts.type == BT_CLASS)
|
||||
{
|
||||
pointer = comp->ts.u.derived->components->attr.pointer;
|
||||
allocatable = comp->ts.u.derived->components->attr.allocatable;
|
||||
}
|
||||
else
|
||||
{
|
||||
pointer = comp->attr.pointer;
|
||||
allocatable = comp->attr.allocatable;
|
||||
}
|
||||
if (pointer || attr.proc_pointer)
|
||||
target = 1;
|
||||
|
||||
|
|
@ -2037,7 +2074,16 @@ gfc_expr_attr (gfc_expr *e)
|
|||
gfc_clear_attr (&attr);
|
||||
|
||||
if (e->value.function.esym != NULL)
|
||||
attr = e->value.function.esym->result->attr;
|
||||
{
|
||||
gfc_symbol *sym = e->value.function.esym->result;
|
||||
attr = sym->attr;
|
||||
if (sym->ts.type == BT_CLASS)
|
||||
{
|
||||
attr.dimension = sym->ts.u.derived->components->attr.dimension;
|
||||
attr.pointer = sym->ts.u.derived->components->attr.pointer;
|
||||
attr.allocatable = sym->ts.u.derived->components->attr.allocatable;
|
||||
}
|
||||
}
|
||||
else
|
||||
attr = gfc_variable_attr (e, NULL);
|
||||
|
||||
|
|
|
|||
|
|
@ -879,7 +879,10 @@ resolve_structure_cons (gfc_expr *expr)
|
|||
|
||||
if (cons->expr->expr_type == EXPR_NULL
|
||||
&& !(comp->attr.pointer || comp->attr.allocatable
|
||||
|| comp->attr.proc_pointer))
|
||||
|| comp->attr.proc_pointer
|
||||
|| (comp->ts.type == BT_CLASS
|
||||
&& (comp->ts.u.derived->components->attr.pointer
|
||||
|| comp->ts.u.derived->components->attr.allocatable))))
|
||||
{
|
||||
t = FAILURE;
|
||||
gfc_error ("The NULL in the derived type constructor at %L is "
|
||||
|
|
@ -3931,7 +3934,10 @@ find_array_spec (gfc_expr *e)
|
|||
gfc_symbol *derived;
|
||||
gfc_ref *ref;
|
||||
|
||||
as = e->symtree->n.sym->as;
|
||||
if (e->symtree->n.sym->ts.type == BT_CLASS)
|
||||
as = e->symtree->n.sym->ts.u.derived->components->as;
|
||||
else
|
||||
as = e->symtree->n.sym->as;
|
||||
derived = NULL;
|
||||
|
||||
for (ref = e->ref; ref; ref = ref->next)
|
||||
|
|
@ -4844,7 +4850,7 @@ check_typebound_baseobject (gfc_expr* e)
|
|||
if (!base)
|
||||
return FAILURE;
|
||||
|
||||
gcc_assert (base->ts.type == BT_DERIVED);
|
||||
gcc_assert (base->ts.type == BT_DERIVED || base->ts.type == BT_CLASS);
|
||||
if (base->ts.u.derived->attr.abstract)
|
||||
{
|
||||
gfc_error ("Base object for type-bound procedure call at %L is of"
|
||||
|
|
@ -5051,7 +5057,10 @@ static gfc_try
|
|||
resolve_ppc_call (gfc_code* c)
|
||||
{
|
||||
gfc_component *comp;
|
||||
gcc_assert (gfc_is_proc_ptr_comp (c->expr1, &comp));
|
||||
bool b;
|
||||
|
||||
b = gfc_is_proc_ptr_comp (c->expr1, &comp);
|
||||
gcc_assert (b);
|
||||
|
||||
c->resolved_sym = c->expr1->symtree->n.sym;
|
||||
c->expr1->expr_type = EXPR_VARIABLE;
|
||||
|
|
@ -5083,7 +5092,10 @@ static gfc_try
|
|||
resolve_expr_ppc (gfc_expr* e)
|
||||
{
|
||||
gfc_component *comp;
|
||||
gcc_assert (gfc_is_proc_ptr_comp (e, &comp));
|
||||
bool b;
|
||||
|
||||
b = gfc_is_proc_ptr_comp (e, &comp);
|
||||
gcc_assert (b);
|
||||
|
||||
/* Convert to EXPR_FUNCTION. */
|
||||
e->expr_type = EXPR_FUNCTION;
|
||||
|
|
@ -5462,6 +5474,8 @@ resolve_deallocate_expr (gfc_expr *e)
|
|||
symbol_attribute attr;
|
||||
int allocatable, pointer, check_intent_in;
|
||||
gfc_ref *ref;
|
||||
gfc_symbol *sym;
|
||||
gfc_component *c;
|
||||
|
||||
/* Check INTENT(IN), unless the object is a sub-component of a pointer. */
|
||||
check_intent_in = 1;
|
||||
|
|
@ -5472,8 +5486,18 @@ resolve_deallocate_expr (gfc_expr *e)
|
|||
if (e->expr_type != EXPR_VARIABLE)
|
||||
goto bad;
|
||||
|
||||
allocatable = e->symtree->n.sym->attr.allocatable;
|
||||
pointer = e->symtree->n.sym->attr.pointer;
|
||||
sym = e->symtree->n.sym;
|
||||
|
||||
if (sym->ts.type == BT_CLASS)
|
||||
{
|
||||
allocatable = sym->ts.u.derived->components->attr.allocatable;
|
||||
pointer = sym->ts.u.derived->components->attr.pointer;
|
||||
}
|
||||
else
|
||||
{
|
||||
allocatable = sym->attr.allocatable;
|
||||
pointer = sym->attr.pointer;
|
||||
}
|
||||
for (ref = e->ref; ref; ref = ref->next)
|
||||
{
|
||||
if (pointer)
|
||||
|
|
@ -5487,9 +5511,17 @@ resolve_deallocate_expr (gfc_expr *e)
|
|||
break;
|
||||
|
||||
case REF_COMPONENT:
|
||||
allocatable = (ref->u.c.component->as != NULL
|
||||
&& ref->u.c.component->as->type == AS_DEFERRED);
|
||||
pointer = ref->u.c.component->attr.pointer;
|
||||
c = ref->u.c.component;
|
||||
if (c->ts.type == BT_CLASS)
|
||||
{
|
||||
allocatable = c->ts.u.derived->components->attr.allocatable;
|
||||
pointer = c->ts.u.derived->components->attr.pointer;
|
||||
}
|
||||
else
|
||||
{
|
||||
allocatable = c->attr.allocatable;
|
||||
pointer = c->attr.pointer;
|
||||
}
|
||||
break;
|
||||
|
||||
case REF_SUBSTRING:
|
||||
|
|
@ -5507,14 +5539,19 @@ resolve_deallocate_expr (gfc_expr *e)
|
|||
&e->where);
|
||||
}
|
||||
|
||||
if (check_intent_in
|
||||
&& e->symtree->n.sym->attr.intent == INTENT_IN)
|
||||
if (check_intent_in && sym->attr.intent == INTENT_IN)
|
||||
{
|
||||
gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
|
||||
e->symtree->n.sym->name, &e->where);
|
||||
sym->name, &e->where);
|
||||
return FAILURE;
|
||||
}
|
||||
|
||||
if (e->ts.type == BT_CLASS)
|
||||
{
|
||||
/* Only deallocate the DATA component. */
|
||||
gfc_add_component_ref (e, "$data");
|
||||
}
|
||||
|
||||
return SUCCESS;
|
||||
}
|
||||
|
||||
|
|
@ -5541,8 +5578,8 @@ gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
|
|||
derived types with default initializers, and derived types with allocatable
|
||||
components that need nullification.) */
|
||||
|
||||
static gfc_expr *
|
||||
expr_to_initialize (gfc_expr *e)
|
||||
gfc_expr *
|
||||
gfc_expr_to_initialize (gfc_expr *e)
|
||||
{
|
||||
gfc_expr *result;
|
||||
gfc_ref *ref;
|
||||
|
|
@ -5579,9 +5616,9 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
|
|||
gfc_ref *ref, *ref2;
|
||||
gfc_array_ref *ar;
|
||||
gfc_code *init_st;
|
||||
gfc_expr *init_e;
|
||||
gfc_symbol *sym;
|
||||
gfc_alloc *a;
|
||||
gfc_component *c;
|
||||
|
||||
/* Check INTENT(IN), unless the object is a sub-component of a pointer. */
|
||||
check_intent_in = 1;
|
||||
|
|
@ -5593,6 +5630,8 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
|
|||
pointer, the next-to-last reference must be a pointer. */
|
||||
|
||||
ref2 = NULL;
|
||||
if (e->symtree)
|
||||
sym = e->symtree->n.sym;
|
||||
|
||||
if (e->expr_type != EXPR_VARIABLE)
|
||||
{
|
||||
|
|
@ -5603,9 +5642,18 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
|
|||
}
|
||||
else
|
||||
{
|
||||
allocatable = e->symtree->n.sym->attr.allocatable;
|
||||
pointer = e->symtree->n.sym->attr.pointer;
|
||||
dimension = e->symtree->n.sym->attr.dimension;
|
||||
if (sym->ts.type == BT_CLASS)
|
||||
{
|
||||
allocatable = sym->ts.u.derived->components->attr.allocatable;
|
||||
pointer = sym->ts.u.derived->components->attr.pointer;
|
||||
dimension = sym->ts.u.derived->components->attr.dimension;
|
||||
}
|
||||
else
|
||||
{
|
||||
allocatable = sym->attr.allocatable;
|
||||
pointer = sym->attr.pointer;
|
||||
dimension = sym->attr.dimension;
|
||||
}
|
||||
|
||||
for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
|
||||
{
|
||||
|
|
@ -5620,11 +5668,19 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
|
|||
break;
|
||||
|
||||
case REF_COMPONENT:
|
||||
allocatable = (ref->u.c.component->as != NULL
|
||||
&& ref->u.c.component->as->type == AS_DEFERRED);
|
||||
|
||||
pointer = ref->u.c.component->attr.pointer;
|
||||
dimension = ref->u.c.component->attr.dimension;
|
||||
c = ref->u.c.component;
|
||||
if (c->ts.type == BT_CLASS)
|
||||
{
|
||||
allocatable = c->ts.u.derived->components->attr.allocatable;
|
||||
pointer = c->ts.u.derived->components->attr.pointer;
|
||||
dimension = c->ts.u.derived->components->attr.dimension;
|
||||
}
|
||||
else
|
||||
{
|
||||
allocatable = c->attr.allocatable;
|
||||
pointer = c->attr.pointer;
|
||||
dimension = c->attr.dimension;
|
||||
}
|
||||
break;
|
||||
|
||||
case REF_SUBSTRING:
|
||||
|
|
@ -5642,24 +5698,46 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
|
|||
return FAILURE;
|
||||
}
|
||||
|
||||
if (check_intent_in
|
||||
&& e->symtree->n.sym->attr.intent == INTENT_IN)
|
||||
if (check_intent_in && sym->attr.intent == INTENT_IN)
|
||||
{
|
||||
gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
|
||||
e->symtree->n.sym->name, &e->where);
|
||||
sym->name, &e->where);
|
||||
return FAILURE;
|
||||
}
|
||||
|
||||
/* Add default initializer for those derived types that need them. */
|
||||
if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts)))
|
||||
if (e->ts.type == BT_CLASS)
|
||||
{
|
||||
/* Initialize VINDEX for CLASS objects. */
|
||||
init_st = gfc_get_code ();
|
||||
init_st->loc = code->loc;
|
||||
init_st->op = EXEC_INIT_ASSIGN;
|
||||
init_st->expr1 = expr_to_initialize (e);
|
||||
init_st->expr2 = init_e;
|
||||
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)
|
||||
{
|
||||
/* vindex must be determined at run time. */
|
||||
init_st->expr2 = gfc_copy_expr (code->expr3);
|
||||
gfc_add_component_ref (init_st->expr2, "$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 (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);
|
||||
}
|
||||
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");
|
||||
}
|
||||
|
||||
if (pointer || dimension == 0)
|
||||
|
|
@ -5706,7 +5784,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
|
|||
|
||||
check_symbols:
|
||||
|
||||
for (a = code->ext.alloc_list; a; a = a->next)
|
||||
for (a = code->ext.alloc.list; a; a = a->next)
|
||||
{
|
||||
sym = a->expr->symtree->n.sym;
|
||||
|
||||
|
|
@ -5758,7 +5836,7 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn)
|
|||
gfc_error ("Stat-variable at %L must be a scalar INTEGER "
|
||||
"variable", &stat->where);
|
||||
|
||||
for (p = code->ext.alloc_list; p; p = p->next)
|
||||
for (p = code->ext.alloc.list; p; p = p->next)
|
||||
if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
|
||||
gfc_error ("Stat-variable at %L shall not be %sd within "
|
||||
"the same %s statement", &stat->where, fcn, fcn);
|
||||
|
|
@ -5787,7 +5865,7 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn)
|
|||
gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
|
||||
"variable", &errmsg->where);
|
||||
|
||||
for (p = code->ext.alloc_list; p; p = p->next)
|
||||
for (p = code->ext.alloc.list; p; p = p->next)
|
||||
if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
|
||||
gfc_error ("Errmsg-variable at %L shall not be %sd within "
|
||||
"the same %s statement", &errmsg->where, fcn, fcn);
|
||||
|
|
@ -5795,7 +5873,7 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn)
|
|||
|
||||
/* Check that an allocate-object appears only once in the statement.
|
||||
FIXME: Checking derived types is disabled. */
|
||||
for (p = code->ext.alloc_list; p; p = p->next)
|
||||
for (p = code->ext.alloc.list; p; p = p->next)
|
||||
{
|
||||
pe = p->expr;
|
||||
if ((pe->ref && pe->ref->type != REF_COMPONENT)
|
||||
|
|
@ -5815,12 +5893,12 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn)
|
|||
|
||||
if (strcmp (fcn, "ALLOCATE") == 0)
|
||||
{
|
||||
for (a = code->ext.alloc_list; a; a = a->next)
|
||||
for (a = code->ext.alloc.list; a; a = a->next)
|
||||
resolve_allocate_expr (a->expr, code);
|
||||
}
|
||||
else
|
||||
{
|
||||
for (a = code->ext.alloc_list; a; a = a->next)
|
||||
for (a = code->ext.alloc.list; a; a = a->next)
|
||||
resolve_deallocate_expr (a->expr);
|
||||
}
|
||||
}
|
||||
|
|
@ -6346,6 +6424,116 @@ resolve_select (gfc_code *code)
|
|||
}
|
||||
|
||||
|
||||
/* Check if a derived type is extensible. */
|
||||
|
||||
bool
|
||||
gfc_type_is_extensible (gfc_symbol *sym)
|
||||
{
|
||||
return !(sym->attr.is_bind_c || sym->attr.sequence);
|
||||
}
|
||||
|
||||
|
||||
/* Resolve a SELECT TYPE statement. */
|
||||
|
||||
static void
|
||||
resolve_select_type (gfc_code *code)
|
||||
{
|
||||
gfc_symbol *selector_type;
|
||||
gfc_code *body, *new_st;
|
||||
gfc_case *c, *default_case;
|
||||
gfc_symtree *st;
|
||||
char name[GFC_MAX_SYMBOL_LEN];
|
||||
|
||||
selector_type = code->expr1->ts.u.derived->components->ts.u.derived;
|
||||
|
||||
/* Assume there is no DEFAULT case. */
|
||||
default_case = NULL;
|
||||
|
||||
/* Loop over TYPE IS / CLASS IS cases. */
|
||||
for (body = code->block; body; body = body->block)
|
||||
{
|
||||
c = body->ext.case_list;
|
||||
|
||||
/* Check F03:C815. */
|
||||
if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
|
||||
&& !gfc_type_is_extensible (c->ts.u.derived))
|
||||
{
|
||||
gfc_error ("Derived type '%s' at %L must be extensible",
|
||||
c->ts.u.derived->name, &c->where);
|
||||
continue;
|
||||
}
|
||||
|
||||
/* Check F03:C816. */
|
||||
if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
|
||||
&& !gfc_type_is_extension_of (selector_type, c->ts.u.derived))
|
||||
{
|
||||
gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
|
||||
c->ts.u.derived->name, &c->where, selector_type->name);
|
||||
continue;
|
||||
}
|
||||
|
||||
/* Intercept the DEFAULT case. */
|
||||
if (c->ts.type == BT_UNKNOWN)
|
||||
{
|
||||
/* Check F03:C818. */
|
||||
if (default_case != NULL)
|
||||
gfc_error ("The DEFAULT CASE at %L cannot be followed "
|
||||
"by a second DEFAULT CASE at %L",
|
||||
&default_case->where, &c->where);
|
||||
else
|
||||
default_case = c;
|
||||
continue;
|
||||
}
|
||||
}
|
||||
|
||||
/* Transform to EXEC_SELECT. */
|
||||
code->op = EXEC_SELECT;
|
||||
gfc_add_component_ref (code->expr1, "$vindex");
|
||||
|
||||
/* Loop over TYPE IS / CLASS IS cases. */
|
||||
for (body = code->block; body; body = body->block)
|
||||
{
|
||||
c = body->ext.case_list;
|
||||
if (c->ts.type == BT_DERIVED)
|
||||
c->low = c->high = gfc_int_expr (c->ts.u.derived->vindex);
|
||||
else if (c->ts.type == BT_CLASS)
|
||||
/* Currently IS CLASS blocks are simply ignored.
|
||||
TODO: Implement IS CLASS. */
|
||||
c->unreachable = 1;
|
||||
|
||||
if (c->ts.type != BT_DERIVED)
|
||||
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);
|
||||
new_st = gfc_get_code ();
|
||||
new_st->op = EXEC_POINTER_ASSIGN;
|
||||
new_st->expr1 = gfc_get_variable_expr (st);
|
||||
new_st->expr2 = gfc_get_variable_expr (code->expr1->symtree);
|
||||
gfc_add_component_ref (new_st->expr2, "$data");
|
||||
new_st->next = body->next;
|
||||
body->next = new_st;
|
||||
}
|
||||
|
||||
/* Eliminate dead blocks. */
|
||||
for (body = code; body && body->block; body = body->block)
|
||||
{
|
||||
if (body->block->ext.case_list->unreachable)
|
||||
{
|
||||
/* Cut the unreachable block from the code chain. */
|
||||
gfc_code *cd = body->block;
|
||||
body->block = cd->block;
|
||||
/* Kill the dead block, but not the blocks below it. */
|
||||
cd->block = NULL;
|
||||
gfc_free_statements (cd);
|
||||
}
|
||||
}
|
||||
|
||||
resolve_select (code);
|
||||
|
||||
}
|
||||
|
||||
|
||||
/* Resolve a transfer statement. This is making sure that:
|
||||
-- a derived type being transferred has only non-pointer components
|
||||
-- a derived type being transferred doesn't have private components, unless
|
||||
|
|
@ -6911,6 +7099,7 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
|
|||
break;
|
||||
|
||||
case EXEC_SELECT:
|
||||
case EXEC_SELECT_TYPE:
|
||||
case EXEC_FORALL:
|
||||
case EXEC_DO:
|
||||
case EXEC_DO_WHILE:
|
||||
|
|
@ -7102,6 +7291,40 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
|
|||
}
|
||||
|
||||
|
||||
/* 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 ();
|
||||
|
||||
/* 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 ();
|
||||
|
||||
/* Modify the actual pointer assignment. */
|
||||
gfc_add_component_ref (code->expr1, "$data");
|
||||
if (code->expr2->ts.type == BT_CLASS)
|
||||
gfc_add_component_ref (code->expr2, "$data");
|
||||
}
|
||||
|
||||
|
||||
/* Given a block of code, recursively resolve everything pointed to by this
|
||||
code block. */
|
||||
|
||||
|
|
@ -7224,6 +7447,9 @@ 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)
|
||||
|
|
@ -7252,7 +7478,11 @@ 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:
|
||||
|
|
@ -7295,6 +7525,10 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
|
|||
resolve_select (code);
|
||||
break;
|
||||
|
||||
case EXEC_SELECT_TYPE:
|
||||
resolve_select_type (code);
|
||||
break;
|
||||
|
||||
case EXEC_BLOCK:
|
||||
gfc_resolve (code->ext.ns);
|
||||
break;
|
||||
|
|
@ -8023,8 +8257,8 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
|
|||
}
|
||||
else
|
||||
{
|
||||
if (!mp_flag && !sym->attr.allocatable
|
||||
&& !sym->attr.pointer && !sym->attr.dummy)
|
||||
if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
|
||||
&& !sym->attr.dummy && sym->ts.type != BT_CLASS)
|
||||
{
|
||||
gfc_error ("Array '%s' at %L cannot have a deferred shape",
|
||||
sym->name, &sym->declared_at);
|
||||
|
|
@ -8035,22 +8269,13 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
|
|||
}
|
||||
|
||||
|
||||
/* Check if a derived type is extensible. */
|
||||
|
||||
static bool
|
||||
type_is_extensible (gfc_symbol *sym)
|
||||
{
|
||||
return !(sym->attr.is_bind_c || sym->attr.sequence);
|
||||
}
|
||||
|
||||
|
||||
/* Additional checks for symbols with flavor variable and derived
|
||||
type. To be called from resolve_fl_variable. */
|
||||
|
||||
static gfc_try
|
||||
resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
|
||||
{
|
||||
gcc_assert (sym->ts.type == BT_DERIVED);
|
||||
gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS);
|
||||
|
||||
/* Check to see if a derived type is blocked from being host
|
||||
associated by the presence of another class I symbol in the same
|
||||
|
|
@ -8092,10 +8317,10 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
|
|||
return FAILURE;
|
||||
}
|
||||
|
||||
if (sym->ts.is_class)
|
||||
if (sym->ts.type == BT_CLASS)
|
||||
{
|
||||
/* C502. */
|
||||
if (!type_is_extensible (sym->ts.u.derived))
|
||||
if (!gfc_type_is_extensible (sym->ts.u.derived->components->ts.u.derived))
|
||||
{
|
||||
gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
|
||||
sym->ts.u.derived->name, sym->name, &sym->declared_at);
|
||||
|
|
@ -8103,7 +8328,9 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
|
|||
}
|
||||
|
||||
/* C509. */
|
||||
if (!(sym->attr.dummy || sym->attr.allocatable || sym->attr.pointer))
|
||||
if (!(sym->attr.dummy || sym->attr.allocatable || sym->attr.pointer
|
||||
|| sym->ts.u.derived->components->attr.allocatable
|
||||
|| sym->ts.u.derived->components->attr.pointer))
|
||||
{
|
||||
gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
|
||||
"or pointer", sym->name, &sym->declared_at);
|
||||
|
|
@ -8244,7 +8471,7 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag)
|
|||
}
|
||||
|
||||
no_init_error:
|
||||
if (sym->ts.type == BT_DERIVED)
|
||||
if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
|
||||
return resolve_fl_variable_derived (sym, no_init_flag);
|
||||
|
||||
return SUCCESS;
|
||||
|
|
@ -8890,6 +9117,9 @@ check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
|
|||
sym1 = t1->specific->u.specific->n.sym;
|
||||
sym2 = t2->specific->u.specific->n.sym;
|
||||
|
||||
if (sym1 == sym2)
|
||||
return SUCCESS;
|
||||
|
||||
/* Both must be SUBROUTINEs or both must be FUNCTIONs. */
|
||||
if (sym1->attr.subroutine != sym2->attr.subroutine
|
||||
|| sym1->attr.function != sym2->attr.function)
|
||||
|
|
@ -9283,8 +9513,15 @@ resolve_typebound_procedure (gfc_symtree* stree)
|
|||
|
||||
/* Now check that the argument-type matches. */
|
||||
gcc_assert (me_arg);
|
||||
if (me_arg->ts.type != BT_DERIVED
|
||||
|| me_arg->ts.u.derived != resolve_bindings_derived)
|
||||
if (me_arg->ts.type != BT_CLASS)
|
||||
{
|
||||
gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
|
||||
" at %L", proc->name, &where);
|
||||
goto error;
|
||||
}
|
||||
|
||||
if (me_arg->ts.u.derived->components->ts.u.derived
|
||||
!= resolve_bindings_derived)
|
||||
{
|
||||
gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
|
||||
" the derived-type '%s'", me_arg->name, proc->name,
|
||||
|
|
@ -9292,12 +9529,6 @@ resolve_typebound_procedure (gfc_symtree* stree)
|
|||
goto error;
|
||||
}
|
||||
|
||||
if (!me_arg->ts.is_class)
|
||||
{
|
||||
gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
|
||||
" at %L", proc->name, &where);
|
||||
goto error;
|
||||
}
|
||||
}
|
||||
|
||||
/* If we are extending some type, check that we don't override a procedure
|
||||
|
|
@ -9475,7 +9706,7 @@ resolve_fl_derived (gfc_symbol *sym)
|
|||
return FAILURE;
|
||||
|
||||
/* An ABSTRACT type must be extensible. */
|
||||
if (sym->attr.abstract && !type_is_extensible (sym))
|
||||
if (sym->attr.abstract && !gfc_type_is_extensible (sym))
|
||||
{
|
||||
gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
|
||||
sym->name, &sym->declared_at);
|
||||
|
|
@ -9611,8 +9842,10 @@ resolve_fl_derived (gfc_symbol *sym)
|
|||
|
||||
/* Now check that the argument-type matches. */
|
||||
gcc_assert (me_arg);
|
||||
if (me_arg->ts.type != BT_DERIVED
|
||||
|| me_arg->ts.u.derived != sym)
|
||||
if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
|
||||
|| (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
|
||||
|| (me_arg->ts.type == BT_CLASS
|
||||
&& me_arg->ts.u.derived->components->ts.u.derived != sym))
|
||||
{
|
||||
gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
|
||||
" the derived type '%s'", me_arg->name, c->name,
|
||||
|
|
@ -9649,9 +9882,9 @@ resolve_fl_derived (gfc_symbol *sym)
|
|||
return FAILURE;
|
||||
}
|
||||
|
||||
if (type_is_extensible (sym) && !me_arg->ts.is_class)
|
||||
if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
|
||||
gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
|
||||
" at %L", c->name, &c->loc);
|
||||
" at %L", c->name, &c->loc);
|
||||
|
||||
}
|
||||
|
||||
|
|
@ -9720,8 +9953,9 @@ resolve_fl_derived (gfc_symbol *sym)
|
|||
}
|
||||
|
||||
/* C437. */
|
||||
if (c->ts.type == BT_DERIVED && c->ts.is_class
|
||||
&& !(c->attr.pointer || c->attr.allocatable))
|
||||
if (c->ts.type == BT_CLASS
|
||||
&& !(c->ts.u.derived->components->attr.pointer
|
||||
|| c->ts.u.derived->components->attr.allocatable))
|
||||
{
|
||||
gfc_error ("Component '%s' with CLASS at %L must be allocatable "
|
||||
"or pointer", c->name, &c->loc);
|
||||
|
|
|
|||
|
|
@ -122,6 +122,7 @@ gfc_free_statement (gfc_code *p)
|
|||
break;
|
||||
|
||||
case EXEC_SELECT:
|
||||
case EXEC_SELECT_TYPE:
|
||||
if (p->ext.case_list)
|
||||
gfc_free_case_list (p->ext.case_list);
|
||||
break;
|
||||
|
|
@ -132,7 +133,7 @@ gfc_free_statement (gfc_code *p)
|
|||
|
||||
case EXEC_ALLOCATE:
|
||||
case EXEC_DEALLOCATE:
|
||||
gfc_free_alloc_list (p->ext.alloc_list);
|
||||
gfc_free_alloc_list (p->ext.alloc.list);
|
||||
break;
|
||||
|
||||
case EXEC_OPEN:
|
||||
|
|
|
|||
|
|
@ -2644,6 +2644,13 @@ gfc_get_ha_sym_tree (const char *name, gfc_symtree **result)
|
|||
int i;
|
||||
|
||||
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);
|
||||
|
|
@ -4534,6 +4541,34 @@ gfc_get_derived_super_type (gfc_symbol* derived)
|
|||
}
|
||||
|
||||
|
||||
/* Get the ultimate super-type of a given derived type. */
|
||||
|
||||
gfc_symbol*
|
||||
gfc_get_ultimate_derived_super_type (gfc_symbol* derived)
|
||||
{
|
||||
if (!derived->attr.extension)
|
||||
return NULL;
|
||||
|
||||
derived = gfc_get_derived_super_type (derived);
|
||||
|
||||
if (derived->attr.extension)
|
||||
return gfc_get_ultimate_derived_super_type (derived);
|
||||
else
|
||||
return derived;
|
||||
}
|
||||
|
||||
|
||||
/* Check if a derived type t2 is an extension of (or equal to) a type t1. */
|
||||
|
||||
bool
|
||||
gfc_type_is_extension_of (gfc_symbol *t1, gfc_symbol *t2)
|
||||
{
|
||||
while (!gfc_compare_derived_types (t1, t2) && t2->attr.extension)
|
||||
t2 = gfc_get_derived_super_type (t2);
|
||||
return gfc_compare_derived_types (t1, t2);
|
||||
}
|
||||
|
||||
|
||||
/* Check if two typespecs are type compatible (F03:5.1.1.2):
|
||||
If ts1 is nonpolymorphic, ts2 must be the same type.
|
||||
If ts1 is polymorphic (CLASS), ts2 must be an extension of ts1. */
|
||||
|
|
@ -4541,19 +4576,16 @@ gfc_get_derived_super_type (gfc_symbol* derived)
|
|||
bool
|
||||
gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2)
|
||||
{
|
||||
if (ts1->type == BT_DERIVED && ts2->type == BT_DERIVED)
|
||||
if ((ts1->type == BT_DERIVED || ts1->type == BT_CLASS)
|
||||
&& (ts2->type == BT_DERIVED || ts2->type == BT_CLASS))
|
||||
{
|
||||
gfc_symbol *t0, *t;
|
||||
if (ts1->is_class)
|
||||
{
|
||||
t0 = ts1->u.derived;
|
||||
t = ts2->u.derived;
|
||||
while (t0 != t && t->attr.extension)
|
||||
t = gfc_get_derived_super_type (t);
|
||||
return (t0 == t);
|
||||
}
|
||||
if (ts1->type == BT_CLASS)
|
||||
return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
|
||||
ts2->u.derived);
|
||||
else if (ts2->type != BT_CLASS)
|
||||
return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived);
|
||||
else
|
||||
return (ts1->u.derived == ts2->u.derived);
|
||||
return 0;
|
||||
}
|
||||
else
|
||||
return (ts1->type == ts2->type);
|
||||
|
|
|
|||
|
|
@ -5873,7 +5873,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
|
|||
gfc_add_expr_to_block (&fnblock, tmp);
|
||||
}
|
||||
|
||||
if (c->attr.allocatable)
|
||||
if (c->attr.allocatable && c->attr.dimension)
|
||||
{
|
||||
comp = fold_build3 (COMPONENT_REF, ctype,
|
||||
decl, cdecl, NULL_TREE);
|
||||
|
|
@ -5885,7 +5885,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
|
|||
case NULLIFY_ALLOC_COMP:
|
||||
if (c->attr.pointer)
|
||||
continue;
|
||||
else if (c->attr.allocatable)
|
||||
else if (c->attr.allocatable && c->attr.dimension)
|
||||
{
|
||||
comp = fold_build3 (COMPONENT_REF, ctype,
|
||||
decl, cdecl, NULL_TREE);
|
||||
|
|
@ -6072,7 +6072,8 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body)
|
|||
gfc_add_expr_to_block (&fnblock, tmp);
|
||||
}
|
||||
|
||||
if (sym->attr.allocatable && !sym->attr.save && !sym->attr.result)
|
||||
if (sym->attr.allocatable && sym->attr.dimension
|
||||
&& !sym->attr.save && !sym->attr.result)
|
||||
{
|
||||
tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
|
||||
gfc_add_expr_to_block (&fnblock, tmp);
|
||||
|
|
|
|||
|
|
@ -482,7 +482,8 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
|
|||
se->string_length = tmp;
|
||||
}
|
||||
|
||||
if ((c->attr.pointer && c->attr.dimension == 0 && c->ts.type != BT_CHARACTER)
|
||||
if (((c->attr.pointer || c->attr.allocatable) && c->attr.dimension == 0
|
||||
&& c->ts.type != BT_CHARACTER)
|
||||
|| c->attr.proc_pointer)
|
||||
se->expr = build_fold_indirect_ref_loc (input_location,
|
||||
se->expr);
|
||||
|
|
@ -510,8 +511,12 @@ conv_parent_component_references (gfc_se * se, gfc_ref * ref)
|
|||
|
||||
if (dt->attr.extension && dt->components)
|
||||
{
|
||||
if (dt->attr.is_class)
|
||||
cmp = dt->components;
|
||||
else
|
||||
cmp = dt->components->next;
|
||||
/* Return if the component is not in the parent type. */
|
||||
for (cmp = dt->components->next; cmp; cmp = cmp->next)
|
||||
for (; cmp; cmp = cmp->next)
|
||||
if (strcmp (c->name, cmp->name) == 0)
|
||||
return;
|
||||
|
||||
|
|
@ -2641,6 +2646,49 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
|
|||
parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
|
||||
}
|
||||
}
|
||||
else if (fsym && fsym->ts.type == BT_CLASS
|
||||
&& e->ts.type == BT_DERIVED)
|
||||
{
|
||||
tree data;
|
||||
tree vindex;
|
||||
|
||||
/* The derived type needs to be converted to a temporary
|
||||
CLASS object. */
|
||||
gfc_init_se (&parmse, se);
|
||||
type = gfc_typenode_for_spec (&fsym->ts);
|
||||
var = gfc_create_var (type, "class");
|
||||
|
||||
/* Get the components. */
|
||||
tmp = fsym->ts.u.derived->components->backend_decl;
|
||||
data = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
|
||||
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);
|
||||
|
||||
/* Set the vindex. */
|
||||
tmp = build_int_cst (TREE_TYPE (vindex),
|
||||
e->ts.u.derived->vindex);
|
||||
gfc_add_modify (&parmse.pre, vindex, tmp);
|
||||
|
||||
/* Now set the data field. */
|
||||
argss = gfc_walk_expr (e);
|
||||
if (argss == gfc_ss_terminator)
|
||||
{
|
||||
gfc_conv_expr_reference (&parmse, e);
|
||||
tmp = fold_convert (TREE_TYPE (data),
|
||||
parmse.expr);
|
||||
gfc_add_modify (&parmse.pre, data, tmp);
|
||||
}
|
||||
else
|
||||
{
|
||||
gfc_conv_expr (&parmse, e);
|
||||
gfc_add_modify (&parmse.pre, data, parmse.expr);
|
||||
}
|
||||
|
||||
/* Pass the address of the class object. */
|
||||
parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
|
||||
}
|
||||
else if (se->ss && se->ss->useflags)
|
||||
{
|
||||
/* An elemental function inside a scalarized loop. */
|
||||
|
|
@ -3607,6 +3655,7 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
|
|||
switch (ts->type)
|
||||
{
|
||||
case BT_DERIVED:
|
||||
case BT_CLASS:
|
||||
gfc_init_se (&se, NULL);
|
||||
gfc_conv_structure (&se, expr, 1);
|
||||
return se.expr;
|
||||
|
|
@ -3771,6 +3820,13 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
|
|||
gfc_add_block_to_block (&block, &se.post);
|
||||
}
|
||||
}
|
||||
else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
|
||||
{
|
||||
/* NULL initialization for CLASS components. */
|
||||
tmp = gfc_trans_structure_assign (dest,
|
||||
gfc_default_initializer (&cm->ts));
|
||||
gfc_add_expr_to_block (&block, tmp);
|
||||
}
|
||||
else if (cm->attr.dimension)
|
||||
{
|
||||
if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
|
||||
|
|
@ -3966,12 +4022,26 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
|
|||
if (!c->expr || cm->attr.allocatable)
|
||||
continue;
|
||||
|
||||
val = gfc_conv_initializer (c->expr, &cm->ts,
|
||||
TREE_TYPE (cm->backend_decl), cm->attr.dimension,
|
||||
cm->attr.pointer || cm->attr.proc_pointer);
|
||||
if (cm->ts.type == BT_CLASS)
|
||||
{
|
||||
val = gfc_conv_initializer (c->expr, &cm->ts,
|
||||
TREE_TYPE (cm->ts.u.derived->components->backend_decl),
|
||||
cm->ts.u.derived->components->attr.dimension,
|
||||
cm->ts.u.derived->components->attr.pointer);
|
||||
|
||||
/* Append it to the constructor list. */
|
||||
CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
|
||||
/* Append it to the constructor list. */
|
||||
CONSTRUCTOR_APPEND_ELT (v, cm->ts.u.derived->components->backend_decl,
|
||||
val);
|
||||
}
|
||||
else
|
||||
{
|
||||
val = gfc_conv_initializer (c->expr, &cm->ts,
|
||||
TREE_TYPE (cm->backend_decl), cm->attr.dimension,
|
||||
cm->attr.pointer || cm->attr.proc_pointer);
|
||||
|
||||
/* Append it to the constructor list. */
|
||||
CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
|
||||
}
|
||||
}
|
||||
se->expr = build_constructor (type, v);
|
||||
if (init)
|
||||
|
|
|
|||
|
|
@ -4700,6 +4700,56 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
|
|||
}
|
||||
|
||||
|
||||
/* Generate code for the SAME_TYPE_AS intrinsic.
|
||||
Generate inline code that directly checks the vindices. */
|
||||
|
||||
static void
|
||||
gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr)
|
||||
{
|
||||
gfc_expr *a, *b;
|
||||
gfc_se se1, se2;
|
||||
tree tmp;
|
||||
|
||||
gfc_init_se (&se1, NULL);
|
||||
gfc_init_se (&se2, NULL);
|
||||
|
||||
a = expr->value.function.actual->expr;
|
||||
b = expr->value.function.actual->next->expr;
|
||||
|
||||
if (a->ts.type == BT_CLASS)
|
||||
gfc_add_component_ref (a, "$vindex");
|
||||
else if (a->ts.type == BT_DERIVED)
|
||||
a = gfc_int_expr (a->ts.u.derived->vindex);
|
||||
|
||||
if (b->ts.type == BT_CLASS)
|
||||
gfc_add_component_ref (b, "$vindex");
|
||||
else if (b->ts.type == BT_DERIVED)
|
||||
b = gfc_int_expr (b->ts.u.derived->vindex);
|
||||
|
||||
gfc_conv_expr (&se1, a);
|
||||
gfc_conv_expr (&se2, b);
|
||||
|
||||
tmp = fold_build2 (EQ_EXPR, boolean_type_node,
|
||||
se1.expr, fold_convert (TREE_TYPE (se1.expr), se2.expr));
|
||||
se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
|
||||
}
|
||||
|
||||
|
||||
/* Generate code for the EXTENDS_TYPE_OF intrinsic. */
|
||||
|
||||
static void
|
||||
gfc_conv_extends_type_of (gfc_se *se, gfc_expr *expr)
|
||||
{
|
||||
gfc_expr *e;
|
||||
/* TODO: Implement EXTENDS_TYPE_OF. */
|
||||
gfc_error ("Intrinsic EXTENDS_TYPE_OF at %L not yet implemented",
|
||||
&expr->where);
|
||||
/* Just return 'false' for now. */
|
||||
e = gfc_logical_expr (false, &expr->where);
|
||||
gfc_conv_expr (se, e);
|
||||
}
|
||||
|
||||
|
||||
/* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
|
||||
|
||||
static void
|
||||
|
|
@ -5108,6 +5158,14 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
|
|||
gfc_conv_associated(se, expr);
|
||||
break;
|
||||
|
||||
case GFC_ISYM_SAME_TYPE_AS:
|
||||
gfc_conv_same_type_as (se, expr);
|
||||
break;
|
||||
|
||||
case GFC_ISYM_EXTENDS_TYPE_OF:
|
||||
gfc_conv_extends_type_of (se, expr);
|
||||
break;
|
||||
|
||||
case GFC_ISYM_ABS:
|
||||
gfc_conv_intrinsic_abs (se, expr);
|
||||
break;
|
||||
|
|
|
|||
|
|
@ -3992,7 +3992,7 @@ tree
|
|||
gfc_trans_allocate (gfc_code * code)
|
||||
{
|
||||
gfc_alloc *al;
|
||||
gfc_expr *expr;
|
||||
gfc_expr *expr, *init_e, *rhs;
|
||||
gfc_se se;
|
||||
tree tmp;
|
||||
tree parm;
|
||||
|
|
@ -4001,7 +4001,7 @@ gfc_trans_allocate (gfc_code * code)
|
|||
tree error_label;
|
||||
stmtblock_t block;
|
||||
|
||||
if (!code->ext.alloc_list)
|
||||
if (!code->ext.alloc.list)
|
||||
return NULL_TREE;
|
||||
|
||||
pstat = stat = error_label = tmp = NULL_TREE;
|
||||
|
|
@ -4020,7 +4020,7 @@ gfc_trans_allocate (gfc_code * code)
|
|||
TREE_USED (error_label) = 1;
|
||||
}
|
||||
|
||||
for (al = code->ext.alloc_list; al != NULL; al = al->next)
|
||||
for (al = code->ext.alloc.list; al != NULL; al = al->next)
|
||||
{
|
||||
expr = al->expr;
|
||||
|
||||
|
|
@ -4034,7 +4034,24 @@ gfc_trans_allocate (gfc_code * code)
|
|||
if (!gfc_array_allocate (&se, expr, pstat))
|
||||
{
|
||||
/* A scalar or derived type. */
|
||||
tmp = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr)));
|
||||
|
||||
/* 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));
|
||||
}
|
||||
else if (code->expr3 && code->expr3->ts.type != BT_CLASS)
|
||||
tmp = 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));
|
||||
else
|
||||
tmp = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr)));
|
||||
|
||||
if (expr->ts.type == BT_CHARACTER && tmp == NULL_TREE)
|
||||
tmp = se.string_length;
|
||||
|
|
@ -4065,6 +4082,23 @@ gfc_trans_allocate (gfc_code * code)
|
|||
|
||||
tmp = gfc_finish_block (&se.pre);
|
||||
gfc_add_expr_to_block (&block, tmp);
|
||||
|
||||
/* 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_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)))
|
||||
{
|
||||
tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr), init_e, true);
|
||||
gfc_add_expr_to_block (&block, tmp);
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
/* STAT block. */
|
||||
|
|
@ -4111,44 +4145,6 @@ gfc_trans_allocate (gfc_code * code)
|
|||
gfc_add_expr_to_block (&block, tmp);
|
||||
}
|
||||
|
||||
/* SOURCE block. Note, by C631, we know that code->ext.alloc_list
|
||||
has a single entity. */
|
||||
if (code->expr3)
|
||||
{
|
||||
gfc_ref *ref;
|
||||
gfc_array_ref *ar;
|
||||
int n;
|
||||
|
||||
/* If there is a terminating array reference, this is converted
|
||||
to a full array, so that gfc_trans_assignment can scalarize the
|
||||
expression for the source. */
|
||||
for (ref = code->ext.alloc_list->expr->ref; ref; ref = ref->next)
|
||||
{
|
||||
if (ref->next == NULL)
|
||||
{
|
||||
if (ref->type != REF_ARRAY)
|
||||
break;
|
||||
|
||||
ref->u.ar.type = AR_FULL;
|
||||
ar = &ref->u.ar;
|
||||
ar->dimen = ar->as->rank;
|
||||
for (n = 0; n < ar->dimen; n++)
|
||||
{
|
||||
ar->dimen_type[n] = DIMEN_RANGE;
|
||||
gfc_free_expr (ar->start[n]);
|
||||
gfc_free_expr (ar->end[n]);
|
||||
gfc_free_expr (ar->stride[n]);
|
||||
ar->start[n] = NULL;
|
||||
ar->end[n] = NULL;
|
||||
ar->stride[n] = NULL;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
tmp = gfc_trans_assignment (code->ext.alloc_list->expr, code->expr3, false);
|
||||
gfc_add_expr_to_block (&block, tmp);
|
||||
}
|
||||
|
||||
return gfc_finish_block (&block);
|
||||
}
|
||||
|
||||
|
|
@ -4186,7 +4182,7 @@ gfc_trans_deallocate (gfc_code *code)
|
|||
gfc_add_modify (&block, astat, build_int_cst (TREE_TYPE (astat), 0));
|
||||
}
|
||||
|
||||
for (al = code->ext.alloc_list; al != NULL; al = al->next)
|
||||
for (al = code->ext.alloc.list; al != NULL; al = al->next)
|
||||
{
|
||||
expr = al->expr;
|
||||
gcc_assert (expr->expr_type == EXPR_VARIABLE);
|
||||
|
|
|
|||
|
|
@ -1029,6 +1029,7 @@ gfc_typenode_for_spec (gfc_typespec * spec)
|
|||
break;
|
||||
|
||||
case BT_DERIVED:
|
||||
case BT_CLASS:
|
||||
basetype = gfc_get_derived_type (spec->u.derived);
|
||||
|
||||
/* If we're dealing with either C_PTR or C_FUNPTR, we modified the
|
||||
|
|
@ -2063,7 +2064,7 @@ gfc_get_derived_type (gfc_symbol * derived)
|
|||
will be built and so we can return the type. */
|
||||
for (c = derived->components; c; c = c->next)
|
||||
{
|
||||
if (c->ts.type != BT_DERIVED)
|
||||
if (c->ts.type != BT_DERIVED && c->ts.type != BT_CLASS)
|
||||
continue;
|
||||
|
||||
if ((!c->attr.pointer && !c->attr.proc_pointer)
|
||||
|
|
@ -2098,7 +2099,7 @@ gfc_get_derived_type (gfc_symbol * derived)
|
|||
{
|
||||
if (c->attr.proc_pointer)
|
||||
field_type = gfc_get_ppc_type (c);
|
||||
else if (c->ts.type == BT_DERIVED)
|
||||
else if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
|
||||
field_type = c->ts.u.derived->backend_decl;
|
||||
else
|
||||
{
|
||||
|
|
@ -2134,7 +2135,8 @@ gfc_get_derived_type (gfc_symbol * derived)
|
|||
PACKED_STATIC,
|
||||
!c->attr.target);
|
||||
}
|
||||
else if (c->attr.pointer && !c->attr.proc_pointer)
|
||||
else if ((c->attr.pointer || c->attr.allocatable)
|
||||
&& !c->attr.proc_pointer)
|
||||
field_type = build_pointer_type (field_type);
|
||||
|
||||
field = gfc_add_field_to_struct (&fieldlist, typenode,
|
||||
|
|
|
|||
|
|
@ -1173,6 +1173,13 @@ gfc_trans_code (gfc_code * code)
|
|||
res = gfc_trans_select (code);
|
||||
break;
|
||||
|
||||
case EXEC_SELECT_TYPE:
|
||||
/* Do nothing. SELECT TYPE statements should be transformed into
|
||||
an ordinary SELECT CASE at resolution stage.
|
||||
TODO: Add an error message here once this is done. */
|
||||
res = NULL_TREE;
|
||||
break;
|
||||
|
||||
case EXEC_FLUSH:
|
||||
res = gfc_trans_flush (code);
|
||||
break;
|
||||
|
|
|
|||
|
|
@ -1,3 +1,53 @@
|
|||
2009-09-30 Janus Weil <janus@gcc.gnu.org>
|
||||
|
||||
* gfortran.dg/same_type_as_1.f03: New test.
|
||||
* gfortran.dg/same_type_as_2.f03: Ditto.
|
||||
|
||||
2009-09-30 Janus Weil <janus@gcc.gnu.org>
|
||||
|
||||
* gfortran.dg/select_type_1.f03: Extended.
|
||||
* gfortran.dg/select_type_3.f03: New test.
|
||||
|
||||
2009-09-30 Janus Weil <janus@gcc.gnu.org>
|
||||
|
||||
* gfortran.dg/class_allocate_1.f03: New test.
|
||||
|
||||
2009-09-30 Janus Weil <janus@gcc.gnu.org>
|
||||
|
||||
PR fortran/40996
|
||||
* gfortran.dg/allocatable_scalar_3.f90: New test.
|
||||
* gfortran.dg/select_type_2.f03: Ditto.
|
||||
* gfortran.dg/typebound_proc_5.f03: Changed error messages.
|
||||
|
||||
2009-09-30 Janus Weil <janus@gcc.gnu.org>
|
||||
|
||||
* gfortran.dg/block_name_2.f90: Modified error message.
|
||||
* gfortran.dg/select_6.f90: Ditto.
|
||||
* gfortran.dg/select_type_1.f03: New test.
|
||||
|
||||
2009-09-30 Janus Weil <janus@gcc.gnu.org>
|
||||
|
||||
* gfortran.dg/allocate_derived_1.f90: Remove -w option.
|
||||
* gfortran.dg/class_1.f03: Ditto.
|
||||
* gfortran.dg/class_2.f03: Ditto.
|
||||
* gfortran.dg/proc_ptr_comp_pass_1.f90: Ditto.
|
||||
* gfortran.dg/proc_ptr_comp_pass_2.f90: Ditto.
|
||||
* gfortran.dg/proc_ptr_comp_pass_3.f90: Ditto.
|
||||
* gfortran.dg/typebound_call_10.f03: Ditto.
|
||||
* gfortran.dg/typebound_call_2.f03: Ditto.
|
||||
* gfortran.dg/typebound_call_3.f03: Ditto.
|
||||
* gfortran.dg/typebound_call_4.f03: Ditto.
|
||||
* gfortran.dg/typebound_call_9.f03: Ditto.
|
||||
* gfortran.dg/typebound_generic_3.f03: Ditto.
|
||||
* gfortran.dg/typebound_generic_4.f03: Ditto.
|
||||
* gfortran.dg/typebound_operator_1.f03: Ditto.
|
||||
* gfortran.dg/typebound_operator_2.f03: Ditto.
|
||||
* gfortran.dg/typebound_operator_3.f03: Ditto.
|
||||
* gfortran.dg/typebound_operator_4.f03: Ditto.
|
||||
* gfortran.dg/typebound_proc_1.f08: Ditto.
|
||||
* gfortran.dg/typebound_proc_5.f03: Ditto.
|
||||
* gfortran.dg/typebound_proc_6.f03: Ditto.
|
||||
|
||||
2009-09-30 Jason Merrill <jason@redhat.com>
|
||||
|
||||
* g++.dg/eh/init-temp1.C: Improve test.
|
||||
|
|
|
|||
25
gcc/testsuite/gfortran.dg/allocatable_scalar_3.f90
Normal file
25
gcc/testsuite/gfortran.dg/allocatable_scalar_3.f90
Normal file
|
|
@ -0,0 +1,25 @@
|
|||
! { dg-do run }
|
||||
!
|
||||
! PR 40996: [F03] ALLOCATABLE scalars
|
||||
!
|
||||
! Contributed by Janus Weil <janus@gcc.gnu.org>
|
||||
|
||||
implicit none
|
||||
|
||||
type :: t
|
||||
integer, allocatable :: i
|
||||
end type
|
||||
|
||||
type(t)::x
|
||||
|
||||
allocate(x%i)
|
||||
|
||||
x%i = 13
|
||||
print *,x%i
|
||||
if (.not. allocated(x%i)) call abort()
|
||||
|
||||
deallocate(x%i)
|
||||
|
||||
if (allocated(x%i)) call abort()
|
||||
|
||||
end
|
||||
|
|
@ -1,8 +1,5 @@
|
|||
! { dg-do compile }
|
||||
!
|
||||
! FIXME: Remove -w after polymorphic entities are supported.
|
||||
! { dg-options "-w" }
|
||||
!
|
||||
! ALLOCATE statements with derived type specification
|
||||
!
|
||||
! Contributed by Janus Weil <janus@gcc.gnu.org>
|
||||
|
|
|
|||
|
|
@ -43,8 +43,8 @@ program blocks
|
|||
end if
|
||||
|
||||
select case (i)
|
||||
case (1) s2 ! { dg-error "Expected the name of the SELECT CASE construct" }
|
||||
case default s2 ! { dg-error "Expected the name of the SELECT CASE construct" }
|
||||
case (1) s2 ! { dg-error "Syntax error in CASE specification" }
|
||||
case default s2 ! { dg-error "Syntax error in CASE specification" }
|
||||
end select s2 ! { dg-error "Syntax error in END SELECT statement" }
|
||||
end select
|
||||
|
||||
|
|
|
|||
|
|
@ -1,8 +1,5 @@
|
|||
! { dg-do run }
|
||||
!
|
||||
! FIXME: Remove -w after polymorphic entities are supported.
|
||||
! { dg-options "-w" }
|
||||
!
|
||||
! PR 40940: CLASS statement
|
||||
!
|
||||
! Contributed by Janus Weil <janus@gcc.gnu.org>
|
||||
|
|
|
|||
|
|
@ -1,8 +1,5 @@
|
|||
! { dg-do compile }
|
||||
!
|
||||
! FIXME: Remove -w after polymorphic entities are supported.
|
||||
! { dg-options "-w" }
|
||||
!
|
||||
! PR 40940: CLASS statement
|
||||
!
|
||||
! Contributed by Janus Weil <janus@gcc.gnu.org>
|
||||
|
|
|
|||
95
gcc/testsuite/gfortran.dg/class_allocate_1.f03
Normal file
95
gcc/testsuite/gfortran.dg/class_allocate_1.f03
Normal file
|
|
@ -0,0 +1,95 @@
|
|||
! { dg-do run }
|
||||
!
|
||||
! Allocating CLASS variables.
|
||||
!
|
||||
! Contributed by Janus Weil <janus@gcc.gnu.org>
|
||||
|
||||
implicit none
|
||||
|
||||
type t1
|
||||
integer :: comp = 5
|
||||
class(t1),pointer :: cc
|
||||
end type
|
||||
|
||||
type, extends(t1) :: t2
|
||||
integer :: j
|
||||
end type
|
||||
|
||||
type, extends(t2) :: t3
|
||||
integer :: k
|
||||
end type
|
||||
|
||||
class(t1),pointer :: cp, cp2
|
||||
type(t3) :: x
|
||||
integer :: i
|
||||
|
||||
|
||||
! (1) check that vindex is set correctly (for different cases)
|
||||
|
||||
i = 0
|
||||
allocate(cp)
|
||||
select type (cp)
|
||||
type is (t1)
|
||||
i = 1
|
||||
type is (t2)
|
||||
i = 2
|
||||
type is (t3)
|
||||
i = 3
|
||||
end select
|
||||
deallocate(cp)
|
||||
if (i /= 1) call abort()
|
||||
|
||||
i = 0
|
||||
allocate(t2 :: cp)
|
||||
select type (cp)
|
||||
type is (t1)
|
||||
i = 1
|
||||
type is (t2)
|
||||
i = 2
|
||||
type is (t3)
|
||||
i = 3
|
||||
end select
|
||||
deallocate(cp)
|
||||
if (i /= 2) call abort()
|
||||
|
||||
i = 0
|
||||
allocate(cp, source = x)
|
||||
select type (cp)
|
||||
type is (t1)
|
||||
i = 1
|
||||
type is (t2)
|
||||
i = 2
|
||||
type is (t3)
|
||||
i = 3
|
||||
end select
|
||||
deallocate(cp)
|
||||
if (i /= 3) call abort()
|
||||
|
||||
i = 0
|
||||
allocate(t2 :: cp2)
|
||||
allocate(cp, source = cp2) ! { dg-warning "not supported yet" }
|
||||
select type (cp)
|
||||
type is (t1)
|
||||
i = 1
|
||||
type is (t2)
|
||||
i = 2
|
||||
type is (t3)
|
||||
i = 3
|
||||
end select
|
||||
deallocate(cp)
|
||||
deallocate(cp2)
|
||||
if (i /= 2) call abort()
|
||||
|
||||
|
||||
! (2) check initialization (default initialization vs. SOURCE)
|
||||
|
||||
allocate(cp)
|
||||
if (cp%comp /= 5) call abort()
|
||||
deallocate(cp)
|
||||
|
||||
x%comp = 4
|
||||
allocate(cp, source=x)
|
||||
if (cp%comp /= 4) call abort()
|
||||
deallocate(cp)
|
||||
|
||||
end
|
||||
|
|
@ -1,8 +1,5 @@
|
|||
! { dg-do run }
|
||||
!
|
||||
! FIXME: Remove -w after polymorphic entities are supported.
|
||||
! { dg-options "-w" }
|
||||
!
|
||||
! PR 39630: [F03] Procedure Pointer Components with PASS
|
||||
!
|
||||
! found at http://groups.google.com/group/comp.lang.fortran/browse_thread/thread/4a827e8ced6efb0f/884b9eca6d7e6742
|
||||
|
|
|
|||
|
|
@ -1,8 +1,5 @@
|
|||
! { dg-do run }
|
||||
!
|
||||
! FIXME: Remove -w after polymorphic entities are supported.
|
||||
! { dg-options "-w" }
|
||||
!
|
||||
! PR 39630: [F03] Procedure Pointer Components with PASS
|
||||
!
|
||||
! taken from "The Fortran 2003 Handbook" (Adams et al., 2009)
|
||||
|
|
|
|||
|
|
@ -1,8 +1,5 @@
|
|||
! { dg-do run }
|
||||
!
|
||||
! FIXME: Remove -w after polymorphic entities are supported.
|
||||
! { dg-options "-w" }
|
||||
!
|
||||
! PR 39630: [F03] Procedure Pointer Components with PASS
|
||||
!
|
||||
! taken from "Fortran 95/2003 explained" (Metcalf, Reid, Cohen, 2004)
|
||||
|
|
|
|||
24
gcc/testsuite/gfortran.dg/same_type_as_1.f03
Normal file
24
gcc/testsuite/gfortran.dg/same_type_as_1.f03
Normal file
|
|
@ -0,0 +1,24 @@
|
|||
! { dg-do compile }
|
||||
!
|
||||
! Error checking for the intrinsic function SAME_TYPE_AS.
|
||||
!
|
||||
! Contributed by Janus Weil <janus@gcc.gnu.org>
|
||||
|
||||
type :: t1
|
||||
integer :: i
|
||||
end type
|
||||
|
||||
type :: ts
|
||||
sequence
|
||||
integer :: j
|
||||
end type
|
||||
|
||||
TYPE(t1) :: x1
|
||||
TYPE(ts) :: x2
|
||||
|
||||
integer :: i
|
||||
|
||||
print *, SAME_TYPE_AS (l,x1) ! { dg-error "must be of a derived type" }
|
||||
print *, SAME_TYPE_AS (x1,x2) ! { dg-error "must be of an extensible type" }
|
||||
|
||||
end
|
||||
52
gcc/testsuite/gfortran.dg/same_type_as_2.f03
Normal file
52
gcc/testsuite/gfortran.dg/same_type_as_2.f03
Normal file
|
|
@ -0,0 +1,52 @@
|
|||
! { dg-do run }
|
||||
!
|
||||
! Verifying the runtime behavior of the intrinsic function SAME_TYPE_AS.
|
||||
!
|
||||
! Contributed by Janus Weil <janus@gcc.gnu.org>
|
||||
|
||||
type :: t1
|
||||
integer :: i
|
||||
end type
|
||||
|
||||
type :: t2
|
||||
integer :: j
|
||||
end type
|
||||
|
||||
CLASS(t1), pointer :: c1
|
||||
CLASS(t2), pointer :: c2
|
||||
TYPE(t1), target :: x1
|
||||
TYPE(t2) ,target :: x2
|
||||
|
||||
intrinsic :: SAME_TYPE_AS
|
||||
logical :: l
|
||||
|
||||
c1 => NULL()
|
||||
|
||||
l = SAME_TYPE_AS (x1,x1)
|
||||
print *,l
|
||||
if (.not.l) call abort()
|
||||
l = SAME_TYPE_AS (x1,x2)
|
||||
print *,l
|
||||
if (l) call abort()
|
||||
|
||||
c1 => x1
|
||||
l = SAME_TYPE_AS (c1,x1)
|
||||
print *,l
|
||||
if (.not.l) call abort()
|
||||
l = SAME_TYPE_AS (c1,x2)
|
||||
print *,l
|
||||
if (l) call abort()
|
||||
|
||||
c1 => x2
|
||||
c2 => x2
|
||||
l = SAME_TYPE_AS (c1,c2)
|
||||
print *,l
|
||||
if (.not.l) call abort()
|
||||
|
||||
c1 => x1
|
||||
c2 => x2
|
||||
l = SAME_TYPE_AS (c1,c2)
|
||||
print *,l
|
||||
if (l) call abort()
|
||||
|
||||
end
|
||||
|
|
@ -5,6 +5,6 @@
|
|||
integer(kind=1) :: i
|
||||
real :: r(3)
|
||||
select case (i)
|
||||
case (129) r(4) = 0 { dg-error "Expected the name" }
|
||||
case (129) r(4) = 0 ! { dg-error "Syntax error in CASE specification" }
|
||||
end select
|
||||
end
|
||||
|
|
|
|||
72
gcc/testsuite/gfortran.dg/select_type_1.f03
Normal file
72
gcc/testsuite/gfortran.dg/select_type_1.f03
Normal file
|
|
@ -0,0 +1,72 @@
|
|||
! { dg-do compile }
|
||||
!
|
||||
! Error checking for the SELECT TYPE statement
|
||||
!
|
||||
! Contributed by Janus Weil <janus@gcc.gnu.org>
|
||||
|
||||
type :: t1
|
||||
integer :: i = 42
|
||||
class(t1),pointer :: cp
|
||||
end type
|
||||
|
||||
type, extends(t1) :: t2
|
||||
integer :: j = 99
|
||||
end type
|
||||
|
||||
type :: t3
|
||||
real :: r
|
||||
end type
|
||||
|
||||
type :: ts
|
||||
sequence
|
||||
integer :: k = 5
|
||||
end type
|
||||
|
||||
class(t1), pointer :: a => NULL()
|
||||
type(t1), target :: b
|
||||
type(t2), target :: c
|
||||
a => b
|
||||
print *, a%i
|
||||
|
||||
type is (t1) ! { dg-error "Unexpected TYPE IS statement" }
|
||||
|
||||
select type (3.5) ! { dg-error "Selector must be a named variable" }
|
||||
select type (a%cp) ! { dg-error "Selector must be a named variable" }
|
||||
select type (b) ! { dg-error "Selector shall be polymorphic" }
|
||||
|
||||
select type (a)
|
||||
print *,"hello world!" ! { dg-error "Expected TYPE IS, CLASS IS or END SELECT" }
|
||||
type is (t1)
|
||||
print *,"a is TYPE(t1)"
|
||||
type is (t2)
|
||||
print *,"a is TYPE(t2)"
|
||||
! FIXME: CLASS IS specification is not yet supported
|
||||
! class is (ts) ! { FIXME: error "must be extensible" }
|
||||
! print *,"a is TYPE(ts)"
|
||||
type is (t3) ! { dg-error "must be an extension of" }
|
||||
print *,"a is TYPE(t3)"
|
||||
type is (t4) ! { dg-error "is not an accessible derived type" }
|
||||
print *,"a is TYPE(t3)"
|
||||
! FIXME: CLASS IS specification is not yet supported
|
||||
! class is (t1)
|
||||
! print *,"a is CLASS(t1)"
|
||||
class is (t2) label ! { dg-error "Syntax error" }
|
||||
print *,"a is CLASS(t2)"
|
||||
class default ! { dg-error "cannot be followed by a second DEFAULT CASE" }
|
||||
print *,"default"
|
||||
class default ! { dg-error "cannot be followed by a second DEFAULT CASE" }
|
||||
print *,"default2"
|
||||
end select
|
||||
|
||||
label: select type (a)
|
||||
type is (t1) label
|
||||
print *,"a is TYPE(t1)"
|
||||
type is (t2) ! { dg-error "overlaps with CASE label" }
|
||||
print *,"a is TYPE(t2)"
|
||||
type is (t2) ! { dg-error "overlaps with CASE label" }
|
||||
print *,"a is still TYPE(t2)"
|
||||
class is (t1) labe ! { dg-error "Expected block name" }
|
||||
print *,"a is CLASS(t1)"
|
||||
end select label
|
||||
|
||||
end
|
||||
69
gcc/testsuite/gfortran.dg/select_type_2.f03
Normal file
69
gcc/testsuite/gfortran.dg/select_type_2.f03
Normal file
|
|
@ -0,0 +1,69 @@
|
|||
! { dg-do run }
|
||||
!
|
||||
! executing simple SELECT TYPE statements
|
||||
!
|
||||
! Contributed by Janus Weil <janus@gcc.gnu.org>
|
||||
|
||||
type :: t1
|
||||
integer :: i
|
||||
end type t1
|
||||
|
||||
type, extends(t1) :: t2
|
||||
integer :: j
|
||||
end type t2
|
||||
|
||||
type, extends(t1) :: t3
|
||||
real :: r
|
||||
end type
|
||||
|
||||
class(t1), pointer :: cp
|
||||
type(t1), target :: a
|
||||
type(t2), target :: b
|
||||
type(t3), target :: c
|
||||
integer :: i
|
||||
|
||||
cp => a
|
||||
i = 0
|
||||
|
||||
select type (cp)
|
||||
type is (t1)
|
||||
i = 1
|
||||
type is (t2)
|
||||
i = 2
|
||||
! FIXME: CLASS IS is not yet supported
|
||||
! class is (t1)
|
||||
! i = 3
|
||||
end select
|
||||
|
||||
if (i /= 1) call abort()
|
||||
|
||||
cp => b
|
||||
i = 0
|
||||
|
||||
select type (cp)
|
||||
type is (t1)
|
||||
i = 1
|
||||
type is (t2)
|
||||
i = 2
|
||||
! FIXME: CLASS IS is not yet supported
|
||||
! class is (t2)
|
||||
! i = 3
|
||||
end select
|
||||
|
||||
if (i /= 2) call abort()
|
||||
|
||||
cp => c
|
||||
i = 0
|
||||
|
||||
select type (cp)
|
||||
type is (t1)
|
||||
i = 1
|
||||
type is (t2)
|
||||
i = 2
|
||||
class default
|
||||
i = 3
|
||||
end select
|
||||
|
||||
if (i /= 3) call abort()
|
||||
|
||||
end
|
||||
42
gcc/testsuite/gfortran.dg/select_type_3.f03
Normal file
42
gcc/testsuite/gfortran.dg/select_type_3.f03
Normal file
|
|
@ -0,0 +1,42 @@
|
|||
! { dg-do run }
|
||||
!
|
||||
! SELECT TYPE with temporaries
|
||||
!
|
||||
! Contributed by Janus Weil <janus@gcc.gnu.org>
|
||||
|
||||
type :: t1
|
||||
integer :: i = -1
|
||||
end type t1
|
||||
|
||||
type, extends(t1) :: t2
|
||||
integer :: j = -1
|
||||
end type t2
|
||||
|
||||
class(t1), pointer :: cp
|
||||
type(t2), target :: b
|
||||
|
||||
cp => b
|
||||
|
||||
select type (cp)
|
||||
type is (t1)
|
||||
cp%i = 1
|
||||
type is (t2)
|
||||
cp%j = 2
|
||||
end select
|
||||
|
||||
print *,b%i,b%j
|
||||
if (b%i /= -1) call abort()
|
||||
if (b%j /= 2) call abort()
|
||||
|
||||
select type (cp)
|
||||
type is (t1)
|
||||
cp%i = 4
|
||||
type is (t2)
|
||||
cp%i = 3*cp%j
|
||||
end select
|
||||
|
||||
print *,b%i,b%j
|
||||
if (b%i /= 6) call abort()
|
||||
if (b%j /= 2) call abort()
|
||||
|
||||
end
|
||||
|
|
@ -1,8 +1,5 @@
|
|||
! { dg-do run }
|
||||
!
|
||||
! FIXME: Remove -w after polymorphic entities are supported.
|
||||
! { dg-options "-w" }
|
||||
!
|
||||
! PR 39630: [F03] Procedure Pointer Components with PASS
|
||||
!
|
||||
! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
|
||||
|
|
|
|||
|
|
@ -1,8 +1,5 @@
|
|||
! { dg-do run }
|
||||
|
||||
! FIXME: Remove -w after polymorphic entities are supported.
|
||||
! { dg-options "-w" }
|
||||
|
||||
! Type-bound procedures
|
||||
! Check calls with passed-objects.
|
||||
|
||||
|
|
|
|||
|
|
@ -1,8 +1,5 @@
|
|||
! { dg-do run }
|
||||
|
||||
! FIXME: Remove -w after polymorphic entities are supported.
|
||||
! { dg-options "-w" }
|
||||
|
||||
! Type-bound procedures
|
||||
! Check that calls work across module-boundaries.
|
||||
|
||||
|
|
|
|||
|
|
@ -1,8 +1,5 @@
|
|||
! { dg-do compile }
|
||||
|
||||
! FIXME: Remove -w after polymorphic entities are supported.
|
||||
! { dg-options "-w" }
|
||||
|
||||
! Type-bound procedures
|
||||
! Check for recognition/errors with more complicated references and some
|
||||
! error-handling in general.
|
||||
|
|
|
|||
|
|
@ -1,8 +1,5 @@
|
|||
! { dg-do compile }
|
||||
|
||||
! FIXME: Remove once polymorphic PASS is resolved
|
||||
! { dg-options "-w" }
|
||||
|
||||
! PR fortran/37638
|
||||
! If a PASS(arg) is invalid, a call to this routine later would ICE in
|
||||
! resolving. Check that this also works for GENERIC, in addition to the
|
||||
|
|
|
|||
|
|
@ -1,8 +1,5 @@
|
|||
! { dg-do run }
|
||||
|
||||
! FIXME: Remove -w once switched to polymorphic passed-object dummy arguments.
|
||||
! { dg-options "-w" }
|
||||
|
||||
! Type-bound procedures
|
||||
! Check calls with GENERIC bindings.
|
||||
|
||||
|
|
|
|||
|
|
@ -1,8 +1,5 @@
|
|||
! { dg-do run }
|
||||
|
||||
! FIXME: Remove -w once the TYPE/CLASS issue is resolved
|
||||
! { dg-options "-w" }
|
||||
|
||||
! PR fortran/37588
|
||||
! This test used to not resolve the GENERIC binding.
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,4 @@
|
|||
! { dg-do compile }
|
||||
! { dg-options "-w" }
|
||||
! FIXME: Remove -w once CLASS is fully supported.
|
||||
|
||||
! Type-bound procedures
|
||||
! Check correct type-bound operator definitions.
|
||||
|
|
|
|||
|
|
@ -1,6 +1,4 @@
|
|||
! { dg-do compile }
|
||||
! { dg-options "-w" }
|
||||
! FIXME: Remove -w once CLASS is fully supported.
|
||||
|
||||
! Type-bound procedures
|
||||
! Checks for correct errors with invalid OPERATOR/ASSIGNMENT usage.
|
||||
|
|
|
|||
|
|
@ -1,6 +1,4 @@
|
|||
! { dg-do run }
|
||||
! { dg-options "-w" }
|
||||
! FIXME: Remove -w when CLASS is fully implemented.
|
||||
|
||||
! Type-bound procedures
|
||||
! Check they can actually be called and run correctly.
|
||||
|
|
|
|||
|
|
@ -1,6 +1,4 @@
|
|||
! { dg-do compile }
|
||||
! { dg-options "-w" }
|
||||
! FIXME: Remove -w when CLASS is fully implemented.
|
||||
|
||||
! Type-bound procedures
|
||||
! Check for errors with operator calls.
|
||||
|
|
|
|||
|
|
@ -1,8 +1,5 @@
|
|||
! { dg-do compile }
|
||||
|
||||
! FIXME: Remove -w after polymorphic entities are supported.
|
||||
! { dg-options "-w" }
|
||||
|
||||
! Type-bound procedures
|
||||
! Test that the basic syntax for specific bindings is parsed and resolved.
|
||||
|
||||
|
|
|
|||
|
|
@ -1,8 +1,5 @@
|
|||
! { dg-do compile }
|
||||
|
||||
! FIXME: Remove -w after polymorphic entities are supported.
|
||||
! { dg-options "-w" }
|
||||
|
||||
! Type-bound procedures
|
||||
! Test for errors in specific bindings, during resolution.
|
||||
|
||||
|
|
@ -58,8 +55,8 @@ MODULE testmod
|
|||
PROCEDURE, PASS :: e1 => proc_noarg ! { dg-error "at least one argument" }
|
||||
PROCEDURE :: e2 => proc_noarg ! { dg-error "at least one argument" }
|
||||
PROCEDURE, PASS(me) :: e3 => proc_nome ! { dg-error "no argument 'me'" }
|
||||
PROCEDURE, PASS(me) :: e4 => proc_mewrong ! { dg-error "of the derived" }
|
||||
PROCEDURE, PASS :: e5 => proc_mewrong ! { dg-error "of the derived" }
|
||||
PROCEDURE, PASS(me) :: e4 => proc_mewrong ! { dg-error "Non-polymorphic passed-object dummy argument" }
|
||||
PROCEDURE, PASS :: e5 => proc_mewrong ! { dg-error "Non-polymorphic passed-object dummy argument" }
|
||||
PROCEDURE :: e6 => noproc ! { dg-error "module procedure" }
|
||||
PROCEDURE :: e7 => proc_nointf ! { dg-error "explicit interface" }
|
||||
PROCEDURE, NOPASS :: e8 => proc_abstract_intf ! { dg-error "explicit interface" }
|
||||
|
|
|
|||
|
|
@ -1,8 +1,5 @@
|
|||
! { dg-do compile }
|
||||
|
||||
! FIXME: Remove -w after polymorphic entities are supported.
|
||||
! { dg-options "-w" }
|
||||
|
||||
! Type-bound procedures
|
||||
! Test for the check if overriding methods "match" the overridden ones by their
|
||||
! characteristics.
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue