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
+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/40996
seen_ts = false;
/* Try to match an optional "type-spec ::" */
- if (gfc_match_type_spec (&ts, 0) == MATCH_YES)
+ if (gfc_match_decl_type_spec (&ts, 0) == MATCH_YES)
{
seen_ts = (gfc_match (" ::") == MATCH_YES);
}
-/* Matches a type specification. If successful, sets the ts structure
- to the matched specification. This is necessary for FUNCTION and
+/* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
+ structure to the matched specification. This is necessary for FUNCTION and
IMPLICIT statements.
If implicit_flag is nonzero, then we don't check for the optional
statement correctly. */
match
-gfc_match_type_spec (gfc_typespec *ts, int implicit_flag)
+gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_symbol *sym;
return m;
ts->is_class = 1;
+ 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");
gfc_clear_new_implicit ();
/* A basic type is mandatory here. */
- m = gfc_match_type_spec (&ts, 1);
+ m = gfc_match_decl_type_spec (&ts, 1);
if (m == MATCH_ERROR)
goto error;
if (m == MATCH_NO)
num_idents_on_line = 0;
- m = gfc_match_type_spec (¤t_ts, 0);
+ m = gfc_match_decl_type_spec (¤t_ts, 0);
if (m != MATCH_YES)
return m;
loop:
if (!seen_type && ts != NULL
- && gfc_match_type_spec (ts, 0) == MATCH_YES
+ && gfc_match_decl_type_spec (ts, 0) == MATCH_YES
&& gfc_match_space () == MATCH_YES)
{
/* Get the type spec. for the procedure interface. */
old_loc = gfc_current_locus;
- m = gfc_match_type_spec (¤t_ts, 0);
+ m = gfc_match_decl_type_spec (¤t_ts, 0);
gfc_gobble_whitespace ();
if (m == MATCH_YES || (m == MATCH_NO && gfc_peek_ascii_char () == ')'))
goto got_ts;
gfc_typebound_proc* gfc_get_typebound_proc (void);
gfc_symbol* gfc_get_derived_super_type (gfc_symbol*);
+bool gfc_type_compatible (gfc_typespec *, gfc_typespec *);
gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, gfc_try*,
const char*, bool, locus*);
gfc_symtree* gfc_find_typebound_user_op (gfc_symbol*, gfc_try*,
}
-/* Match a Fortran 2003 intrinsic-type-spec. This is a stripped
- down version of gfc_match_type_spec() from decl.c. It only includes
- the intrinsic types from the Fortran 2003 standard. Thus, neither
- BYTE nor forms like REAL*4 are allowed. Additionally, the implicit_flag
- is not needed, so it was removed. The handling of derived types has
- been removed and no notion of the gfc_matching_function state
- is needed. In short, this functions matches only standard conforming
- intrinsic-type-spec (R403). */
+/* 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
+ (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally,
+ the implicit_flag is not needed, so it was removed. Derived types are
+ identified by their name alone. */
static match
-match_intrinsic_typespec (gfc_typespec *ts)
+match_type_spec (gfc_typespec *ts)
{
match m;
+ gfc_symbol *derived;
+ locus old_locus;
gfc_clear_ts (ts);
+ old_locus = gfc_current_locus;
if (gfc_match ("integer") == MATCH_YES)
{
goto kind_selector;
}
- /* If an intrinsic type is not matched, simply return MATCH_NO. */
+ if (gfc_match_symbol (&derived, 1) == 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
+ {
+ 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;
+ }
+ }
+ }
+
+ /* If a type is not matched, simply return MATCH_NO. */
return MATCH_NO;
kind_selector:
if (gfc_match_char ('(') != MATCH_YES)
goto syntax;
- /* Match an optional intrinsic-type-spec. */
+ /* Match an optional type-spec. */
old_locus = gfc_current_locus;
- m = match_intrinsic_typespec (&ts);
+ m = match_type_spec (&ts);
if (m == MATCH_ERROR)
goto cleanup;
else if (m == MATCH_NO)
constraints. */
if (ts.type != BT_UNKNOWN)
{
- /* Enforce C626. */
- if (ts.type != tail->expr->ts.type)
+ /* Enforce F03:C624. */
+ if (!gfc_type_compatible (&tail->expr->ts, &ts))
{
gfc_error ("Type of entity at %L is type incompatible with "
"typespec", &tail->expr->where);
goto cleanup;
}
- /* Enforce C627. */
+ /* Enforce F03:C627. */
if (ts.kind != tail->expr->ts.kind)
{
gfc_error ("Kind type parameter for entity at %L differs from "
match gfc_match_null (gfc_expr **);
match gfc_match_kind_spec (gfc_typespec *, bool);
match gfc_match_old_kind_spec (gfc_typespec *);
-match gfc_match_type_spec (gfc_typespec *, int);
+match gfc_match_decl_type_spec (gfc_typespec *, int);
match gfc_match_end (gfc_statement *);
match gfc_match_data_decl (void);
}
+/* 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. */
+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.
+
2009-08-31 Janus Weil <janus@gcc.gnu.org>
PR fortran/40996
--- /dev/null
+! { 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>
+
+ type :: t1
+ integer :: i
+ end type
+
+ type, extends(t1) :: t2
+ real :: r
+ end type
+
+ type, extends(t2) :: t3
+ real :: q
+ end type
+
+ type, abstract :: u0
+ logical :: nothing
+ end type
+
+ type :: v1
+ real :: r
+ end type
+
+ class(t1),dimension(:),allocatable :: x
+ type(t2),dimension(:),allocatable :: y
+ class(t3),dimension(:),allocatable :: z
+
+ allocate( x(1))
+ allocate(t1 :: x(2))
+ allocate(t2 :: x(3))
+ allocate(t3 :: x(4))
+ allocate(tx :: x(5)) ! { dg-error "is not an accessible derived type" }
+ allocate(u0 :: x(6)) ! { dg-error "may not be ABSTRACT" }
+ allocate(v1 :: x(7)) ! { dg-error "is type incompatible with typespec" }
+
+ allocate( y(1))
+ allocate(t1 :: y(2)) ! { dg-error "is type incompatible with typespec" }
+ allocate(t2 :: y(3))
+ allocate(t3 :: y(3)) ! { dg-error "is type incompatible with typespec" }
+
+ allocate( z(1))
+ allocate(t1 :: z(2)) ! { dg-error "is type incompatible with typespec" }
+ allocate(t2 :: z(3)) ! { dg-error "is type incompatible with typespec" }
+ allocate(t3 :: z(4))
+
+end
+
--- /dev/null
+! { dg-do compile }
+! { dg-options "-std=f95" }
+!
+! PR 40940: [F03] CLASS statement
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+ type :: t
+ integer :: comp
+ end type
+
+ class(t), pointer :: cl ! { dg-error "CLASS statement" }
+
+end
+
projects / thirdparty / gcc.git / commitdiff
