2009-10-17 Janus Weil <janus@gcc.gnu.org>
Paul Thomas <pault@gcc.gnu.org>
PR fortran/41608
* decl.c (gfc_match_data_decl): Add BT_CLASS for undefined type
and empty type errors.
* parse.c (gfc_build_block_ns): Only set recursive if parent ns
has a proc_name.
PR fortran/41629
PR fortran/41618
PR fortran/41587
* gfortran.h : Add class_ok bitfield to symbol_attr.
* decl.c (build_sym): Set attr.class_ok if dummy, pointer or
allocatable.
(build_struct): Use gfc_try 't' to carry errors past the call
to encapsulate_class_symbol.
(attr_decl1): For a CLASS object, apply the new attribute to
the data component.
* match.c (gfc_match_select_type): Set attr.class_ok for an
assigned selector.
* resolve.c (resolve_fl_variable_derived): Check a CLASS object
is dummy, pointer or allocatable by testing the class_ok and
the use_assoc attribute.
2009-10-17 Janus Weil <janus@gcc.gnu.org>
Paul Thomas <pault@gcc.gnu.org>
PR fortran/41629
* gfortran.dg/class_6.f90: New test.
PR fortran/41608
PR fortran/41587
* gfortran.dg/class_7.f90: New test.
PR fortran/41618
* gfortran.dg/class_8.f90: New test.
Co-Authored-By: Paul Thomas <pault@gcc.gnu.org>
From-SVN: r152955
+2009-10-17 Janus Weil <janus@gcc.gnu.org>
+ Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/41608
+ * decl.c (gfc_match_data_decl): Add BT_CLASS for undefined type
+ and empty type errors.
+ * parse.c (gfc_build_block_ns): Only set recursive if parent ns
+ has a proc_name.
+
+ PR fortran/41629
+ PR fortran/41618
+ PR fortran/41587
+ * gfortran.h : Add class_ok bitfield to symbol_attr.
+ * decl.c (build_sym): Set attr.class_ok if dummy, pointer or
+ allocatable.
+ (build_struct): Use gfc_try 't' to carry errors past the call
+ to encapsulate_class_symbol.
+ (attr_decl1): For a CLASS object, apply the new attribute to
+ the data component.
+ * match.c (gfc_match_select_type): Set attr.class_ok for an
+ assigned selector.
+ * resolve.c (resolve_fl_variable_derived): Check a CLASS object
+ is dummy, pointer or allocatable by testing the class_ok and
+ the use_assoc attribute.
+
2009-10-16 Janus Weil <janus@gcc.gnu.org>
PR fortran/41719
sym->attr.implied_index = 0;
if (sym->ts.type == BT_CLASS)
- encapsulate_class_symbol (&sym->ts, &sym->attr, &sym->as);
+ {
+ sym->attr.class_ok = (sym->attr.dummy
+ || sym->attr.pointer
+ || sym->attr.allocatable) ? 1 : 0;
+ encapsulate_class_symbol (&sym->ts, &sym->attr, &sym->as);
+ }
return SUCCESS;
}
gfc_array_spec **as)
{
gfc_component *c;
+ gfc_try t = SUCCESS;
/* F03:C438/C439. If the current symbol is of the same derived type that we're
constructing, it must have the pointer attribute. */
}
}
- if (c->ts.type == BT_CLASS)
- encapsulate_class_symbol (&c->ts, &c->attr, &c->as);
-
/* Check array components. */
if (!c->attr.dimension)
- return SUCCESS;
+ goto scalar;
if (c->attr.pointer)
{
{
gfc_error ("Pointer array component of structure at %C must have a "
"deferred shape");
- return FAILURE;
+ t = FAILURE;
}
}
else if (c->attr.allocatable)
{
gfc_error ("Allocatable component of structure at %C must have a "
"deferred shape");
- return FAILURE;
+ t = FAILURE;
}
}
else
{
gfc_error ("Array component of structure at %C must have an "
"explicit shape");
- return FAILURE;
+ t = FAILURE;
}
}
- return SUCCESS;
+scalar:
+ if (c->ts.type == BT_CLASS)
+ encapsulate_class_symbol (&c->ts, &c->attr, &c->as);
+
+ return t;
}
if (m != MATCH_YES)
return m;
- if (current_ts.type == BT_DERIVED && gfc_current_state () != COMP_DERIVED)
+ if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
+ && gfc_current_state () != COMP_DERIVED)
{
sym = gfc_use_derived (current_ts.u.derived);
goto cleanup;
}
- if (current_ts.type == BT_DERIVED && current_ts.u.derived->components == NULL
+ if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
+ && current_ts.u.derived->components == NULL
&& !current_ts.u.derived->attr.zero_comp)
{
}
}
- /* Update symbol table. DIMENSION attribute is set
- in gfc_set_array_spec(). */
- if (current_attr.dimension == 0
- && gfc_copy_attr (&sym->attr, ¤t_attr, &var_locus) == FAILURE)
+ /* Update symbol table. DIMENSION attribute is set in
+ gfc_set_array_spec(). For CLASS variables, this must be applied
+ to the first component, or '$data' field. */
+ if (sym->ts.type == BT_CLASS && sym->ts.u.derived)
{
- m = MATCH_ERROR;
- goto cleanup;
+ gfc_component *comp;
+ comp = gfc_find_component (sym->ts.u.derived, "$data", true, true);
+ if (comp == NULL || gfc_copy_attr (&comp->attr, ¤t_attr,
+ &var_locus) == FAILURE)
+ {
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+ sym->attr.class_ok = (sym->attr.class_ok
+ || current_attr.allocatable
+ || current_attr.pointer);
+ }
+ else
+ {
+ if (current_attr.dimension == 0
+ && gfc_copy_attr (&sym->attr, ¤t_attr, &var_locus) == FAILURE)
+ {
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
}
if (gfc_set_array_spec (sym, as, &var_locus) == FAILURE)
unsigned is_bind_c:1; /* say if is bound to C. */
unsigned extension:1; /* extends a derived type. */
unsigned is_class:1; /* is a CLASS container. */
+ unsigned class_ok:1; /* is a CLASS object with correct attributes. */
/* These flags are both in the typespec and attribute. The attribute
list is what gets read from/written to a module file. The typespec
return MATCH_ERROR;
expr1->symtree->n.sym->ts = expr2->ts;
expr1->symtree->n.sym->attr.referenced = 1;
+ expr1->symtree->n.sym->attr.class_ok = 1;
}
else
{
my_ns->proc_name->name, NULL);
gcc_assert (t == SUCCESS);
}
- my_ns->proc_name->attr.recursive = parent_ns->proc_name->attr.recursive;
+
+ if (parent_ns->proc_name)
+ my_ns->proc_name->attr.recursive = parent_ns->proc_name->attr.recursive;
return my_ns;
}
}
/* C509. */
- if (!(sym->attr.dummy || sym->attr.allocatable || sym->attr.pointer
- || sym->ts.u.derived->components->attr.allocatable
- || sym->ts.u.derived->components->attr.pointer))
+ /* Assume that use associated symbols were checked in the module ns. */
+ if (!sym->attr.class_ok && !sym->attr.use_assoc)
{
gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
"or pointer", sym->name, &sym->declared_at);
+2009-10-17 Janus Weil <janus@gcc.gnu.org>
+ Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/41629
+ * gfortran.dg/class_6.f90: New test.
+
+ PR fortran/41608
+ PR fortran/41587
+ * gfortran.dg/class_7.f90: New test.
+
+ PR fortran/41618
+ * gfortran.dg/class_8.f90: New test.
+
2009-10-17 Richard Guenther <rguenther@suse.de>
* gcc.dg/lto/20091017-1_0.c: New testcase.
--- /dev/null
+! { dg-do run }
+!
+! PR 41629: [OOP] gimplification error on valid code
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+ type t1
+ integer :: comp
+ end type
+
+ type(t1), target :: a
+
+ class(t1) :: x
+ pointer :: x ! This is valid
+
+ a%comp = 3
+ x => a
+ print *,x%comp
+ if (x%comp/=3) call abort()
+
+end
--- /dev/null
+! { dg-do compile }
+! Test fixes for PR41587 and PR41608.
+!
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+!
+! PR41587: used to accept the declaration of component 'foo'
+ type t0
+ integer :: j = 42
+ end type t0
+ type t
+ integer :: i
+ class(t0), allocatable :: foo(3) ! { dg-error "deferred shape" }
+ end type t
+
+! PR41608: Would ICE on missing type decl
+ class(t1), pointer :: c ! { dg-error "before it is defined" }
+
+ select type (c) ! { dg-error "shall be polymorphic" }
+ type is (t1) ! { dg-error "Unexpected" }
+ end select ! { dg-error "Expecting END PROGRAM" }
+end
--- /dev/null
+! { dg-do compile }
+! Test fixes for PR41618.
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+!
+ type t1
+ integer :: comp
+ class(t1),pointer :: cc
+ end type
+
+ class(t1) :: x ! { dg-error "must be dummy, allocatable or pointer" }
+
+ x%comp = 3
+ print *,x%comp
+
+end
projects / gcc.git / commitdiff