https://gcc.gnu.org/g:8b40209e48c8212ad870724b83718ed244bdf6eb
commit r17-514-g8b40209e48c8212ad870724b83718ed244bdf6eb Author: Thomas Koenig <[email protected]> Date: Thu May 14 16:59:11 2026 +0200 PR fortran/125092 - implement 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: PR fortran/125092 * 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: PR fortran/125092 * 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: --- gcc/fortran/decl.cc | 2 +- gcc/fortran/frontend-passes.cc | 3 + gcc/fortran/gfortran.h | 1 + gcc/fortran/interface.cc | 28 +-- gcc/fortran/resolve.cc | 190 ++++++++++++++++++++- gcc/testsuite/gfortran.dg/PR100906.f90 | 1 + gcc/testsuite/gfortran.dg/PR100911.f90 | 1 + gcc/testsuite/gfortran.dg/PR100915.f90 | 1 + gcc/testsuite/gfortran.dg/PR94327.f90 | 1 + gcc/testsuite/gfortran.dg/PR94331.f90 | 1 + gcc/testsuite/gfortran.dg/bind_c_procs_4.f90 | 4 +- .../gfortran.dg/binding_label_tests_25.f90 | 16 +- .../gfortran.dg/binding_label_tests_3.f03 | 4 +- .../gfortran.dg/binding_label_tests_34.f90 | 8 +- .../gfortran.dg/binding_label_tests_36.f90 | 46 +++++ .../gfortran.dg/binding_label_tests_37.f90 | 127 ++++++++++++++ gcc/testsuite/gfortran.dg/c_char_tests_4.f90 | 1 + gcc/testsuite/gfortran.dg/c_char_tests_5.f90 | 2 +- 18 files changed, 401 insertions(+), 36 deletions(-) diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc index 5d194635ad6f..166b10d4cd42 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 fa508794e204..1ea84198d62f 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 7b55442aa50b..37a8582e36d8 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -4133,6 +4133,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 d25cf0591b7f..8ab2fade283e 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 0db362758636..6d2ebed813f5 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -14903,6 +14903,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 @@ -14919,7 +15047,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; @@ -14933,6 +15078,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))) @@ -14992,6 +15179,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 f6cb3af6d8a6..d848b904069a 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 69f485b59de2..c9b4ff590b9f 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 64a2a88fe2da..03f218078151 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 3cb3ac3dda18..d6bb7f61710a 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 6185031afc57..89976e7b0efa 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 407d8bb9afc8..5f38706ab15e 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 0769eb05de1f..65ec55af8f90 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 429fa0b0e840..7ef0612ecd2d 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 f4f18626ed88..9f24388544a2 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 000000000000..03a151469655 --- /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 000000000000..64873d548323 --- /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 512948a2a3f8..b745c2309acc 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 c7a1c6e8c2bc..8a8368c43be4 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
