From: Thomas Koenig Date: Wed, 8 Jan 2025 16:06:31 +0000 (+0100) Subject: Allow CFI_cdesc_t in argument lists with -fc-prototypes. X-Git-Tag: basepoints/gcc-16~2586 X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=c158f36027c316aedaa7bde83ca28a3365721fce;p=thirdparty%2Fgcc.git 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 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 \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 = ""; + + 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 7367db8853c..825dc2ae8e2 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 fbecb174437..a75284ec0bc 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)