Am 09.01.25 um 14:34 schrieb Thomas Koenig:
This patch fixes and reorganizes dumping C prototypes.
And here is the "five seconds later, I realized I had forgotten
to attach the patch" e-mail...
diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc
index 8d31ddfcffb..826f4c6df7a 100644
--- a/gcc/fortran/dump-parse-tree.cc
+++ b/gcc/fortran/dump-parse-tree.cc
@@ -3802,27 +3802,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"
@@ -3831,18 +3897,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 };
@@ -3863,6 +3958,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)
{
@@ -3982,20 +4086,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)
@@ -4034,6 +4142,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)
{
@@ -4042,7 +4155,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. */
@@ -4108,7 +4221,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)
{
@@ -4119,7 +4232,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 aa495b5487e..b465285552d 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -4060,7 +4060,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 f65449df9e2..ba111bfe538 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)
