diff options
| author | Janus Weil <janus@gcc.gnu.org> | 2009-08-31 21:08:03 +0200 |
|---|---|---|
| committer | Janus Weil <janus@gcc.gnu.org> | 2009-08-31 21:08:03 +0200 |
| commit | e74f1cc83c20eff2e1d0f9b3363075a1d7fd6a78 (patch) | |
| tree | e381e09a17810c8b05f37fdbd76ea44cf8c23cb2 /gcc/fortran/symbol.c | |
| parent | e2abde5f35ace69607e6664daa9765f50635ad1d (diff) | |
| download | gcc-e74f1cc83c20eff2e1d0f9b3363075a1d7fd6a78.zip gcc-e74f1cc83c20eff2e1d0f9b3363075a1d7fd6a78.tar.gz gcc-e74f1cc83c20eff2e1d0f9b3363075a1d7fd6a78.tar.bz2 | |
re PR fortran/40940 ([F03] CLASS statement)
2009-08-31 Janus Weil <janus@gcc.gnu.org>
Paul Thomas <pault@gcc.gnu.org>
PR fortran/40940
* array.c (gfc_match_array_constructor): Rename gfc_match_type_spec.
* decl.c (gfc_match_type_spec): Rename to gfc_match_decl_type_spec,
and reject CLASS with -std=f95.
(gfc_match_implicit, gfc_match_data_decl,gfc_match_prefix,
match_procedure_interface): Rename gfc_match_type_spec.
* gfortran.h (gfc_type_compatible): Add prototype.
* match.h (gfc_match_type_spec): Rename to gfc_match_decl_type_spec.
* match.c (match_intrinsic_typespec): Rename to match_type_spec, and
add handling of derived types.
(gfc_match_allocate): Rename match_intrinsic_typespec and check
type compatibility of derived types.
* symbol.c (gfc_type_compatible): New function to check if two types
are compatible.
2009-08-31 Janus Weil <janus@gcc.gnu.org>
PR fortran/40940
* gfortran.dg/allocate_derived_1.f90: New.
* gfortran.dg/class_3.f03: New.
Co-Authored-By: Paul Thomas <pault@gcc.gnu.org>
From-SVN: r151244
Diffstat (limited to 'gcc/fortran/symbol.c')
| -rw-r--r-- | gcc/fortran/symbol.c | 26 |
1 files changed, 26 insertions, 0 deletions
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 150d149..f6ce3cf 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -4534,6 +4534,32 @@ gfc_get_derived_super_type (gfc_symbol* derived) } +/* 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. */ + +bool +gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2) +{ + if (ts1->type == BT_DERIVED && ts2->type == BT_DERIVED) + { + 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); + } + else + return (ts1->u.derived == ts2->u.derived); + } + else + return (ts1->type == ts2->type); +} + + /* General worker function to find either a type-bound procedure or a type-bound user operator. */ |