Paul Thomas <pault@gcc.gnu.org>
PR fortran/30922
* decl.c (gfc_match_import): If the parent of the current name-
space is null, try looking for an imported symbol in the parent
of the proc_name interface.
* resolve.c (resolve_fl_variable): Do not check for blocking of
host association by a same symbol, if the symbol is in an
interface body.
2007-03-15 Paul Thomas <pault@gcc.gnu.org>
PR fortran/30879
* decl.c (match_data_constant): Before going on to try to match
a name, try to match a structure component.
PR fortran/30870
* resolve.c (resolve_actual_arglist): Do not reject a generic
actual argument if it has a same name specific interface.
PR fortran/31163
* trans-array.c (parse_interface): Do not nullify allocatable
components if the symbol has the saved attribute.
2007-03-15 Paul Thomas <pault@gcc.gnu.org>
PR fortran/30922
* gfortran.dg/import5.f90.f90: New test.
PR fortran/30879
* gfortran.dg/data_components_1.f90: New test.
PR fortran/30870
* gfortran.dg/generic_13.f90: New test.
PR fortran/31163
* gfortran.dg/alloc_comp_basics_5.f90: New test.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@122944
138bc75d-0d04-0410-961f-
82ee72b054a4
+2007-03-15 Tobias Burnus <burnus@gcc.gnu.org>
+ Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/30922
+ * decl.c (gfc_match_import): If the parent of the current name-
+ space is null, try looking for an imported symbol in the parent
+ of the proc_name interface.
+ * resolve.c (resolve_fl_variable): Do not check for blocking of
+ host association by a same symbol, if the symbol is in an
+ interface body.
+
+2007-03-15 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/30879
+ * decl.c (match_data_constant): Before going on to try to match
+ a name, try to match a structure component.
+
+
+ PR fortran/30870
+ * resolve.c (resolve_actual_arglist): Do not reject a generic
+ actual argument if it has a same name specific interface.
+
+ PR fortran/31163
+ * trans-array.c (parse_interface): Do not nullify allocatable
+ components if the symbol has the saved attribute.
+
2007-03-14 Francois-Xavier Coudert <coudert@clipper.ens.fr>
* trans-array.c (gfc_trans_auto_array_allocation): Replace
gfc_symbol *sym;
gfc_expr *expr;
match m;
+ locus old_loc;
m = gfc_match_literal_constant (&expr, 1);
if (m == MATCH_YES)
if (m != MATCH_NO)
return m;
+ old_loc = gfc_current_locus;
+
+ /* Should this be a structure component, try to match it
+ before matching a name. */
+ m = gfc_match_rvalue (result);
+ if (m == MATCH_ERROR)
+ return m;
+
+ if (m == MATCH_YES && (*result)->expr_type == EXPR_STRUCTURE)
+ {
+ if (gfc_simplify_expr (*result, 0) == FAILURE)
+ m = MATCH_ERROR;
+ return m;
+ }
+
+ gfc_current_locus = old_loc;
+
m = gfc_match_name (name);
if (m != MATCH_YES)
return m;
switch (m)
{
case MATCH_YES:
- if (gfc_find_symbol (name, gfc_current_ns->parent, 1, &sym))
+ if (gfc_current_ns->parent != NULL
+ && gfc_find_symbol (name, gfc_current_ns->parent,
+ 1, &sym))
+ {
+ gfc_error ("Type name '%s' at %C is ambiguous", name);
+ return MATCH_ERROR;
+ }
+ else if (gfc_current_ns->proc_name->ns->parent != NULL
+ && gfc_find_symbol (name,
+ gfc_current_ns->proc_name->ns->parent,
+ 1, &sym))
{
gfc_error ("Type name '%s' at %C is ambiguous", name);
return MATCH_ERROR;
&e->where);
}
+ /* Check if a generic interface has a specific procedure
+ with the same name before emitting an error. */
if (sym->attr.generic)
{
- gfc_error ("GENERIC non-INTRINSIC procedure '%s' is not "
- "allowed as an actual argument at %L", sym->name,
- &e->where);
+ gfc_interface *p;
+ for (p = sym->generic; p; p = p->next)
+ if (strcmp (sym->name, p->sym->name) == 0)
+ {
+ e->symtree = gfc_find_symtree
+ (p->sym->ns->sym_root, sym->name);
+ sym = p->sym;
+ break;
+ }
+
+ if (p == NULL || e->symtree == NULL)
+ gfc_error ("GENERIC non-INTRINSIC procedure '%s' is not "
+ "allowed as an actual argument at %L", sym->name,
+ &e->where);
}
/* If the symbol is the function that names the current (or
/* Check to see if a derived type is blocked from being host associated
by the presence of another class I symbol in the same namespace.
14.6.1.3 of the standard and the discussion on comp.lang.fortran. */
- if (sym->ts.type == BT_DERIVED && sym->ns != sym->ts.derived->ns)
+ if (sym->ts.type == BT_DERIVED && sym->ns != sym->ts.derived->ns
+ && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
{
gfc_symbol *s;
gfc_find_symbol (sym->ts.derived->name, sym->ns, 0, &s);
if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable))
{
- rank = sym->as ? sym->as->rank : 0;
- tmp = gfc_nullify_alloc_comp (sym->ts.derived, descriptor, rank);
- gfc_add_expr_to_block (&fnblock, tmp);
+ if (!sym->attr.save)
+ {
+ rank = sym->as ? sym->as->rank : 0;
+ tmp = gfc_nullify_alloc_comp (sym->ts.derived, descriptor, rank);
+ gfc_add_expr_to_block (&fnblock, tmp);
+ }
}
else if (!GFC_DESCRIPTOR_TYPE_P (type))
{
/* Allocatable arrays need to be freed when they go out of scope.
The allocatable components of pointers must not be touched. */
if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
- && !sym->attr.pointer)
+ && !sym->attr.pointer && !sym->attr.save)
{
int rank;
rank = sym->as ? sym->as->rank : 0;
+2007-03-15 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/30922
+ * gfortran.dg/import5.f90.f90: New test.
+
+
+ PR fortran/30879
+ * gfortran.dg/data_components_1.f90: New test.
+
+
+ PR fortran/30870
+ * gfortran.dg/generic_13.f90: New test.
+
+ PR fortran/31163
+ * gfortran.dg/alloc_comp_basics_5.f90: New test.
+
2007-03-14 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR libgfortran/31051
--- /dev/null
+! { dg-do run }
+! This checks the correct functioning of derived types with the SAVE
+! attribute and allocatable components - PR31163
+!
+! Contributed by Salvatore Filippone <salvatore.filippone@uniroma2.it>
+!
+Module bar_mod
+
+ type foo_type
+ integer, allocatable :: mv(:)
+ end type foo_type
+
+
+contains
+
+
+ subroutine bar_foo_ab(info)
+
+ integer, intent(out) :: info
+ Type(foo_type), save :: f_a
+
+ if (allocated(f_a%mv)) then
+ info = size(f_a%mv)
+ else
+ allocate(f_a%mv(10),stat=info)
+ if (info /= 0) then
+ info = -1
+ endif
+ end if
+ end subroutine bar_foo_ab
+
+
+end module bar_mod
+
+program tsave
+ use bar_mod
+
+ integer :: info
+
+ call bar_foo_ab(info)
+ if (info .ne. 0) call abort ()
+ call bar_foo_ab(info)
+ if (info .ne. 10) call abort ()
+
+end program tsave
+
+! { dg-final { cleanup-modules "bar_mod" } }
--- /dev/null
+! { dg-do compile }
+! Check the fix for PR30879, in which the structure
+! components in the DATA values would cause a syntax
+! error.
+!
+! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
+!
+ TYPE T1
+ INTEGER :: I
+ END TYPE T1
+
+ TYPE(T1), PARAMETER :: D1=T1(2)
+ TYPE(T1) :: D2(2)
+
+ INTEGER :: a(2)
+
+ DATA (a(i),i=1,D1%I) /D1%I*D1%I/
+
+ DATA (D2(i),i=1,D1%I) /D1%I*T1(4)/
+
+ print *, a
+ print *, D2
+ END
--- /dev/null
+! { dg-do compile }
+! tests the patch for PR30870, in which the generic XX was rejected
+! because the specific with the same name was not looked for.
+!
+! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
+!
+MODULE TEST
+ INTERFACE xx
+ MODULE PROCEDURE xx
+ END INTERFACE
+ public :: xx
+CONTAINS
+ SUBROUTINE xx(i)
+ INTEGER :: I
+ I=7
+ END SUBROUTINE
+END
+MODULE TOO
+CONTAINS
+ SUBROUTINE SUB(xx,I)
+ INTERFACE
+ SUBROUTINE XX(I)
+ INTEGER :: I
+ END SUBROUTINE
+ END INTERFACE
+ CALL XX(I)
+ END SUBROUTINE
+END MODULE TOO
+PROGRAM TT
+ USE TEST
+ USE TOO
+ INTEGER :: I
+ CALL SUB(xx,I)
+ IF (I.NE.7) CALL ABORT()
+END PROGRAM
+! { dg-final { cleanup-modules "test too" } }
--- /dev/null
+! { dg-do compile }
+! Test for import in interfaces PR fortran/30922
+!
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+!
+module test_import
+ implicit none
+
+ type :: my_type
+ integer :: data
+ end type my_type
+ integer, parameter :: n = 20
+
+ interface
+ integer function func1(param)
+ import
+ type(my_type) :: param(n)
+ end function func1
+
+ integer function func2(param)
+ import :: my_type
+ type(my_type), value :: param
+ end function func2
+ end interface
+
+contains
+
+ subroutine sub1 ()
+
+ interface
+ integer function func3(param)
+ import
+ type(my_type), dimension (n) :: param
+ end function func3
+
+ integer function func4(param)
+ import :: my_type, n
+ type(my_type), dimension (n) :: param
+ end function func4
+ end interface
+
+ end subroutine sub1
+end module test_import
+! { dg-final { cleanup-modules "test_import" } }
OSDN Git Service
