+2010-05-17 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/44044
+ * resolve.c (resolve_fl_var_and_proc): Move error messages here from ...
+ (resolve_fl_variable_derived): ... this place.
+ (resolve_symbol): Make sure function symbols (and their result
+ variables) are not resolved twice.
+
2010-05-16 Daniel Franke <franke.daniel@gmail.com>
PR fortran/35779
return FAILURE;
}
}
+
+ /* Constraints on polymorphic variables. */
+ if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym))
+ {
+ /* F03:C502. */
+ 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->components->ts.u.derived->name,
+ sym->name, &sym->declared_at);
+ return FAILURE;
+ }
+
+ /* F03:C509. */
+ /* 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);
+ return FAILURE;
+ }
+ }
+
return SUCCESS;
}
&sym->declared_at) == FAILURE)
return FAILURE;
- if (sym->ts.type == BT_CLASS)
- {
- /* C502. */
- 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->components->ts.u.derived->name,
- sym->name, &sym->declared_at);
- return FAILURE;
- }
-
- /* C509. */
- /* 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);
- return FAILURE;
- }
- }
-
/* Assign default initializer. */
if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
&& (!no_init_flag || sym->attr.intent == INTENT_OUT))
gfc_namespace *ns;
gfc_component *c;
+ /* Avoid double resolution of function result symbols. */
+ if ((sym->result || sym->attr.result) && (sym->ns != gfc_current_ns))
+ return;
+
if (sym->attr.flavor == FL_UNKNOWN)
{
--- /dev/null
+! { dg-do compile }
+!
+! PR 44044: [OOP] SELECT TYPE with class-valued function
+! comment #1
+!
+! Note: All three error messages are being checked for double occurrence,
+! using the trick from PR 30612.
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+
+implicit none
+
+type :: t
+end type
+
+type :: s
+ sequence
+end type
+
+contains
+
+ function fun() ! { dg-bogus "must be dummy, allocatable or pointer.*must be dummy, allocatable or pointer" }
+ class(t) :: fun
+ end function
+
+ function fun2() ! { dg-bogus "cannot have a deferred shape.*cannot have a deferred shape" }
+ integer,dimension(:) :: fun2
+ end function
+
+ function fun3() result(res) ! { dg-bogus "is not extensible.*is not extensible" }
+ class(s),pointer :: res
+ end function
+
+end
+
+
+! { dg-error "must be dummy, allocatable or pointer" "" { target *-*-* } 23 }
+! { dg-error "cannot have a deferred shape" "" { target *-*-* } 27 }
+! { dg-error "is not extensible" "" { target *-*-* } 31 }