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;
|| sym->attr.dummy)
return;
+ if (sym->error)
+ return;
+
if (sym->binding_label)
sym_name = sym->binding_label;
else if (sym->attr.use_rename
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 *,
}
-static int
-symbol_rank (gfc_symbol *sym)
+int
+gfc_symbol_rank (gfc_symbol *sym)
{
gfc_array_spec *as = NULL;
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;
}
}
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;
}
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)
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;
}
/* 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))
}
/* 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
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;
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;
else
strlen = 1;
- if (symbol_rank (sym) == 0)
+ if (gfc_symbol_rank (sym) == 0)
{
*size_known = true;
return strlen;
/* 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);
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
|| 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;
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)))
"global identifier as entity at %L", sym->name,
sym->binding_label, &sym->declared_at, &gsym->where);
sym->binding_label = NULL;
+ return;
}
}
! { dg-do run }
+! { dg-additional-options "-Wno-pedantic" }
! { dg-additional-sources PR100906.c }
!
! Test the fix for PR100906
! { dg-do run }
! { dg-additional-sources PR100911.c }
+! { dg-additional-options -Wno-pedantic }
!
! Test the fix for PR100911
!
! { dg-do run }
! { dg-additional-sources PR100915.c }
+! { dg-additional-options "-Wno-pedantic" }
!
! Test the fix for PR100915
!
! { dg-do run }
! { dg-additional-sources PR94327.c }
+! { dg-additional-options -Wno-pedantic }
!
! Test the fix for PR94327
!
! { dg-do run }
! { dg-additional-sources PR94331.c }
+! { dg-additional-options "-Wno-pedantic" }
!
! Test the fix for PR94331
!
! 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" }
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
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
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
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
! { 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" }
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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
! { 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
! { 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
projects / thirdparty / gcc.git / commitdiff
