OSDN Git Service

fortran/
authorburnus <burnus@138bc75d-0d04-0410-961f-82ee72b054a4>
Wed, 30 Sep 2009 19:55:45 +0000 (19:55 +0000)
committerburnus <burnus@138bc75d-0d04-0410-961f-82ee72b054a4>
Wed, 30 Sep 2009 19:55:45 +0000 (19:55 +0000)
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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@152345 138bc75d-0d04-0410-961f-82ee72b054a4

55 files changed:
gcc/fortran/ChangeLog
gcc/fortran/check.c
gcc/fortran/decl.c
gcc/fortran/dump-parse-tree.c
gcc/fortran/expr.c
gcc/fortran/gfortran.h
gcc/fortran/interface.c
gcc/fortran/intrinsic.c
gcc/fortran/intrinsic.h
gcc/fortran/match.c
gcc/fortran/match.h
gcc/fortran/misc.c
gcc/fortran/module.c
gcc/fortran/parse.c
gcc/fortran/parse.h
gcc/fortran/primary.c
gcc/fortran/resolve.c
gcc/fortran/st.c
gcc/fortran/symbol.c
gcc/fortran/trans-array.c
gcc/fortran/trans-expr.c
gcc/fortran/trans-intrinsic.c
gcc/fortran/trans-stmt.c
gcc/fortran/trans-types.c
gcc/fortran/trans.c
gcc/testsuite/ChangeLog
gcc/testsuite/gfortran.dg/allocatable_scalar_3.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/allocate_derived_1.f90
gcc/testsuite/gfortran.dg/block_name_2.f90
gcc/testsuite/gfortran.dg/class_1.f03
gcc/testsuite/gfortran.dg/class_2.f03
gcc/testsuite/gfortran.dg/class_allocate_1.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_1.f90
gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_2.f90
gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_3.f90
gcc/testsuite/gfortran.dg/same_type_as_1.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/same_type_as_2.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/select_6.f90
gcc/testsuite/gfortran.dg/select_type_1.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/select_type_2.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/select_type_3.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/typebound_call_10.f03
gcc/testsuite/gfortran.dg/typebound_call_2.f03
gcc/testsuite/gfortran.dg/typebound_call_3.f03
gcc/testsuite/gfortran.dg/typebound_call_4.f03
gcc/testsuite/gfortran.dg/typebound_call_9.f03
gcc/testsuite/gfortran.dg/typebound_generic_3.f03
gcc/testsuite/gfortran.dg/typebound_generic_4.f03
gcc/testsuite/gfortran.dg/typebound_operator_1.f03
gcc/testsuite/gfortran.dg/typebound_operator_2.f03
gcc/testsuite/gfortran.dg/typebound_operator_3.f03
gcc/testsuite/gfortran.dg/typebound_operator_4.f03
gcc/testsuite/gfortran.dg/typebound_proc_1.f08
gcc/testsuite/gfortran.dg/typebound_proc_5.f03
gcc/testsuite/gfortran.dg/typebound_proc_6.f03

index addfcbe..04aac0c 100644 (file)
@@ -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
index 01775ab..171eeaa 100644 (file)
@@ -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)
@@ -2647,6 +2641,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)
 {
   if (type_check (x, 0, BT_REAL) == FAILURE)
index cfd8b81..20718ca 100644 (file)
@@ -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;
 
index 8480e40..32ff298 100644 (file)
@@ -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);
index 970c259..32aa682 100644 (file)
@@ -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);
index 0dce218..326112d 100644 (file)
@@ -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 */
index 132f10a..0fd4742 100644 (file)
@@ -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);
index d2cdb59..3e8e3f2 100644 (file)
@@ -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);
index a239ad6..acd3f78 100644 (file)
@@ -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 *);
index 919d5d1..3e969e7 100644 (file)
@@ -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;
-         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
+      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)
        {
-         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.  
index a53c7f0..bc19453 100644 (file)
@@ -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 *);
index f80c9fa..b5e6275 100644 (file)
@@ -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;
index ec15d3f..1769ead 100644 (file)
@@ -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 ();
 }
 
index e6b5dbb..13199c9 100644 (file)
@@ -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)
index 7239c38..2b92661 100644 (file)
@@ -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;
 
index f25de23..c0777c4 100644 (file)
@@ -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);
 
index 3eec50e..445753e 100644 (file)
@@ -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,21 +9513,22 @@ 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 ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
-                    " the derived-type '%s'", me_arg->name, proc->name,
-                    me_arg->name, &where, resolve_bindings_derived->name);
+         gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
+                    " at %L", proc->name, &where);
          goto error;
        }
 
