===================================================================
@@ -56,7 +56,6 @@ static gfc_expr* check_conjg_transpose_variable (g
static int call_external_blas (gfc_code **, int *, void *);
static int matmul_temp_args (gfc_code **, int *,void *data);
static int index_interchange (gfc_code **, int*, void *);
-
static bool is_fe_temp (gfc_expr *e);
#ifdef CHECKING_P
@@ -5364,3 +5363,100 @@ gfc_code_walker (gfc_code **c, walk_code_fn_t code
}
return 0;
}
+
+/* As a post-resolution step, check that all global symbols which are
+ not declared in the source file match in their call signatures.
+ We do this by looping over the code (and expressions). The first call
+ we happen to find is assumed to be canonical. */
+
+/* Callback for external functions. */
+
+static int
+check_externals_expr (gfc_expr **ep, int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data ATTRIBUTE_UNUSED)
+{
+ gfc_expr *e = *ep;
+ gfc_symbol *sym, *def_sym;
+ gfc_gsymbol *gsym;
+
+ if (e->expr_type != EXPR_FUNCTION)
+ return 0;
+
+ sym = e->value.function.esym;
+
+ if (sym == NULL || sym->attr.is_bind_c)
+ return 0;
+
+ if (sym->attr.proc != PROC_EXTERNAL && sym->attr.proc != PROC_UNKNOWN)
+ return 0;
+
+ gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name);
+ if (gsym == NULL)
+ return 0;
+
+ gfc_find_symbol (sym->name, gsym->ns, 0, &def_sym);
+
+ if (sym && def_sym)
+ gfc_procedure_use (def_sym, &e->value.function.actual, &e->where);
+
+ return 0;
+}
+
+/* Callback for external code. */
+
+static int
+check_externals_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data ATTRIBUTE_UNUSED)
+{
+ gfc_code *co = *c;
+ gfc_symbol *sym, *def_sym;
+ gfc_gsymbol *gsym;
+
+ if (co->op != EXEC_CALL)
+ return 0;
+
+ sym = co->resolved_sym;
+ if (sym == NULL || sym->attr.is_bind_c)
+ return 0;
+
+ if (sym->attr.proc != PROC_EXTERNAL && sym->attr.proc != PROC_UNKNOWN)
+ return 0;
+
+ if (sym->attr.if_source == IFSRC_IFBODY || sym->attr.if_source == IFSRC_DECL)
+ return 0;
+
+ gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name);
+ if (gsym == NULL)
+ return 0;
+
+ gfc_find_symbol (sym->name, gsym->ns, 0, &def_sym);
+
+ if (sym && def_sym)
+ gfc_procedure_use (def_sym, &co->ext.actual, &co->loc);
+
+ return 0;
+}
+
+/* Called routine. */
+
+void
+gfc_check_externals (gfc_namespace *ns)
+{
+
+ gfc_clear_error ();
+
+ /* Turn errors into warnings if -std=legacy is given by the user. */
+
+ if (!pedantic && !(gfc_option.warn_std & GFC_STD_LEGACY))
+ gfc_errors_to_warnings (true);
+
+ gfc_code_walker (&ns->code, check_externals_code, check_externals_expr, NULL);
+
+ for (ns = ns->contained; ns; ns = ns->sibling)
+ {
+ if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
+ gfc_check_externals (ns);
+ }
+
+ gfc_errors_to_warnings (false);
+}
===================================================================
@@ -3477,6 +3477,8 @@ void gfc_dump_parse_tree (gfc_namespace *, FILE *)
void gfc_dump_c_prototypes (gfc_namespace *, FILE *);
void gfc_dump_external_c_prototypes (FILE *);
void gfc_dump_global_symbols (FILE *);
+void debug (gfc_symbol *);
+void debug (gfc_expr *);
/* parse.c */
bool gfc_parse_file (void);
@@ -3551,6 +3553,7 @@ int gfc_dummy_code_callback (gfc_code **, int *, v
int gfc_expr_walker (gfc_expr **, walk_expr_fn_t, void *);
int gfc_code_walker (gfc_code **, walk_code_fn_t, walk_expr_fn_t, void *);
bool gfc_has_dimen_vector_ref (gfc_expr *e);
+void gfc_check_externals (gfc_namespace *);
/* simplify.c */
===================================================================
@@ -2979,10 +2979,15 @@ compare_actual_formal (gfc_actual_arglist **ap, gf
if (a->expr == NULL)
{
- if (where)
- gfc_error_now ("Unexpected alternate return specifier in "
- "subroutine call at %L", where);
- return false;
+ if (f->sym->attr.optional)
+ continue;
+ else
+ {
+ if (where)
+ gfc_error_now ("Unexpected alternate return specifier in "
+ "subroutine call at %L", where);
+ return false;
+ }
}
/* Make sure that intrinsic vtables exist for calls to unlimited
@@ -3723,6 +3728,9 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arg
for (a = *ap; a; a = a->next)
{
+ if (a->expr && a->expr->error)
+ return false;
+
/* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
if (a->name != NULL && a->name[0] != '%')
{
@@ -3738,6 +3746,7 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arg
gfc_error ("Assumed-type argument %s at %L requires an explicit "
"interface", a->expr->symtree->n.sym->name,
&a->expr->where);
+ a->expr->error = 1;
break;
}
@@ -3751,6 +3760,7 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arg
gfc_error ("Actual argument of LOCK_TYPE or with LOCK_TYPE "
"component at %L requires an explicit interface for "
"procedure %qs", &a->expr->where, sym->name);
+ a->expr->error = 1;
break;
}
@@ -3764,6 +3774,7 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arg
gfc_error ("Actual argument of EVENT_TYPE or with EVENT_TYPE "
"component at %L requires an explicit interface for "
"procedure %qs", &a->expr->where, sym->name);
+ a->expr->error = 1;
break;
}
@@ -3770,7 +3781,9 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arg
if (a->expr && a->expr->expr_type == EXPR_NULL
&& a->expr->ts.type == BT_UNKNOWN)
{
- gfc_error ("MOLD argument to NULL required at %L", &a->expr->where);
+ gfc_error ("MOLD argument to NULL required at %L",
+ &a->expr->where);
+ a->expr->error = 1;
return false;
}
@@ -3780,6 +3793,7 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arg
{
gfc_error ("Assumed-rank argument requires an explicit interface "
"at %L", &a->expr->where);
+ a->expr->error = 1;
return false;
}
}
===================================================================
@@ -6319,6 +6319,12 @@ done:
/* Do the resolution. */
resolve_all_program_units (gfc_global_ns_list);
+
+ /* Fixup for external procedures. */
+ for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns;
+ gfc_current_ns = gfc_current_ns->sibling)
+ gfc_check_externals (gfc_current_ns);
+
/* Do the parse tree dump. */
gfc_current_ns = flag_dump_fortran_original ? gfc_global_ns_list : NULL;
===================================================================
@@ -2506,8 +2506,7 @@ gfc_explicit_interface_required (gfc_symbol *sym,
static void
-resolve_global_procedure (gfc_symbol *sym, locus *where,
- gfc_actual_arglist **actual, int sub)
+resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
{
gfc_gsymbol * gsym;
gfc_namespace *ns;
@@ -2615,14 +2614,6 @@ static void
" %s", sym->name, &sym->declared_at, reason);
goto done;
}
-
- if (!pedantic
- || ((gfc_option.warn_std & GFC_STD_LEGACY)
- && !(gfc_option.warn_std & GFC_STD_GNU)))
- gfc_errors_to_warnings (true);
-
- if (sym->attr.if_source != IFSRC_IFBODY)
- gfc_procedure_use (def_sym, actual, where);
}
done:
@@ -3198,8 +3189,7 @@ resolve_function (gfc_expr *expr)
/* If the procedure is external, check for usage. */
if (sym && is_external_proc (sym))
- resolve_global_procedure (sym, &expr->where,
- &expr->value.function.actual, 0);
+ resolve_global_procedure (sym, &expr->where, 0);
if (sym && sym->ts.type == BT_CHARACTER
&& sym->ts.u.cl
@@ -3675,7 +3665,7 @@ resolve_call (gfc_code *c)
/* If external, check for usage. */
if (csym && is_external_proc (csym))
- resolve_global_procedure (csym, &c->loc, &c->ext.actual, 1);
+ resolve_global_procedure (csym, &c->loc, 1);
t = true;
if (c->resolved_sym == NULL)
===================================================================
@@ -14,6 +14,6 @@ subroutine sub (x)
end
subroutine sub2
call sub (*99) ! { dg-error "Unexpected alternate return specifier" }
- call sub (99.) ! { dg-warning "Type mismatch in argument" }
+ call sub (99.) ! { dg-error "Type mismatch in argument" }
99 stop
end
===================================================================
@@ -1,5 +1,5 @@
! { dg-do compile }
-! { dg-options "-g -fdec-structure" }
+! { dg-options "-g -fdec-structure -std=legacy" }
!
! Test a regression where typespecs of unions containing character buffers of
! different lengths where copied, resulting in a bad gimple tree state.
===================================================================
@@ -1,9 +1,9 @@
! { dg-do run }
-! { dg-options "-std=gnu" }
+! { dg-options "-std=legacy" }
! PR43217 Output of Hollerith constants which are not a multiple of 4 bytes
! Test case prepared from OP by Jerry DeLisle <jvdelisle@gcc.gnu.org>
program hello2
- call wrtout (9hHELLO YOU, 9)
+ call wrtout (9hHELLO YOU, 9) ! { dg-warning "Rank mismatch" }
stop
end
@@ -22,5 +22,3 @@ subroutine wrtout (iarray, nchrs)
& outstr.ne."48454C4C 4F20594F 55202020") STOP 1
return
end
-! { dg-warning "Hollerith constant" "" { target *-*-* } 6 }
-! { dg-warning "Rank mismatch" "" { target *-*-* } 6 }
===================================================================
@@ -139,16 +139,16 @@ subroutine foo(a)
call gee_i(i**(-huge(0_4)))
call gee_i(i**(-huge(0_4)-1_4))
- call gee_i(i**0_8) ! { dg-warning "Type mismatch in argument" }
- call gee_i(i**1_8) ! { dg-warning "Type mismatch in argument" }
- call gee_i(i**2_8) ! { dg-warning "Type mismatch in argument" }
- call gee_i(i**3_8) ! { dg-warning "Type mismatch in argument" }
- call gee_i(i**(-1_8)) ! { dg-warning "Type mismatch in argument" }
- call gee_i(i**(-2_8)) ! { dg-warning "Type mismatch in argument" }
- call gee_i(i**(-3_8)) ! { dg-warning "Type mismatch in argument" }
- call gee_i(i**huge(0_8)) ! { dg-warning "Type mismatch in argument" }
- call gee_i(i**(-huge(0_8))) ! { dg-warning "Type mismatch in argument" }
- call gee_i(i**(-huge(0_8)-1_8)) ! { dg-warning "Type mismatch in argument" }
+ call gee_i8(i**0_8)
+ call gee_i8(i**1_8)
+ call gee_i8(i**2_8)
+ call gee_i8(i**3_8)
+ call gee_i8(i**(-1_8))
+ call gee_i8(i**(-2_8))
+ call gee_i8(i**(-3_8))
+ call gee_i8(i**huge(0_8))
+ call gee_i8(i**(-huge(0_8)))
+ call gee_i8(i**(-huge(0_8)-1_8))
! Real
call gee_r(a**0_1)
@@ -245,6 +245,10 @@ subroutine gee_i(i)
integer :: i
end subroutine gee_i
+subroutine gee_i8(i)
+ integer(kind=8) :: i
+end subroutine gee_i8
+
subroutine gee_r(r)
real :: r
end subroutine gee_r
===================================================================
@@ -1,5 +1,5 @@
! { dg-do compile }
-! { dg-options "-O3" }
+! { dg-options "-O3 -std=legacy" }
CALL UVSET(NX,NY,NZ,HVAR,ZET,NP,DZ,DKM,UM,VM,UG,VG,TM,DCDX, ! { dg-warning "Rank mismatch" }
*ITY,ISH,NSMT,F)
CALL DCTDX(NX,NY,NX1,NFILT,C(MLAG),DCDX(MLAG),HELP,HELPA,
===================================================================
@@ -19,7 +19,7 @@ subroutine b
integer :: u1
end type
type (u) :: q
- call a(q) ! { dg-warning "Type mismatch" }
+ call a(q) ! { dg-error "Type mismatch" }
print *, q%u1
end subroutine
@@ -36,7 +36,7 @@ subroutine d
integer :: u1
end type
type (u) :: q
- call c(q) ! { dg-warning "Type mismatch" }
+ call c(q) ! { dg-error "Type mismatch" }
print *, q%u1
end subroutine
===================================================================
@@ -14,8 +14,8 @@ end function
program gg
real :: h
character (5) :: chr = 'hello'
-h = a(); ! { dg-warning "Missing actual argument" }
-call test ([chr]) ! { dg-warning "Rank mismatch" }
+h = a(); ! { dg-error "Missing actual argument" }
+call test ([chr]) ! { dg-error "Rank mismatch" }
end program gg
subroutine test (a)