https://gcc.gnu.org/g:c158f36027c316aedaa7bde83ca28a3365721fce
commit r15-6967-gc158f36027c316aedaa7bde83ca28a3365721fce
Author: Thomas Koenig <tkoe...@gcc.gnu.org>
Date: Wed Jan 8 17:06:31 2025 +0100
Allow CFI_cdesc_t in argument lists with -fc-prototypes.
This patch fixes and reorganizes dumping C prototypes. It makes the
following
changes:
- BIND(C) types are now always output before any global symbols
- CFI_cdesc_t is issued for assumed shape and assumed rank
arguments.
- BIND(C,NAME="...") entities were not always issued.
gcc/fortran/ChangeLog:
PR fortran/118359
* dump-parse-tree.cc (show_external_symbol): New function.
(write_type): Add prototype, put in restrictions on what not to
dump.
(has_cfi_cdesc): New function.
(need_iso_fortran_binding): New function.
(gfc_dump_c_prototypes): Adjust to take only a file output. Add
"#include <ISO_Fortran_binding.h" if CFI_cdesc_t is found.
Traverse global namespaces to dump types and the globalsymol list
to dump external symbols.
(gfc_dump_external_c_prototypes): Traverse global namespaces.
(get_c_type_name): Handle CFI_cdesc_t.
(write_proc): Also pass array spec to get_c_type_name.
* gfortran.h (gfc_dump_c_prototypes): Adjust prototype.
* parse.cc (gfc_parse_file): Adjust call to gfc_dump_c_prototypes.
Diff:
---
gcc/fortran/dump-parse-tree.cc | 154 +++++++++++++++++++++++++++++++++++------
gcc/fortran/gfortran.h | 2 +-
gcc/fortran/parse.cc | 6 +-
3 files changed, 136 insertions(+), 26 deletions(-)
diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc
index 0f983e98a5ec..0ae135058767 100644
--- a/gcc/fortran/dump-parse-tree.cc
+++ b/gcc/fortran/dump-parse-tree.cc
@@ -4015,27 +4015,93 @@ gfc_dump_parse_tree (gfc_namespace *ns, FILE *file)
show_namespace (ns);
}
-/* This part writes BIND(C) definition for use in external C programs. */
+/* This part writes BIND(C) prototypes and declatations, and prototypes
+ for EXTERNAL preocedures, for use in a C programs. */
static void write_interop_decl (gfc_symbol *);
static void write_proc (gfc_symbol *, bool);
+static void show_external_symbol (gfc_gsymbol *, void *);
+static void write_type (gfc_symbol *sym);
+
+/* Do we need to write out an #include <ISO_Fortran_binding.h> or not? */
+
+static void
+has_cfi_cdesc (gfc_gsymbol *gsym, void *p)
+{
+ bool *data_p = (bool *) p;
+ gfc_formal_arglist *f;
+ gfc_symbol *sym;
+
+ if (*data_p)
+ return;
+
+ if (gsym->ns == NULL || gsym->sym_name == NULL )
+ return;
+
+ gfc_find_symbol (gsym->sym_name, gsym->ns, 0, &sym);
+
+ if (sym == NULL || sym->attr.flavor != FL_PROCEDURE || !sym->attr.is_bind_c)
+ return;
+
+ for (f = sym->formal; f; f = f->next)
+ {
+ gfc_symbol *s;
+ s = f->sym;
+ if (s->as && (s->as->type == AS_ASSUMED_RANK || s->as->type ==
AS_ASSUMED_SHAPE))
+ {
+ *data_p = true;
+ return;
+ }
+ }
+}
+
+static bool
+need_iso_fortran_binding ()
+{
+ bool needs_include = false;
+
+ if (gfc_gsym_root == NULL)
+ return false;
+
+ gfc_traverse_gsymbol (gfc_gsym_root, has_cfi_cdesc, (void *) &needs_include);
+ return needs_include;
+}
void
-gfc_dump_c_prototypes (gfc_namespace *ns, FILE *file)
+gfc_dump_c_prototypes (FILE *file)
{
+ bool bind_c = true;
int error_count;
+ gfc_namespace *ns;
gfc_get_errors (NULL, &error_count);
if (error_count != 0)
return;
+
+ if (gfc_gsym_root == NULL)
+ return;
+
dumpfile = file;
- gfc_traverse_ns (ns, write_interop_decl);
+ if (need_iso_fortran_binding ())
+ fputs ("#include <ISO_Fortran_binding.h>\n\n", dumpfile);
+
+ for (ns = gfc_global_ns_list; ns; ns = ns->sibling)
+ gfc_traverse_ns (ns, write_type);
+
+ gfc_traverse_gsymbol (gfc_gsym_root, show_external_symbol, (void *) &bind_c);
}
-/* Loop over all global symbols, writing out their declarations. */
+/* Loop over all external symbols, writing out their declarations. */
void
gfc_dump_external_c_prototypes (FILE * file)
{
+ bool bind_c = false;
+ int error_count;
+
+ gfc_get_errors (NULL, &error_count);
+ if (error_count != 0)
+ return;
+
dumpfile = file;
fprintf (dumpfile,
_("/* Prototypes for external procedures generated from %s\n"
@@ -4044,18 +4110,47 @@ gfc_dump_external_c_prototypes (FILE * file)
" BIND(C) feature of standard Fortran instead. */\n\n"),
gfc_source_file, pkgversion_string, version_string);
- for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns;
- gfc_current_ns = gfc_current_ns->sibling)
- {
- gfc_symbol *sym = gfc_current_ns->proc_name;
+ if (gfc_gsym_root == NULL)
+ return;
- if (sym == NULL || sym->attr.flavor != FL_PROCEDURE
- || sym->attr.is_bind_c)
- continue;
+ gfc_traverse_gsymbol (gfc_gsym_root, show_external_symbol, (void *) &bind_c);
+}
+
+/* Callback function for dumping external symbols, be they BIND(C) or
+ external. */
+
+static void
+show_external_symbol (gfc_gsymbol *gsym, void *data)
+{
+ bool bind_c, *data_p;
+ gfc_symbol *sym;
+ const char *name;
+
+ if (gsym->ns == NULL)
+ return;
+
+ name = gsym->sym_name ? gsym->sym_name : gsym->name;
+
+ gfc_find_symbol (name, gsym->ns, 0, &sym);
+ if (sym == NULL)
+ return;
+
+ data_p = (bool *) data;
+ bind_c = *data_p;
+ if (bind_c)
+ {
+ if (!sym->attr.is_bind_c)
+ return;
+
+ write_interop_decl (sym);
+ }
+ else
+ {
+ if (sym->attr.flavor != FL_PROCEDURE || sym->attr.is_bind_c)
+ return;
write_proc (sym, false);
}
- return;
}
enum type_return { T_OK=0, T_WARN, T_ERROR };
@@ -4076,6 +4171,15 @@ get_c_type_name (gfc_typespec *ts, gfc_array_spec *as,
const char **pre,
*asterisk = false;
*post = "";
*type_name = "<error>";
+
+ if (as && (as->type == AS_ASSUMED_RANK || as->type == AS_ASSUMED_SHAPE))
+ {
+ *asterisk = true;
+ *post = "";
+ *type_name = "CFI_cdesc_t";
+ return T_OK;
+ }
+
if (ts->type == BT_REAL || ts->type == BT_INTEGER || ts->type == BT_COMPLEX
|| ts->type == BT_UNSIGNED)
{
@@ -4195,20 +4299,24 @@ get_c_type_name (gfc_typespec *ts, gfc_array_spec *as,
const char **pre,
ret = T_OK;
}
- if (ret != T_ERROR && as)
+ if (ret != T_ERROR && as && as->type == AS_EXPLICIT)
{
mpz_t sz;
bool size_ok;
size_ok = spec_size (as, &sz);
- gcc_assert (size_ok == true);
- gmp_snprintf (post_buffer, sizeof(post_buffer), "[%Zd]", sz);
- *post = post_buffer;
- mpz_clear (sz);
+ if (size_ok)
+ {
+ gmp_snprintf (post_buffer, sizeof(post_buffer), "[%Zd]", sz);
+ *post = post_buffer;
+ mpz_clear (sz);
+ *asterisk = false;
+ }
}
return ret;
}
/* Write out a declaration. */
+
static void
write_decl (gfc_typespec *ts, gfc_array_spec *as, const char *sym_name,
bool func_ret, locus *where, bool bind_c)
@@ -4247,6 +4355,11 @@ write_type (gfc_symbol *sym)
{
gfc_component *c;
+ /* Don't dump our iso c module. */
+
+ if (sym->from_intmod == INTMOD_ISO_C_BINDING || sym->attr.flavor !=
FL_DERIVED)
+ return;
+
fprintf (dumpfile, "typedef struct %s {\n", sym->name);
for (c = sym->components; c; c = c->next)
{
@@ -4255,7 +4368,7 @@ write_type (gfc_symbol *sym)
fputs (";\n", dumpfile);
}
- fprintf (dumpfile, "} %s;\n", sym->name);
+ fprintf (dumpfile, "} %s;\n\n", sym->name);
}
/* Write out a variable. */
@@ -4321,7 +4434,7 @@ write_proc (gfc_symbol *sym, bool bind_c)
{
gfc_symbol *s;
s = f->sym;
- rok = get_c_type_name (&(s->ts), NULL, &pre, &type_name, &asterisk,
+ rok = get_c_type_name (&(s->ts), s->as, &pre, &type_name, &asterisk,
&post, false);
if (rok == T_ERROR)
{
@@ -4332,7 +4445,8 @@ write_proc (gfc_symbol *sym, bool bind_c)
return;
}
- if (!s->attr.value)
+ /* For explicit arrays, we already set the asterisk above. */
+ if (!s->attr.value && !(s->as && s->as->type == AS_EXPLICIT))
asterisk = true;
if (s->attr.intent == INTENT_IN && !s->attr.value)
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 7367db8853c6..825dc2ae8e2b 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -4078,7 +4078,7 @@ void * gfc_delete_bbt (void *, void *, compare_fn);
/* dump-parse-tree.cc */
void gfc_dump_parse_tree (gfc_namespace *, FILE *);
-void gfc_dump_c_prototypes (gfc_namespace *, FILE *);
+void gfc_dump_c_prototypes (FILE *);
void gfc_dump_external_c_prototypes (FILE *);
void gfc_dump_global_symbols (FILE *);
void debug (gfc_symbol *);
diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc
index fbecb1744376..a75284ec0bc0 100644
--- a/gcc/fortran/parse.cc
+++ b/gcc/fortran/parse.cc
@@ -7529,11 +7529,7 @@ done:
/* First dump BIND(C) prototypes. */
if (flag_c_prototypes)
- {
- for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns;
- gfc_current_ns = gfc_current_ns->sibling)
- gfc_dump_c_prototypes (gfc_current_ns, stdout);
- }
+ gfc_dump_c_prototypes (stdout);
/* Dump external prototypes. */
if (flag_c_prototypes_external)
