+2019-08-15 Thomas Koenig <tkoenig@gcc.gnu.org>
+
+ PR fortran/91443
+ * frontend-passes.c (check_externals_expr): New function.
+ (check_externals_code): New function.
+ (gfc_check_externals): New function.
+ * gfortran.h (debug): Add prototypes for gfc_symbol * and
+ gfc_expr *.
+ (gfc_check_externals): Add prototype.
+ * interface.c (compare_actual_formal): Do not complain about
+ alternate returns if the formal argument is optional.
+ (gfc_procedure_use): Handle cases when an error has been issued
+ previously. Break long line.
+ * parse.c (gfc_parse_file): Call gfc_check_externals for all
+ external procedures.
+ * resolve.c (resolve_global_procedure): Remove checking of
+ argument list.
+
2019-08-13 Steven G. Kargl <kargl@gcc.gnu.org>
PR fortran/87991
2019-08-13 Steven G. Kargl <kargl@gcc.gnu.org>
PR fortran/88072
- * misc.c (gfc_typename): Do not point to something that ought not to
+ * misc.c (gfc_typename): Do not point to something that ought not to
be pointed at.
2013-08-13 Thomas Koenig <tkoenig@gcc.gnu.org>
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
}
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);
+}
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);
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 */
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
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] != '%')
{
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;
}
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;
}
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;
}
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;
}
{
gfc_error ("Assumed-rank argument requires an explicit interface "
"at %L", &a->expr->where);
+ a->expr->error = 1;
return false;
}
}
/* 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;
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;
" %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:
/* 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
/* 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)
+2019-08-15 Thomas Koenig <tkoenig@gcc.gnu.org>
+
+ PR fortran/91443
+ * gfortran.dg/argument_checking_19.f90: New test.
+ * gfortran.dg/altreturn_10.f90: Change dg-warning to dg-error.
+ * gfortran.dg/dec_union_11.f90: Add -std=legacy.
+ * gfortran.dg/hollerith8.f90: Likewise. Remove warning for
+ Hollerith constant.
+ * gfortran.dg/integer_exponentiation_2.f90: New subroutine gee_i8;
+ use it to avoid type mismatches.
+ * gfortran.dg/pr41011.f: Add -std=legacy.
+ * gfortran.dg/whole_file_1.f90: Change warnings to errors.
+ * gfortran.dg/whole_file_2.f90: Likewise.
+
2019-08-15 Richard Biener <rguenther@suse.de>
PR tree-optimization/91445
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
--- /dev/null
+! { dg-do compile }
+! PR 91443 - this was not caught.
+module x
+contains
+ subroutine a
+ call foo(1) ! { dg-error "Type mismatch in argument" }
+ end subroutine a
+end module x
+
+subroutine foo(a)
+ real :: a
+ print *,a
+end subroutine foo
+
+program main
+ use x
+ call a
+end program main
! { 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.
! { 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
& outstr.ne."48454C4C 4F20594F 55202020") STOP 1
return
end
-! { dg-warning "Hollerith constant" "" { target *-*-* } 6 }
-! { dg-warning "Rank mismatch" "" { target *-*-* } 6 }
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)
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
! { 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,
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
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
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)
projects / gcc.git / commitdiff