+2009-04-22 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/39735
+ * decl.c (add_hidden_procptr_result): Bugfix for procptr results.
+ (match_procedure_decl): Set if_source.
+ * expr.c (gfc_check_pointer_assign): Bugfix: Return after error.
+ And: Check interface also for IFSRC_UNKNOWN (return type may be known).
+ * gfortran.h (typedef enum ifsrc): Remove IFSRC_USAGE,
+ add documentation. Rename copy_formal_args and copy_formal_args_intr.
+ * interface.c (gfc_compare_interfaces): Check for return types,
+ handle IFSRC_UNKNOWN.
+ (compare_intr_interfaces,compare_actual_formal_intr): Obsolete, removed.
+ (gfc_procedure_use): Modified handling of intrinsics.
+ * intrinsic.c (add_functions): Bugfix for "dim".
+ * resolve.c (resolve_intrinsic): New function to resolve intrinsics,
+ which copies the interface from isym to sym.
+ (resolve_procedure_expression,resolve_function): Use new function
+ 'resolve_intrinsic'.
+ (resolve_symbol): Add function attribute for externals with return type
+ and use new function 'resolve_intrinsic'.
+ * symbol.c (ifsrc_types): Remove string for IFSRC_USAGE.
+ (copy_formal_args): Renamed to gfc_copy_formal_args.
+ (copy_formal_args_intr): Renamed to gfc_copy_formal_args_intr.
+ * trans-const.c (gfc_conv_const_charlen): Handle cl==NULL.
+
2009-04-21 Joseph Myers <joseph@codesourcery.com>
* ChangeLog, ChangeLog-2002, ChangeLog-2003, ChangeLog-2004,
{
gfc_symtree *stree;
if (case1)
- gfc_get_sym_tree ("ppr@", gfc_current_ns, &stree);
+ gfc_get_sym_tree ("ppr@", gfc_current_ns, &stree);
else if (case2)
- gfc_get_sym_tree ("ppr@", gfc_current_ns->parent, &stree);
+ {
+ gfc_symtree *st2;
+ gfc_get_sym_tree ("ppr@", gfc_current_ns->parent, &stree);
+ st2 = gfc_new_symtree (&gfc_current_ns->sym_root, "ppr@");
+ st2->n.sym = stree->n.sym;
+ }
sym->result = stree->n.sym;
sym->result->attr.proc_pointer = sym->attr.proc_pointer;
}
sym->ts.interface = proc_if;
sym->attr.untyped = 1;
+ sym->attr.if_source = IFSRC_IFBODY;
}
else if (current_ts.type != BT_UNKNOWN)
{
sym->ts.interface->ts = current_ts;
sym->ts.interface->attr.function = 1;
sym->attr.function = sym->ts.interface->attr.function;
+ sym->attr.if_source = IFSRC_UNKNOWN;
}
if (gfc_match (" =>") == MATCH_YES)
gfc_error ("Abstract interface '%s' is invalid "
"in procedure pointer assignment at %L",
rvalue->symtree->name, &rvalue->where);
+ return FAILURE;
}
if (rvalue->expr_type == EXPR_VARIABLE
- && lvalue->symtree->n.sym->attr.if_source != IFSRC_UNKNOWN
&& !gfc_compare_interfaces (lvalue->symtree->n.sym,
rvalue->symtree->n.sym, 0))
{
gfc_access;
/* Flags to keep track of where an interface came from.
- 4 elements = 2 bits. */
+ 3 elements = 2 bits. */
typedef enum ifsrc
-{ IFSRC_UNKNOWN = 0, IFSRC_DECL, IFSRC_IFBODY, IFSRC_USAGE
+{ IFSRC_UNKNOWN = 0, /* Interface unknown, only return type may be known. */
+ IFSRC_DECL, /* FUNCTION or SUBROUTINE declaration. */
+ IFSRC_IFBODY /* INTERFACE statement or PROCEDURE statement
+ with explicit interface. */
}
ifsrc;
gfc_symbol* gfc_get_derived_super_type (gfc_symbol*);
gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, gfc_try*, const char*, bool);
-void copy_formal_args (gfc_symbol *, gfc_symbol *);
-void copy_formal_args_intr (gfc_symbol *, gfc_intrinsic_sym *);
+void gfc_copy_formal_args (gfc_symbol *, gfc_symbol *);
+void gfc_copy_formal_args_intr (gfc_symbol *, gfc_intrinsic_sym *);
void gfc_free_finalizer (gfc_finalizer *el); /* Needed in resolve.c, too */
}
-static int compare_intr_interfaces (gfc_symbol *, gfc_symbol *);
-
/* Given two symbols that are formal arguments, compare their types
and rank and their formal interfaces if they are both dummy
procedures. Returns nonzero if the same, zero if different. */
{
gfc_formal_arglist *f1, *f2;
- if (s2->attr.intrinsic)
- return compare_intr_interfaces (s1, s2);
-
- if (s1->attr.function != s2->attr.function
- || s1->attr.subroutine != s2->attr.subroutine)
- return 0; /* Disagreement between function/subroutine. */
-
- f1 = s1->formal;
- f2 = s2->formal;
-
- if (f1 == NULL && f2 == NULL)
- return 1; /* Special case. */
-
- if (count_types_test (f1, f2))
+ if ((s1->attr.function && !s2->attr.function)
+ || (s1->attr.subroutine && s2->attr.function))
return 0;
- if (count_types_test (f2, f1))
- return 0;
-
- if (generic_flag)
- {
- if (generic_correspondence (f1, f2))
- return 0;
- if (generic_correspondence (f2, f1))
- return 0;
- }
- else
- {
- if (operator_correspondence (f1, f2))
- return 0;
- }
-
- return 1;
-}
-
-
-static int
-compare_intr_interfaces (gfc_symbol *s1, gfc_symbol *s2)
-{
- gfc_formal_arglist *f, *f1;
- gfc_intrinsic_arg *fi, *f2;
- gfc_intrinsic_sym *isym;
-
- isym = gfc_find_function (s2->name);
- if (isym)
- {
- if (!s2->attr.function)
- gfc_add_function (&s2->attr, s2->name, &gfc_current_locus);
- s2->ts = isym->ts;
- }
- else
- {
- isym = gfc_find_subroutine (s2->name);
- gcc_assert (isym);
- if (!s2->attr.subroutine)
- gfc_add_subroutine (&s2->attr, s2->name, &gfc_current_locus);
- }
- if (s1->attr.function != s2->attr.function
- || s1->attr.subroutine != s2->attr.subroutine)
- return 0; /* Disagreement between function/subroutine. */
-
- /* If the arguments are functions, check type and kind. */
-
- if (s1->attr.dummy && s1->attr.function && s2->attr.function)
+ /* If the arguments are functions, check type and kind
+ (only for dummy procedures and procedure pointer assignments). */
+ if ((s1->attr.dummy || s1->attr.proc_pointer)
+ && s1->attr.function && s2->attr.function)
{
- if (s1->ts.type != s2->ts.type)
- return 0;
- if (s1->ts.kind != s2->ts.kind)
+ if (s1->ts.type == BT_UNKNOWN)
+ return 1;
+ if ((s1->ts.type != s2->ts.type) || (s1->ts.kind != s2->ts.kind))
return 0;
if (s1->attr.if_source == IFSRC_DECL)
return 1;
}
- f1 = s1->formal;
- f2 = isym->formal;
-
- /* Special case. */
- if (f1 == NULL && f2 == NULL)
+ if (s1->attr.if_source == IFSRC_UNKNOWN)
return 1;
-
- /* First scan through the formal argument list and check the intrinsic. */
- fi = f2;
- for (f = f1; f; f = f->next)
- {
- if (fi == NULL)
- return 0;
- if ((fi->ts.type != f->sym->ts.type) || (fi->ts.kind != f->sym->ts.kind))
- return 0;
- fi = fi->next;
- }
-
- /* Now scan through the intrinsic argument list and check the formal. */
- f = f1;
- for (fi = f2; fi; fi = fi->next)
- {
- if (f == NULL)
- return 0;
- if ((fi->ts.type != f->sym->ts.type) || (fi->ts.kind != f->sym->ts.kind))
- return 0;
- f = f->next;
- }
-
- return 1;
-}
+ f1 = s1->formal;
+ f2 = s2->formal;
-/* Compare an actual argument list with an intrinsic argument list. */
-
-static int
-compare_actual_formal_intr (gfc_actual_arglist **ap, gfc_symbol *s2)
-{
- gfc_actual_arglist *a;
- gfc_intrinsic_arg *fi, *f2;
- gfc_intrinsic_sym *isym;
-
- isym = gfc_find_function (s2->name);
-
- /* This should already have been checked in
- resolve.c (resolve_actual_arglist). */
- gcc_assert (isym);
+ if (f1 == NULL && f2 == NULL)
+ return 1; /* Special case. */
- f2 = isym->formal;
+ if (count_types_test (f1, f2) || count_types_test (f2, f1))
+ return 0;
- /* Special case. */
- if (*ap == NULL && f2 == NULL)
- return 1;
-
- /* First scan through the actual argument list and check the intrinsic. */
- fi = f2;
- for (a = *ap; a; a = a->next)
+ if (generic_flag)
{
- if (fi == NULL)
+ if (generic_correspondence (f1, f2) || generic_correspondence (f2, f1))
return 0;
- if ((fi->ts.type != a->expr->ts.type)
- || (fi->ts.kind != a->expr->ts.kind))
- return 0;
- fi = fi->next;
}
-
- /* Now scan through the intrinsic argument list and check the formal. */
- a = *ap;
- for (fi = f2; fi; fi = fi->next)
+ else
{
- if (a == NULL)
- return 0;
- if ((fi->ts.type != a->expr->ts.type)
- || (fi->ts.kind != a->expr->ts.kind))
+ if (operator_correspondence (f1, f2))
return 0;
- a = a->next;
}
return 1;
gfc_warning ("Procedure '%s' called with an implicit interface at %L",
sym->name, where);
- if (sym->ts.interface && sym->ts.interface->attr.intrinsic)
- {
- gfc_intrinsic_sym *isym;
- isym = gfc_find_function (sym->ts.interface->name);
- if (isym != NULL)
- {
- if (compare_actual_formal_intr (ap, sym->ts.interface))
- return;
- gfc_error ("Type/rank mismatch in argument '%s' at %L",
- sym->name, where);
- return;
- }
- }
-
if (sym->attr.if_source == IFSRC_UNKNOWN)
{
gfc_actual_arglist *a;
add_sym_2 ("dim", GFC_ISYM_DIM, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
gfc_check_a_p, gfc_simplify_dim, gfc_resolve_dim,
- x, BT_REAL, dr, REQUIRED, y, BT_UNKNOWN, dr, REQUIRED);
+ x, BT_REAL, dr, REQUIRED, y, BT_REAL, dr, REQUIRED);
add_sym_2 ("idim", GFC_ISYM_DIM, CLASS_ELEMENTAL, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77,
NULL, gfc_simplify_dim, gfc_resolve_dim,
}
+/* Resolve an intrinsic procedure: Set its function/subroutine attribute,
+ its typespec and formal argument list. */
+
+static gfc_try
+resolve_intrinsic (gfc_symbol *sym, locus *loc)
+{
+ gfc_intrinsic_sym *isym = gfc_find_function (sym->name);
+ if (isym)
+ {
+ if (!sym->attr.function &&
+ gfc_add_function (&sym->attr, sym->name, loc) == FAILURE)
+ return FAILURE;
+ sym->ts = isym->ts;
+ }
+ else
+ {
+ isym = gfc_find_subroutine (sym->name);
+ gcc_assert (isym);
+ if (!sym->attr.subroutine &&
+ gfc_add_subroutine (&sym->attr, sym->name, loc) == FAILURE)
+ return FAILURE;
+ }
+ if (!sym->formal)
+ gfc_copy_formal_args_intr (sym, isym);
+ return SUCCESS;
+}
+
+
/* Resolve a procedure expression, like passing it to a called procedure or as
RHS for a procedure pointer assignment. */
gcc_assert (expr->symtree);
sym = expr->symtree->n.sym;
+
+ if (sym->attr.intrinsic)
+ resolve_intrinsic (sym, &expr->where);
+
if (sym->attr.flavor != FL_PROCEDURE
|| (sym->attr.function && sym->result == sym))
return SUCCESS;
sym = expr->symtree->n.sym;
if (sym && sym->attr.intrinsic
- && !gfc_find_function (sym->name)
- && gfc_find_subroutine (sym->name)
- && sym->attr.function)
- {
- gfc_error ("Intrinsic subroutine '%s' used as "
- "a function at %L", sym->name, &expr->where);
- return FAILURE;
- }
+ && resolve_intrinsic (sym, &expr->where) == FAILURE)
+ return FAILURE;
if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
{
}
}
+ if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function)
+ gfc_add_function (&sym->attr, sym->name, &sym->declared_at);
+
if (sym->attr.procedure && sym->ts.interface
&& sym->attr.if_source != IFSRC_DECL)
{
gfc_symbol *ifc = sym->ts.interface;
if (ifc->attr.intrinsic)
- {
- gfc_intrinsic_sym *isym = gfc_find_function (sym->ts.interface->name);
- if (isym)
- {
- sym->attr.function = 1;
- sym->ts = isym->ts;
- sym->ts.interface = ifc;
- }
- else
- {
- isym = gfc_find_subroutine (sym->ts.interface->name);
- gcc_assert (isym);
- sym->attr.subroutine = 1;
- }
- copy_formal_args_intr (sym, isym);
- }
- else
- {
- sym->ts = ifc->ts;
- sym->ts.interface = ifc;
- sym->attr.function = ifc->attr.function;
- sym->attr.subroutine = ifc->attr.subroutine;
- copy_formal_args (sym, ifc);
- }
+ resolve_intrinsic (ifc, &ifc->declared_at);
+
+ sym->ts = ifc->ts;
+ sym->ts.interface = ifc;
+ sym->attr.function = ifc->attr.function;
+ sym->attr.subroutine = ifc->attr.subroutine;
+ gfc_copy_formal_args (sym, ifc);
sym->attr.allocatable = ifc->attr.allocatable;
sym->attr.pointer = ifc->attr.pointer;
{
minit ("UNKNOWN", IFSRC_UNKNOWN),
minit ("DECL", IFSRC_DECL),
- minit ("BODY", IFSRC_IFBODY),
- minit ("USAGE", IFSRC_USAGE)
+ minit ("BODY", IFSRC_IFBODY)
};
const mstring save_status[] =
add_formal_arg (head, tail, formal_arg, param_sym);
}
+
/* Add a procedure interface to the given symbol (i.e., store a
reference to the list of formal arguments). */
sym->attr.if_source = source;
}
+
/* Copy the formal args from an existing symbol, src, into a new
symbol, dest. New formal args are created, and the description of
each arg is set according to the existing ones. This function is
args based on the args of a given named interface. */
void
-copy_formal_args (gfc_symbol *dest, gfc_symbol *src)
+gfc_copy_formal_args (gfc_symbol *dest, gfc_symbol *src)
{
gfc_formal_arglist *head = NULL;
gfc_formal_arglist *tail = NULL;
formal_arg->sym->attr = curr_arg->sym->attr;
formal_arg->sym->ts = curr_arg->sym->ts;
formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as);
- copy_formal_args (formal_arg->sym, curr_arg->sym);
+ gfc_copy_formal_args (formal_arg->sym, curr_arg->sym);
/* If this isn't the first arg, set up the next ptr. For the
last arg built, the formal_arg->next will never get set to
gfc_current_ns = parent_ns;
}
+
void
-copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src)
+gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src)
{
gfc_formal_arglist *head = NULL;
gfc_formal_arglist *tail = NULL;
/* May need to copy more info for the symbol. */
formal_arg->sym->ts = curr_arg->ts;
formal_arg->sym->attr.optional = curr_arg->optional;
- /*formal_arg->sym->attr = curr_arg->sym->attr;
- formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as);
- copy_formal_args (formal_arg->sym, curr_arg->sym);*/
/* If this isn't the first arg, set up the next ptr. For the
last arg built, the formal_arg->next will never get set to
gfc_current_ns = parent_ns;
}
+
/* Builds the parameter list for the iso_c_binding procedure
c_f_pointer or c_f_procpointer. The old_sym typically refers to a
generic version of either the c_f_pointer or c_f_procpointer
void
gfc_conv_const_charlen (gfc_charlen * cl)
{
- if (cl->backend_decl)
+ if (!cl || cl->backend_decl)
return;
if (cl->length && cl->length->expr_type == EXPR_CONSTANT)
+2009-04-22 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/39735
+ * gfortran.dg/assumed_charlen_function_5.f90: Modified.
+ * gfortran.dg/external_initializer.f90: Modified.
+ * gfortran.dg/interface_26.f90: Modified.
+ * gfortran.dg/intrinsic_subroutine.f90: Modified.
+ * gfortran.dg/proc_ptr_3.f90: Modified.
+ * gfortran.dg/proc_ptr_15.f90: New.
+ * gfortran.dg/proc_ptr_result_1.f90: Modified.
+
2009-04-21 Manuel Lopez-Ibanez <manu@gcc.gnu.org>
PR c++/35711
character(26), external :: charrext
interface
- integer(4) function test(charr, i)
+ integer(4) function test(charr, i) ! { dg-warning "is obsolescent in fortran 95" }
character(*), external :: charr
integer :: i
end function test
integer :: i
print *, charr(i)
test = 1
-end function test
\ No newline at end of file
+end function test
+
! { dg-do compile }
! PR20849 - An external symbol may not have a initializer.
! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
-REAL, EXTERNAL :: X=0 ! { dg-error "may not have an initializer" }
+REAL, EXTERNAL :: X=0 ! { dg-error "not have an initializer" }
END
END INTERFACE
INTEGER, EXTERNAL :: UserOp
- res = UserFunction( a,b, UserOp )
+ res = UserFunction( a,b, UserOp ) ! { dg-error "Type/rank mismatch in argument" }
if( res .lt. 10 ) then
res = recSum( a, res, UserFunction, UserOp )
implicit none
intrinsic cpu_time
real :: time
-print *, CPU_TIME(TIME) ! { dg-error "Intrinsic subroutine" }
+print *, CPU_TIME(TIME) ! { dg-error "attribute conflicts with" }
end
--- /dev/null
+! { dg-do compile }
+!
+! PR 39735: procedure pointer assignments: return value is not checked
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+implicit none
+procedure(real(4)), pointer :: p1
+procedure(integer), pointer :: p2
+procedure(sub), pointer :: p3
+procedure(), pointer :: p4
+procedure(real(8)),pointer :: p5
+real(4), external, pointer :: p6
+
+! valid
+p2 => iabs
+p3 => sub
+p4 => p2
+p6 => p1
+
+! invalid
+p1 => iabs ! { dg-error "Interfaces don't match" }
+p1 => p2 ! { dg-error "Interfaces don't match" }
+p1 => p5 ! { dg-error "Interfaces don't match" }
+p6 => iabs ! { dg-error "Interfaces don't match" }
+
+contains
+
+ subroutine sub(i)
+ integer :: i
+ end subroutine
+
+end
+
end subroutine sp
end interface
-external :: e1
+real, external :: e1
interface
subroutine e2(a,b)
contains
function j()
+ implicit none
procedure(),pointer :: j
intrinsic iabs
j => iabs
git://gcc.gnu.org / gcc.git / commitdiff