Hello world,
the patch below is regression-tested. OK for trunk?
Best regards
Thomas
PR fortran/125092 - checks for binding label argument mismatch.
This patch implements some checks on different interfaces to the same
C binding functions. It contains a few policy changes, and is somewhat
more permissive than the standard, but there are no constraint
violations (to my knowledge) that it misses.
Apart from checking for standards conformance, this should also
help proof code against (now or future) type-based aliasing mishaps.
Checks for global identifiers are performed on a case-insensitive
basis by default, and only sensitive when -pedantic is in force.
This makes sense if Fortran code wants to interface to "FOO" and
"foo". The restriction to case-insensitive labels comes from a time
when relevant systems had linkers which were case-insensitive, and
it is not possible to implement C (especially the C versions referenced
in the standard) with such a linker.
Return types of functions, ranks, number, type and rank of arguments
are checked. In non-pedantic mode, arguments which have the same
prototype on the C side are permitted, for example passing a scalar
or an array by reference, or arrays of different rank (both for pass
by reference and pass by descriptors). Assumed types are also
assumed to bee OK. This functionality was checked in a few test
cases, so it would make little sense to remove it.
C_PTR is *not* compatible with a random argument passed by reference.
For example, a TYPE(C_PTR), VALUE argument is not compatible
with an INTEGER argument (without VALUE); C_LOC has to be used.
The one-liner in decl.cc may fix some ENTRY problems, I didn't check.
gcc/fortran/ChangeLog:
* decl.cc (add_global_entry): Use string from the heap instead
of a pointer to stack-allocated memory.
* frontend-passes.cc (check_against_globals): If there is an error
already, return early.
* gfortran.h (gfc_symbol_rank): New prototype.
* interface.cc (symbol_rank): Rename to
(gfc_symbol_rank): this.
(gfc_check_dummy_characteristics): Use new function name.
(gfc_check_result_characteristics): Likewise.
(gfc_compare_interfaces): Likewise.
(compare_parameter): Likewise.
(get_sym_storage_size): Likewise.
(gfc_procedure_use): Likewise.
* resolve.cc (decays_to_pointer): New function.
(c_types_conform): New function.
(compare_c_binding_arglists): New function.
(gfc_verify_binding_labels): Check return types and rank
plus argument lists if there is a pre-exisiting global
symbol.
gcc/testsuite/ChangeLog:
* gfortran.dg/PR100906.f90: Add -Wno-pedantic to options.
* gfortran.dg/PR100911.f90: Likewise.
* gfortran.dg/PR100915.f90: Likewise.
* gfortran.dg/PR94327.f90: Likewise.
* gfortran.dg/PR94331.f90: Likewise.
* gfortran.dg/bind_c_procs_4.f90: Add error messages, remove
warning.
* gfortran.dg/binding_label_tests_25.f90: Add error messages.
* gfortran.dg/binding_label_tests_3.f03: Add error messages.
* gfortran.dg/binding_label_tests_34.f90: Add -Wno-pedantic to
options.
* gfortran.dg/c_char_tests_4.f90: Likewise.
* gfortran.dg/c_char_tests_5.f90: Likewise.
* gfortran.dg/binding_label_tests_36.f90: New test.
* gfortran.dg/binding_label_tests_37.f90: New test.
diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index 5d194635ad6..166b10d4cd4 100644
--- a/gcc/fortran/decl.cc
+++ b/gcc/fortran/decl.cc
@@ -8409,7 +8409,7 @@ add_global_entry (const char *name, const char *binding_label, bool sub,
else
{
s->type = type;
- s->sym_name = name;
+ s->sym_name = gfc_get_string ("%s", name);
s->binding_label = binding_label;
s->where = *where;
s->defined = 1;
diff --git a/gcc/fortran/frontend-passes.cc b/gcc/fortran/frontend-passes.cc
index fa508794e20..1ea84198d62 100644
--- a/gcc/fortran/frontend-passes.cc
+++ b/gcc/fortran/frontend-passes.cc
@@ -5884,6 +5884,9 @@ check_against_globals (gfc_symbol *sym)
|| sym->attr.dummy)
return;
+ if (sym->error)
+ return;
+
if (sym->binding_label)
sym_name = sym->binding_label;
else if (sym->attr.use_rename
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index b0ce54e1c21..a41ee627e67 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -4132,6 +4132,7 @@ void gfc_free_interface (gfc_interface *);
void gfc_drop_interface_elements_before (gfc_interface **, gfc_interface *);
bool gfc_compare_derived_types (gfc_symbol *, gfc_symbol *);
bool gfc_compare_types (gfc_typespec *, gfc_typespec *);
+int gfc_symbol_rank (gfc_symbol *);
bool gfc_check_dummy_characteristics (gfc_symbol *, gfc_symbol *,
bool, char *, int);
bool gfc_check_result_characteristics (gfc_symbol *, gfc_symbol *,
diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc
index d25cf0591b7..8ab2fade283 100644
--- a/gcc/fortran/interface.cc
+++ b/gcc/fortran/interface.cc
@@ -1375,8 +1375,8 @@ generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
}
-static int
-symbol_rank (gfc_symbol *sym)
+int
+gfc_symbol_rank (gfc_symbol *sym)
{
gfc_array_spec *as = NULL;
@@ -1420,7 +1420,7 @@ gfc_check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
if (!compare_rank (s1, s2))
{
snprintf (errmsg, err_len, "Rank mismatch in argument '%s' (%i/%i)",
- s1->name, symbol_rank (s1), symbol_rank (s2));
+ s1->name, gfc_symbol_rank (s1), gfc_symbol_rank (s2));
return false;
}
}
@@ -1667,7 +1667,7 @@ gfc_check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2,
if (!compare_rank (r1, r2))
{
snprintf (errmsg, err_len, "Rank mismatch in function result (%i/%i)",
- symbol_rank (r1), symbol_rank (r2));
+ gfc_symbol_rank (r1), gfc_symbol_rank (r2));
return false;
}
@@ -1958,7 +1958,7 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
if (errmsg != NULL)
snprintf (errmsg, err_len, "Rank mismatch in argument "
"'%s' (%i/%i)", f1->sym->name,
- symbol_rank (f1->sym), symbol_rank (f2->sym));
+ gfc_symbol_rank (f1->sym), gfc_symbol_rank (f2->sym));
return false;
}
if ((gfc_option.allow_std & GFC_STD_F2008)
@@ -2477,12 +2477,12 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
return false;
if (ranks_must_agree
- && symbol_rank (formal) != actual->rank
- && symbol_rank (formal) != -1)
+ && gfc_symbol_rank (formal) != actual->rank
+ && gfc_symbol_rank (formal) != -1)
{
if (where)
argument_rank_mismatch (formal->name, &actual->where,
- symbol_rank (formal), actual->rank,
+ gfc_symbol_rank (formal), actual->rank,
NULL);
return false;
}
@@ -2692,7 +2692,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
/* TS29113 C407c; F2018 C711. */
if (actual->ts.type == BT_ASSUMED
- && symbol_rank (formal) == -1
+ && gfc_symbol_rank (formal) == -1
&& actual->rank != -1
&& !(actual->symtree->n.sym->as
&& actual->symtree->n.sym->as->type == AS_ASSUMED_SHAPE))
@@ -2871,7 +2871,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
}
/* If the rank is the same or the formal argument has assumed-rank. */
- if (symbol_rank (formal) == actual->rank || symbol_rank (formal) == -1)
+ if (gfc_symbol_rank (formal) == actual->rank || gfc_symbol_rank (formal) == -1)
return true;
rank_check = where != NULL && !is_elemental && formal_as
@@ -2916,7 +2916,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
where_formal = NULL;
argument_rank_mismatch (formal->name, &actual->where,
- symbol_rank (formal), actual->rank,
+ gfc_symbol_rank (formal), actual->rank,
where_formal);
}
return false;
@@ -3019,7 +3019,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
where_formal = NULL;
argument_rank_mismatch (formal->name, &actual->where,
- symbol_rank (formal), actual->rank,
+ gfc_symbol_rank (formal), actual->rank,
where_formal);
}
return false;
@@ -3052,7 +3052,7 @@ get_sym_storage_size (gfc_symbol *sym, bool *size_known)
else
strlen = 1;
- if (symbol_rank (sym) == 0)
+ if (gfc_symbol_rank (sym) == 0)
{
*size_known = true;
return strlen;
@@ -4639,7 +4639,7 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
/* TS 29113, C407b. */
if (a->expr && a->expr->expr_type == EXPR_VARIABLE
- && symbol_rank (a->expr->symtree->n.sym) == -1)
+ && gfc_symbol_rank (a->expr->symtree->n.sym) == -1)
{
gfc_error ("Assumed-rank argument requires an explicit interface "
"at %L", &a->expr->where);
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index a5d9add9d2f..f0417b4b7e9 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -14877,6 +14877,134 @@ gfc_verify_DTIO_procedures (gfc_symbol *sym)
return;
}
+/* Auxiliary function, checks if an argument decays to a pointer. */
+
+static bool
+decays_to_pointer (gfc_symbol *sym)
+{
+ if (!sym->as)
+ return true;
+
+ if (sym->as->type == AS_ASSUMED_SHAPE)
+ return false;
+
+ if (sym->as->type == AS_ASSUMED_RANK)
+ return false;
+
+ if (sym->as->type == AS_DEFERRED && sym->attr.dummy)
+ return false;
+
+ return true;
+}
+
+/* Helper function, returns true if the types conform according to the C
+ standard, when they are not equal on the Fortran side. If we decide to
+ include or exclude any types from this, this is the place to change. */
+
+static bool
+c_types_conform (gfc_typespec *ts1, gfc_typespec *ts2)
+{
+ if (ts1->type == BT_ASSUMED || ts2->type == BT_ASSUMED)
+ return true;
+
+ if (ts1->kind == ts2->kind
+ && (ts1->type == BT_CHARACTER || ts1->type == BT_INTEGER
+ || ts1->type == BT_UNSIGNED)
+ && (ts2->type == BT_CHARACTER || ts2->type == BT_INTEGER
+ || ts2->type == BT_UNSIGNED))
+ return true;
+
+ return false;
+
+}
+
+/* Check argument lists of BIND(C) procedures against each other, return
+ false if they do not. */
+
+static bool
+compare_c_binding_arglists (gfc_symbol *osym, gfc_symbol *nsym)
+{
+ gfc_formal_arglist *oarg, *narg;
+ bool ret = true;
+ locus *oloc, *nloc;
+
+ oarg = osym->formal;
+ narg = nsym->formal;
+ oloc = &osym->declared_at;
+ nloc = &nsym->declared_at;
+ for ( ; oarg && narg ; oarg = oarg->next, narg = narg->next)
+ {
+ oloc = &oarg->sym->declared_at;
+ nloc = &narg->sym->declared_at;
+
+ if (!gfc_compare_types (&oarg->sym->ts, &narg->sym->ts)
+ && (pedantic || !c_types_conform (&oarg->sym->ts, &narg->sym->ts)))
+ {
+ gfc_error ("Type mismatch in argument %qs at %L (%s/%s) "
+ "originally declared at %L", narg->sym->name,
+ nloc, gfc_typename (&narg->sym->ts),
+ gfc_typename (&oarg->sym->ts), oloc);
+ ret = false;
+ continue;
+ }
+ if (oarg->sym->attr.value != narg->sym->attr.value)
+ {
+ gfc_error ("VALUE attribute mismatch in argument %qs at %L "
+ "originally declared at %L",narg->sym->name,
+ nloc, oloc);
+ ret = false;
+ continue;
+ }
+
+ /* According to the Fortran standard, ranks have to match for arguments.
+ In this case, this makes little sense because both decay to C
+ pointers. Only issue an error if -pedantic or if the argument does
+ not decay to a pointer. Same thing for CFI_desc arrays, which include
+ assumed rank. */
+
+ int orank = gfc_symbol_rank (oarg->sym);
+ int nrank = gfc_symbol_rank (narg->sym);
+ if (orank != nrank && pedantic)
+ {
+ gfc_error ("Rank mismatch in argument %qs (%d/%d) at %L originally "
+ "declared at %L", narg->sym->name, nrank, orank, nloc,
+ oloc);
+ ret = false;
+ continue;
+ }
+
+ /* Confusion between CFI_desc and "normal" arrays. */
+
+ if (decays_to_pointer (oarg->sym) != decays_to_pointer (narg->sym))
+ {
+ gfc_error ("Array specification mismatch in argument %qs at %L "
+ "originally declared at %L", narg->sym->name,
+ nloc, oloc);
+ ret = false;
+ continue;
+ }
+ }
+
+ if (oarg && !narg)
+ {
+ gfc_error ("Not enough arguments for procedure %qs with binding label "
+ "%qs after %L, originally declared at %L", nsym->name,
+ nsym->binding_label, nloc, &oarg->sym->declared_at);
+ ret = false;
+ }
+
+ if (!oarg && narg)
+ {
+ gfc_error ("Too many arguments for procedure %qs with binding label "
+ "%qs at %L, originally declared at %L", nsym->name,
+ nsym->binding_label, &narg->sym->declared_at, oloc);
+ ret = false;
+ }
+
+ return ret;
+}
+
+
/* Verify that any binding labels used in a given namespace do not collide
with the names or binding labels of any global symbols. Multiple INTERFACE
for the same procedure are permitted. Abstract interfaces and dummy
@@ -14893,7 +15021,24 @@ gfc_verify_binding_labels (gfc_symbol *sym)
|| sym->attr.abstract || sym->attr.dummy)
return;
- gsym = gfc_find_case_gsymbol (gfc_gsym_root, sym->binding_label);
+ /* Avoid double error reporting. */
+ if (sym->error)
+ return;
+
+ /* TODO: Check the names of reserved external C identifiers here, see
+ PR 125251. */
+
+ /* According to the Fortran standard, global identifiers are case
+ insensitive, which also holds for C identifiers. This was probably done
+ for systems which had case-insensitive linkers. Such systems could not
+ accomodate the C standards referenced, so this restriction makes little
+ sense for modern systems. Therefore, check case-sensitive labels unless
+ -pedantic is in force. */
+
+ if (pedantic)
+ gsym = gfc_find_case_gsymbol (gfc_gsym_root, sym->binding_label);
+ else
+ gsym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
if (sym->module)
module = sym->module;
@@ -14907,6 +15052,48 @@ gfc_verify_binding_labels (gfc_symbol *sym)
else
module = NULL;
+ if (gsym)
+ {
+ if (gsym->type == GSYM_FUNCTION || gsym->type == GSYM_SUBROUTINE)
+ {
+ gfc_symbol *global_sym;
+ gfc_find_symbol (gsym->sym_name, gsym->ns, 0, &global_sym);
+ gcc_assert (global_sym);
+
+ /* If subroutines and functions are conflated, there is little point
+ in continuing checks. */
+ if ((sym->attr.function && gsym->type == GSYM_SUBROUTINE)
+ || (sym->attr.subroutine && gsym->type == GSYM_FUNCTION))
+ {
+ gfc_global_used (gsym, &sym->declared_at);
+ sym->binding_label = NULL;
+ sym->error = 1;
+ return;
+ }
+
+ if (gsym->type == GSYM_FUNCTION && sym->attr.function
+ && !gfc_compare_types (&sym->ts, &global_sym->ts))
+ {
+ gfc_error ("Return type mismatch of function %qs with binding "
+ "label %qs at %L (%s/%s), originally declared at %L",
+ sym->name, sym->binding_label,
+ &sym->declared_at,
+ gfc_typename (&sym->ts),
+ gfc_typename (&global_sym->ts),
+ &gsym->where);
+ sym->binding_label = NULL;
+ sym->error = 1;
+ return;
+ }
+ if (!compare_c_binding_arglists (global_sym, sym))
+ {
+ sym->binding_label = NULL;
+ sym->error = 1;
+ return;
+ }
+ }
+ }
+
if (!gsym
|| (!gsym->defined
&& (gsym->type == GSYM_FUNCTION || gsym->type == GSYM_SUBROUTINE)))
@@ -14966,6 +15153,7 @@ gfc_verify_binding_labels (gfc_symbol *sym)
"global identifier as entity at %L", sym->name,
sym->binding_label, &sym->declared_at, &gsym->where);
sym->binding_label = NULL;
+ return;
}
}
diff --git a/gcc/testsuite/gfortran.dg/PR100906.f90 b/gcc/testsuite/gfortran.dg/PR100906.f90
index f6cb3af6d8a..d848b904069 100644
--- a/gcc/testsuite/gfortran.dg/PR100906.f90
+++ b/gcc/testsuite/gfortran.dg/PR100906.f90
@@ -1,4 +1,5 @@
! { dg-do run }
+! { dg-additional-options "-Wno-pedantic" }
! { dg-additional-sources PR100906.c }
!
! Test the fix for PR100906
diff --git a/gcc/testsuite/gfortran.dg/PR100911.f90 b/gcc/testsuite/gfortran.dg/PR100911.f90
index 69f485b59de..c9b4ff590b9 100644
--- a/gcc/testsuite/gfortran.dg/PR100911.f90
+++ b/gcc/testsuite/gfortran.dg/PR100911.f90
@@ -1,5 +1,6 @@
! { dg-do run }
! { dg-additional-sources PR100911.c }
+! { dg-additional-options -Wno-pedantic }
!
! Test the fix for PR100911
!
diff --git a/gcc/testsuite/gfortran.dg/PR100915.f90 b/gcc/testsuite/gfortran.dg/PR100915.f90
index 64a2a88fe2d..03f21807815 100644
--- a/gcc/testsuite/gfortran.dg/PR100915.f90
+++ b/gcc/testsuite/gfortran.dg/PR100915.f90
@@ -1,5 +1,6 @@
! { dg-do run }
! { dg-additional-sources PR100915.c }
+! { dg-additional-options "-Wno-pedantic" }
!
! Test the fix for PR100915
!
diff --git a/gcc/testsuite/gfortran.dg/PR94327.f90 b/gcc/testsuite/gfortran.dg/PR94327.f90
index 3cb3ac3dda1..d6bb7f61710 100644
--- a/gcc/testsuite/gfortran.dg/PR94327.f90
+++ b/gcc/testsuite/gfortran.dg/PR94327.f90
@@ -1,5 +1,6 @@
! { dg-do run }
! { dg-additional-sources PR94327.c }
+! { dg-additional-options -Wno-pedantic }
!
! Test the fix for PR94327
!
diff --git a/gcc/testsuite/gfortran.dg/PR94331.f90 b/gcc/testsuite/gfortran.dg/PR94331.f90
index 6185031afc5..89976e7b0ef 100644
--- a/gcc/testsuite/gfortran.dg/PR94331.f90
+++ b/gcc/testsuite/gfortran.dg/PR94331.f90
@@ -1,5 +1,6 @@
! { dg-do run }
! { dg-additional-sources PR94331.c }
+! { dg-additional-options "-Wno-pedantic" }
!
! Test the fix for PR94331
!
diff --git a/gcc/testsuite/gfortran.dg/bind_c_procs_4.f90 b/gcc/testsuite/gfortran.dg/bind_c_procs_4.f90
index 407d8bb9afc..5f38706ab15 100644
--- a/gcc/testsuite/gfortran.dg/bind_c_procs_4.f90
+++ b/gcc/testsuite/gfortran.dg/bind_c_procs_4.f90
@@ -3,15 +3,15 @@
! Contributed by G.Steinmetz
function f() result(n) bind(c) ! { dg-error "not C interoperable" }
+ ! { dg-error "Return type mismatch" "" { target "*-*-*" } .-1 }
class(*), allocatable :: n
end
program p
interface
- function f() result(n) bind(c)
+ function f() result(n) bind(c) ! { dg-error "Return type mismatch" }
integer :: n
end
end interface
if ( f() /= 0 ) stop
end
-! { dg-prune-output "Type mismatch" }
diff --git a/gcc/testsuite/gfortran.dg/binding_label_tests_25.f90 b/gcc/testsuite/gfortran.dg/binding_label_tests_25.f90
index 0769eb05de1..65ec55af8f9 100644
--- a/gcc/testsuite/gfortran.dg/binding_label_tests_25.f90
+++ b/gcc/testsuite/gfortran.dg/binding_label_tests_25.f90
@@ -11,7 +11,7 @@ module m_odbc_if
implicit none
interface sql_set_env_attr
- function sql_set_env_attr_int( input_handle,attribute,value,length ) &
+ function sql_set_env_attr_int( input_handle,attribute,value,length ) & ! { dg-error "Type mismatch" }
result(res) bind(C,name="SQLSetEnvAttr")
use, intrinsic :: iso_c_binding
implicit none
@@ -21,7 +21,7 @@ module m_odbc_if
integer(c_int), value :: length
integer(c_short) :: res
end function
- function sql_set_env_attr_ptr( input_handle,attribute,value,length ) &
+ function sql_set_env_attr_ptr( input_handle,attribute,value,length ) & ! { dg-error "Type mismatch" }
result(res) bind(C,name="SQLSetEnvAttr")
use, intrinsic :: iso_c_binding
implicit none
@@ -38,24 +38,16 @@ module graph_partitions
use,intrinsic :: iso_c_binding
interface Cfun
- subroutine cfunc1 (num, array) bind(c, name="Cfun")
+ subroutine cfunc1 (num, array) bind(c, name="Cfun") ! { dg-error "Type mismatch" }
import :: c_int
integer(c_int),value :: num
integer(c_int) :: array(*) ! <<< HERE: int[]
end subroutine cfunc1
- subroutine cfunf2 (num, array) bind(c, name="Cfun")
+ subroutine cfunf2 (num, array) bind(c, name="Cfun") ! { dg-error "Type mismatch" }
import :: c_int, c_ptr
integer(c_int),value :: num
type(c_ptr),value :: array ! <<< HERE: void*
end subroutine cfunf2
end interface
end module graph_partitions
-
-program test
- use graph_partitions
- integer(c_int) :: a(100)
-
- call Cfun (1, a)
- call Cfun (2, C_NULL_PTR)
-end program test
diff --git a/gcc/testsuite/gfortran.dg/binding_label_tests_3.f03 b/gcc/testsuite/gfortran.dg/binding_label_tests_3.f03
index 429fa0b0e84..7ef0612ecd2 100644
--- a/gcc/testsuite/gfortran.dg/binding_label_tests_3.f03
+++ b/gcc/testsuite/gfortran.dg/binding_label_tests_3.f03
@@ -2,14 +2,14 @@
program main
use iso_c_binding
interface
- subroutine p1(f, a1, a2, a3, a4) bind(c, name='printf') ! Doubtful use ...
+ subroutine p1(f, a1, a2, a3, a4) bind(c, name='printf') ! { dg-error "Type mismatch" }
import :: c_ptr, c_int, c_double
type(c_ptr), value :: f
integer(c_int), value :: a1, a3
real(c_double), value :: a2, a4
end subroutine p1
- subroutine p2(f, a1, a2, a3, a4) bind(c, name='printf') ! ... with incompatible interfaces
+ subroutine p2(f, a1, a2, a3, a4) bind(c, name='printf') ! { dg-error "Type mismatch" }
import :: c_ptr, c_int, c_double
type(c_ptr), value :: f
real(c_double), value :: a1, a3
diff --git a/gcc/testsuite/gfortran.dg/binding_label_tests_34.f90 b/gcc/testsuite/gfortran.dg/binding_label_tests_34.f90
index f4f18626ed8..9f24388544a 100644
--- a/gcc/testsuite/gfortran.dg/binding_label_tests_34.f90
+++ b/gcc/testsuite/gfortran.dg/binding_label_tests_34.f90
@@ -1,13 +1,15 @@
! { dg-do compile }
+! { dg-options "-pedantic" }
! PR 94737 - global symbols are case-insensitive; an error should be
! reported if they match (see F2018, 9.2, paragraph 2). Original
! test case by Lee Busby.
+! Modified because this catches
module foo
interface
-function func1(ii) result (k) bind(c, name="c_func")
- integer :: ii
+ function func1(ii) result (k) bind(c, name="c_func") ! { dg-error "Global binding name" }
+ integer :: ii
integer :: k
end function func1
subroutine sub1(ii,jj) bind(c, name="c_Func") ! { dg-error "Global binding name" }
@@ -20,6 +22,6 @@ contains
function func2(ii) result (k)
integer :: ii
integer :: k
- k = func1(ii) ! { dg-error "Global binding name" }
+ k = func1(ii)
end function func2
end module foo
diff --git a/gcc/testsuite/gfortran.dg/binding_label_tests_36.f90 b/gcc/testsuite/gfortran.dg/binding_label_tests_36.f90
new file mode 100644
index 00000000000..03a15146965
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/binding_label_tests_36.f90
@@ -0,0 +1,46 @@
+! { dg-do compile }
+! { dg-options -Wno-pedantic }
+! Special checks which are disabled without -pedantic.
+
+module api
+ implicit none
+
+ ! Case insensitivity with different names.
+
+ interface
+ subroutine s9(a) bind(c, name="Quuux")
+ use, intrinsic :: iso_c_binding, only : c_int
+ integer(c_int) :: a
+ end subroutine s9
+ end interface
+
+ interface
+ subroutine s10() bind(c, name="quuux")
+ end subroutine s10
+ end interface
+
+ interface
+ subroutine s11(a, n) bind(c, name="bla")
+ use, intrinsic :: iso_c_binding, only : c_int
+ integer(c_int), value :: n
+ integer(c_int) :: a
+ end subroutine s11
+ end interface
+
+ interface
+ subroutine s12(a, n) bind(c, name="bla")
+ use, intrinsic :: iso_c_binding, only : c_int
+ integer(c_int), value :: n
+ integer(c_int), dimension(*) :: a
+ end subroutine s12
+ end interface
+
+ interface
+ subroutine s13(a, n) bind(c, name="bla")
+ use, intrinsic :: iso_c_binding, only : c_int
+ integer(c_int), value :: n
+ integer(c_int), dimension(n) :: a
+ end subroutine s13
+ end interface
+
+end module
diff --git a/gcc/testsuite/gfortran.dg/binding_label_tests_37.f90 b/gcc/testsuite/gfortran.dg/binding_label_tests_37.f90
new file mode 100644
index 00000000000..64873d54832
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/binding_label_tests_37.f90
@@ -0,0 +1,127 @@
+! { dg-do compile }
+module api
+ implicit none
+
+ interface
+ function f1(a) result(istat) & ! { dg-error "Type mismatch in argument" }
+ bind(c, name="foo")
+ use, intrinsic :: iso_c_binding, only :c_int
+ implicit none
+ integer(kind=c_int) :: a
+ integer(kind=c_int) :: istat
+ end function
+ end interface
+
+ interface
+ function f2(a) result(istat) & ! { dg-error "Type mismatch in argument" }
+ bind(c, name="foo")
+ use, intrinsic :: iso_c_binding, only : c_int, c_float
+ implicit none
+ real(kind=c_float) :: a ! integer
+ integer(kind=c_int) :: istat
+ end function
+ end interface
+
+ interface
+ subroutine s3(a) bind(C, name="bar") ! { dg-error "VALUE attribute" }
+ use, intrinsic :: iso_c_binding, only :c_int
+ integer, value :: a
+ end subroutine s3
+ end interface
+
+ interface
+ subroutine s4(a) bind(C, name="bar") ! { dg-error "VALUE attribute" }
+ use, intrinsic :: iso_c_binding, only :c_int
+ integer :: a
+ end subroutine s4
+ end interface
+
+ interface
+ function f5 (a) result(istat) bind(c, name="qux") ! { dg-error "Return type mismatch" }
+ use, intrinsic :: iso_c_binding, only : c_intptr_t, c_int
+ implicit none
+ integer(kind=c_intptr_t) :: a ! integer
+ integer(kind=c_int) :: istat
+ end function f5
+ end interface
+
+ interface
+ function f6(a) result(istat) bind(c, name="qux") ! { dg-error "Return type mismatch" }
+ use, intrinsic :: iso_c_binding, only : c_intptr_t, c_float
+ implicit none
+ integer(kind=c_intptr_t) :: a ! integer
+ real(kind=c_float) :: istat
+ end function f6
+ end interface
+
+ interface
+ subroutine s7() bind(c, name="quux") ! { dg-error "Too many arguments" }
+ end subroutine s7
+ end interface
+
+ interface
+ subroutine s8(a) bind(c, name="quux") ! { dg-error "Too many arguments" }
+ use, intrinsic :: iso_c_binding, only : c_int
+ integer(c_int) :: a
+ end subroutine s8
+ end interface
+
+ interface
+ subroutine s9(a) bind(c, name="quuux") ! { dg-error "Too many arguments" }
+ use, intrinsic :: iso_c_binding, only : c_int
+ integer(c_int) :: a
+ end subroutine s9
+ end interface
+
+ interface
+ subroutine s10() bind(c, name="quuux") ! { dg-error "Too many arguments" }
+ end subroutine s10
+ end interface
+
+ ! "bla" check with -pedantic only.
+
+ interface
+ subroutine s11(a, n) bind(c, name="bla") ! { dg-error "Rank mismatch" }
+ use, intrinsic :: iso_c_binding, only : c_int
+ integer(c_int), value :: n
+ integer(c_int) :: a
+ end subroutine s11
+ end interface
+
+ interface
+ subroutine s12(a, n) bind(c, name="bla") ! { dg-error "Rank mismatch" }
+ use, intrinsic :: iso_c_binding, only : c_int
+ integer(c_int), value :: n
+ integer(c_int), dimension(*) :: a
+ end subroutine s12
+ end interface
+
+ interface
+ subroutine s14(a) bind(c, name="blubb") ! { dg-error "Type mismatch in argument" }
+ use, intrinsic :: iso_c_binding, only: c_ptr
+ type(c_ptr), value :: a
+ end subroutine s14
+ end interface
+
+ interface
+ subroutine s15(a) bind(c, name="blubb") ! { dg-error "Type mismatch in argument" }
+ use, intrinsic :: iso_c_binding, only : c_int
+ integer(c_int) :: a
+ end subroutine s15
+ end interface
+
+ interface
+ subroutine s16(a) bind(c, name="blabla") ! { dg-error "Array specification mismatch" }
+ use, intrinsic :: iso_c_binding, only : c_int
+ integer, dimension(:) :: a
+ end subroutine s16
+ end interface
+
+ interface
+ subroutine s17(a) bind(c, name="blabla") ! { dg-error "Array specification mismatch" }
+ use, intrinsic :: iso_c_binding, only : c_int
+ integer, dimension(*) :: a
+ end subroutine s17
+ end interface
+
+end module
diff --git a/gcc/testsuite/gfortran.dg/c_char_tests_4.f90 b/gcc/testsuite/gfortran.dg/c_char_tests_4.f90
index 512948a2a3f..b745c2309ac 100644
--- a/gcc/testsuite/gfortran.dg/c_char_tests_4.f90
+++ b/gcc/testsuite/gfortran.dg/c_char_tests_4.f90
@@ -1,4 +1,5 @@
! { dg-do run }
+! { dg-additional-options "-Wno-pedantic" }
!
! PR fortran/103828
! Check that we can pass many function args as C char, which are interoperable
diff --git a/gcc/testsuite/gfortran.dg/c_char_tests_5.f90 b/gcc/testsuite/gfortran.dg/c_char_tests_5.f90
index c7a1c6e8c2b..8a8368c43be 100644
--- a/gcc/testsuite/gfortran.dg/c_char_tests_5.f90
+++ b/gcc/testsuite/gfortran.dg/c_char_tests_5.f90
@@ -1,5 +1,5 @@
! { dg-do run }
-! { dg-options "-fbackslash" }
+! { dg-options "-fbackslash -Wno-pedantic" }
!
! PR fortran/103828
! Check that we can C char with non-ASCII values, which are interoperable