-      if (!me_arg->ts.is_class)
+      if (me_arg->ts.u.derived->components->ts.u.derived
+         != resolve_bindings_derived)
        {
-         gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
-                    " at %L", proc->name, &where);
+         gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
+                    " the derived-type '%s'", me_arg->name, proc->name,
+                    me_arg->name, &where, resolve_bindings_derived->name);
          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);
index c3c640a..f1765e6 100644 (file)
@@ -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:
index f6ce3cf..39285b1 100644 (file)
@@ -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);
index 31c59c6..0c00d32 100644 (file)
@@ -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);
index b3642c2..eb741f8 100644 (file)
@@ -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->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);
+         /* Append it to the constructor list.  */
+         CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
+       }
     }
   se->expr = build_constructor (type, v);
   if (init) 
index b9e5b86..b00ceba 100644 (file)
@@ -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;
index 25a5b3b..9d3197d 100644 (file)
@@ -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);
index 454a155..9096ad4 100644 (file)
@@ -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,
index f53f75e..09b424c 100644 (file)
@@ -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;
index 61d402a..1a98272 100644 (file)
@@ -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.
diff --git a/gcc/testsuite/gfortran.dg/allocatable_scalar_3.f90 b/gcc/testsuite/gfortran.dg/allocatable_scalar_3.f90
new file mode 100644 (file)
index 0000000..c624de2
--- /dev/null
@@ -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
index d74851e..b9f6d55 100644 (file)
@@ -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>
index 590a015..d86e77e 100644 (file)
@@ -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
 
index bdd742b..f21133a 100644 (file)
@@ -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>
index b402045..070d3f7 100644 (file)
@@ -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>
diff --git a/gcc/testsuite/gfortran.dg/class_allocate_1.f03 b/gcc/testsuite/gfortran.dg/class_allocate_1.f03
new file mode 100644 (file)
index 0000000..844e144
--- /dev/null
@@ -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
index 2a73bda..4513083 100644 (file)
@@ -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
index 9e3cd58..03770ce 100644 (file)
@@ -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)
index 3c56794..add025c 100644 (file)
@@ -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)
diff --git a/gcc/testsuite/gfortran.dg/same_type_as_1.f03 b/gcc/testsuite/gfortran.dg/same_type_as_1.f03
new file mode 100644 (file)
index 0000000..ba13a0b
--- /dev/null
@@ -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
diff --git a/gcc/testsuite/gfortran.dg/same_type_as_2.f03 b/gcc/testsuite/gfortran.dg/same_type_as_2.f03
new file mode 100644 (file)
index 0000000..9a2110d
--- /dev/null
@@ -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
index 926659c..0e0f052 100644 (file)
@@ -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
diff --git a/gcc/testsuite/gfortran.dg/select_type_1.f03 b/gcc/testsuite/gfortran.dg/select_type_1.f03
new file mode 100644 (file)
index 0000000..e764ec9
--- /dev/null
@@ -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
diff --git a/gcc/testsuite/gfortran.dg/select_type_2.f03 b/gcc/testsuite/gfortran.dg/select_type_2.f03
new file mode 100644 (file)
index 0000000..08ac9fe
--- /dev/null
@@ -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
diff --git a/gcc/testsuite/gfortran.dg/select_type_3.f03 b/gcc/testsuite/gfortran.dg/select_type_3.f03
new file mode 100644 (file)
index 0000000..13cd3c1
--- /dev/null
@@ -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
index 77667fb..ca6038e 100644 (file)
@@ -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>
index f6e623c..5d70f7c 100644 (file)
@@ -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.
 
index 028c5b1..eabb28e 100644 (file)
@@ -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.
 
index 25745fd..cdbbea9 100644 (file)
@@ -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.
index f2e128d..6bb2ca8 100644 (file)
@@ -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
index d708282..d56f914 100644 (file)
@@ -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.
 
index 28af021..ff5cd05 100644 (file)
@@ -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.
 
index 2556590..f756a59 100644 (file)
@@ -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.
index 71e8e4f..57b3448 100644 (file)
@@ -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.
index 9f2369a..51ad1d2 100644 (file)
@@ -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.
index ee7c298..1ce2b97 100644 (file)
@@ -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.
index 3437baa..53868a4 100644 (file)
@@ -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.
 
index 1251e3f..fdd15b3 100644 (file)
@@ -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" }
index eba4836..83765bf 100644 (file)
@@ -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.