From patchwork Wed May 8 21:30:57 2019 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Thomas Koenig X-Patchwork-Id: 1097223 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (mailfrom) smtp.mailfrom=gcc.gnu.org (client-ip=209.132.180.131; helo=sourceware.org; envelope-from=gcc-patches-return-500336-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=pass (p=quarantine dis=none) header.from=netcologne.de Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="w7sib+Cv"; dkim=pass (2048-bit key; unprotected) header.d=netcologne.de header.i=@netcologne.de header.b="V9IlLmvm"; dkim-atps=neutral Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 44zqRT2Nb1z9s4V for ; Thu, 9 May 2019 07:31:32 +1000 (AEST) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:to :from:subject:message-id:date:mime-version:content-type; q=dns; s=default; b=m1UhvXv3m0lpMyxYFDUAk4x2yTNeuGyZdzW90PfbYtUL8eaOBJ JrtxLskPr/OFjd/xLiyqNO1SretgWAMvuWFhyWAQgPBYS4CXNhDfoiHatsl9rtoN yO/CzYkmbGb6GBrY+7lFP3W3/XOBgQS+n5w0HmYryEJTpDjaEhEbS73uM= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:to :from:subject:message-id:date:mime-version:content-type; s= default; bh=P9EDYl9iTVlB0/RrhT2nmU93xPw=; b=w7sib+Cv8oJKqGD0Nz/e wnWtInmaNmal062gs0h0QHCh7/FndKoSaovZnz+OHCl2HRgOFpxAPgf7op8WkXrg rRFji+VYoPJgINmxVtvO1SMP2tjXy0sRVSgH5w4rdqueA7L75buq1Kyu7LJid1Wd Te7B944ylMuwFAy8pco76aY= Received: (qmail 29528 invoked by alias); 8 May 2019 21:31:10 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Received: (qmail 29462 invoked by uid 89); 8 May 2019 21:31:06 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-16.8 required=5.0 tests=BAYES_00, GIT_PATCH_1, GIT_PATCH_2, GIT_PATCH_3, KAM_ASCII_DIVIDERS, RCVD_IN_DNSWL_LOW, SPF_PASS autolearn=ham version=3.3.1 spammy=strcmp, asterisk, developments, U*tkoenig X-HELO: cc-smtpout1.netcologne.de Received: from cc-smtpout1.netcologne.de (HELO cc-smtpout1.netcologne.de) (89.1.8.211) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Wed, 08 May 2019 21:31:02 +0000 Received: from cc-smtpin1.netcologne.de (cc-smtpin1.netcologne.de [89.1.8.201]) by cc-smtpout1.netcologne.de (Postfix) with ESMTP id C3BD813221; Wed, 8 May 2019 23:30:58 +0200 (CEST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/simple; d=netcologne.de; s=nc1116a; t=1557351058; bh=5Sr2tOA0pWz/xQ8dhQRnKkx2zLu9YSYAbsgDDc0bG2g=; h=To:From:Subject:Message-ID:Date:From; b=V9IlLmvmbB8tPlJVo08QgZm6+tlcwZWpO3zC4bk5e2vlau4Hha1hoUGycA+fdR4GY cIKYIUND9V1uQN+KA1UTMyNdo8ewWfsVMgpT91UmCaUkKXRdwIvYNErmypT5LE/8VE FZfNRGr1RuiS1WRcfIpQInJ/scyzMt/HrmQVFXVU3aoVrLbUQqrYTEcifBwWP9XAVp Xu5vbiWNDG/M6oFSljjVAEzPekcNqRRPpVPAhsCMvFSzD8X9oI/402mdWHHGCQysFg cY90nXdfWePE3F8no0q04LwHpf2YJxknXZRjNE2p+SZQFe0x00M37CxYuf/bz453sK ILkxdyTsaD+5A== Received: from localhost (localhost [127.0.0.1]) by cc-smtpin1.netcologne.de (Postfix) with ESMTP id B6EC811EF1; Wed, 8 May 2019 23:30:58 +0200 (CEST) Received: from [2001:4dd7:ac4:0:7285:c2ff:fe6c:992d] (helo=cc-smtpin1.netcologne.de) by localhost with ESMTP (eXpurgate 4.6.0) (envelope-from ) id 5cd34a92-0165-7f0000012729-7f000001ede0-1 for ; Wed, 08 May 2019 23:30:58 +0200 Received: from [IPv6:2001:4dd7:ac4:0:7285:c2ff:fe6c:992d] (2001-4dd7-ac4-0-7285-c2ff-fe6c-992d.ipv6dyn.netcologne.de [IPv6:2001:4dd7:ac4:0:7285:c2ff:fe6c:992d]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by cc-smtpin1.netcologne.de (Postfix) with ESMTPSA; Wed, 8 May 2019 23:30:57 +0200 (CEST) To: "fortran@gcc.gnu.org" , gcc-patches From: Thomas Koenig Subject: [patch, fortran] C prototype writing improvements for gfortran Message-ID: <4993ab4d-5b67-c90b-4456-6f643a6a60d9@netcologne.de> Date: Wed, 8 May 2019 23:30:57 +0200 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:60.0) Gecko/20100101 Thunderbird/60.6.1 MIME-Version: 1.0 Hello world, the attached patch fixes PR 90351 (not all prototypes were written to standard output with -fc-prototypes) and introduces new functionality to also write C prototypes for external functions, at the same time discouraging their use (because BIND(C) is really the better, standard-conforming and portable way). While looking at the code, I also noticed that COMPLEX was not handled before, so I added that, too. Example: $ cat c.f90 integer function r(i) end subroutine foo(a,b,c) character*(*) a real b complex c end character*(*) function x(r, c1,c2) real r character*(*) c1,c2 end $ gfortran -fsyntax-only -fc-prototypes-external c.f90 /* Prototypes for external procedures generated from c.f90 by GNU Fortran (GCC) 10.0.0 20190427 (experimental). Use of this interface is dicsouraged, consider using the BIND(C) feature of standard Fortran instead. */ int r_ (int *i); void foo_ (char *a, float *b, float complex *c, size_t a_len); void x_ (char *result_x, size_t result_x_len, float *r, char *c1, char *c2, size_t c1_len, size_t c2_len); I'd like to commit this to trunk and to gcc-9, to help users of old-fashioned Lapack bindings, such as R, with their transition to something that does not violate gfortran's ABI. Tested with "make dvi" and "make info". Otherwise, since these flags are not tested in the testsuite (maybe they should be, I just don't know how), regression test passed. OK? 2019-05-08 Thomas Koenig PR fortran/90351 PR fortran/90329 * gfortran.dg/dump-parse-tree.c: Include version.h. (gfc_dump_external_c_prototypes): New function. (get_c_type_name): Select "char" as a name for a simple char. Adjust to handling external functions. Also handle complex. (write_decl): Add argument bind_c. Adjust for dumping of external procedures. (write_proc): Likewise. (write_interop_decl): Add bind_c argument to call of write_proc. * gfortran.h: Add prototype for gfc_dump_external_c_prototypes. * lang.opt: Add -fc-prototypes-external flag. * parse.c (gfc_parse_file): Move dumping of BIND(C) prototypes. Call gfc_dump_external_c_prototypes if option is set. * invoke.texi: Document -fc-prototypes-external. Index: dump-parse-tree.c =================================================================== --- dump-parse-tree.c (Revision 270622) +++ dump-parse-tree.c (Arbeitskopie) @@ -35,6 +35,7 @@ along with GCC; see the file COPYING3. If not see #include "coretypes.h" #include "gfortran.h" #include "constructor.h" +#include "version.h" /* Keep track of indentation for symbol tree dumps. */ static int show_level = 0; @@ -3074,6 +3075,7 @@ gfc_dump_parse_tree (gfc_namespace *ns, FILE *file /* This part writes BIND(C) definition for use in external C programs. */ static void write_interop_decl (gfc_symbol *); +static void write_proc (gfc_symbol *, bool); void gfc_dump_c_prototypes (gfc_namespace *ns, FILE *file) @@ -3086,6 +3088,33 @@ gfc_dump_c_prototypes (gfc_namespace *ns, FILE *fi gfc_traverse_ns (ns, write_interop_decl); } +/* Loop over all global symbols, writing out their declrations. */ + +void +gfc_dump_external_c_prototypes (FILE * file) +{ + dumpfile = file; + fprintf (dumpfile, + _("/* Prototypes for external procedures generated from %s\n" + " by GNU Fortran %s%s.\n\n" + " Use of this interface is dicsouraged, consider using the\n" + " 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 (sym == NULL || sym->attr.flavor != FL_PROCEDURE + || sym->attr.is_bind_c) + continue; + + write_proc (sym, false); + } + return; +} + enum type_return { T_OK=0, T_WARN, T_ERROR }; /* Return the name of the type for later output. Both function pointers and @@ -3104,7 +3133,7 @@ get_c_type_name (gfc_typespec *ts, gfc_array_spec *asterisk = false; *post = ""; *type_name = ""; - if (ts->type == BT_REAL || ts->type == BT_INTEGER) + if (ts->type == BT_REAL || ts->type == BT_INTEGER || ts->type == BT_COMPLEX) { if (ts->is_c_interop && ts->interop_kind) { @@ -3113,6 +3142,12 @@ get_c_type_name (gfc_typespec *ts, gfc_array_spec *type_name = "signed char"; else if (strcmp (*type_name, "size_t") == 0) *type_name = "ssize_t"; + else if (strcmp (*type_name, "float_complex") == 0) + *type_name = "float complex"; + else if (strcmp (*type_name, "double_complex") == 0) + *type_name = "double complex"; + else if (strcmp (*type_name, "long_double_complex") == 0) + *type_name = "long double complex"; ret = T_OK; } @@ -3130,6 +3165,12 @@ get_c_type_name (gfc_typespec *ts, gfc_array_spec *type_name = "signed char"; else if (strcmp (*type_name, "size_t") == 0) *type_name = "ssize_t"; + else if (strcmp (*type_name, "float_complex") == 0) + *type_name = "float complex"; + else if (strcmp (*type_name, "double_complex") == 0) + *type_name = "double complex"; + else if (strcmp (*type_name, "long_double_complex") == 0) + *type_name = "long double complex"; ret = T_WARN; break; @@ -3167,16 +3208,21 @@ get_c_type_name (gfc_typespec *ts, gfc_array_spec } else { - /* Let's select an appropriate int, with a warning. */ - for (int i = 0; i < ISOCBINDING_NUMBER; i++) - { - if (c_interop_kinds_table[i].f90_type == BT_INTEGER - && c_interop_kinds_table[i].value == ts->kind) - { - *type_name = c_interop_kinds_table[i].name + 2; - ret = T_WARN; - } + if (ts->kind == gfc_default_character_kind) + *type_name = "char"; + else + /* Let's select an appropriate int. */ + for (int i = 0; i < ISOCBINDING_NUMBER; i++) + { + if (c_interop_kinds_table[i].f90_type == BT_INTEGER + && c_interop_kinds_table[i].value == ts->kind) + { + *type_name = c_interop_kinds_table[i].name + 2; + break; + } } + ret = T_WARN; + } } else if (ts->type == BT_DERIVED) @@ -3200,6 +3246,7 @@ get_c_type_name (gfc_typespec *ts, gfc_array_spec } } *asterisk = true; + ret = T_OK; } else *type_name = ts->u.derived->name; @@ -3206,6 +3253,7 @@ get_c_type_name (gfc_typespec *ts, gfc_array_spec ret = T_OK; } + if (ret != T_ERROR && as) { mpz_t sz; @@ -3222,7 +3270,7 @@ get_c_type_name (gfc_typespec *ts, gfc_array_spec /* 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 func_ret, locus *where, bool bind_c) { const char *pre, *type_name, *post; bool asterisk; @@ -3245,7 +3293,7 @@ write_decl (gfc_typespec *ts, gfc_array_spec *as, fputs (sym_name, dumpfile); fputs (post, dumpfile); - if (rok == T_WARN) + if (rok == T_WARN && bind_c) fprintf (dumpfile," /* WARNING: Converting '%s' to interoperable type */", gfc_typename (ts)); } @@ -3262,7 +3310,7 @@ write_type (gfc_symbol *sym) for (c = sym->components; c; c = c->next) { fputs (" ", dumpfile); - write_decl (&(c->ts), c->as, c->name, false, &sym->declared_at); + write_decl (&(c->ts), c->as, c->name, false, &sym->declared_at, true); fputs (";\n", dumpfile); } @@ -3284,7 +3332,7 @@ write_variable (gfc_symbol *sym) sym_name = sym->name; fputs ("extern ", dumpfile); - write_decl (&(sym->ts), sym->as, sym_name, false, &sym->declared_at); + write_decl (&(sym->ts), sym->as, sym_name, false, &sym->declared_at, true); fputs (";\n", dumpfile); } @@ -3291,7 +3339,7 @@ write_variable (gfc_symbol *sym) /* Write out a procedure, including its arguments. */ static void -write_proc (gfc_symbol *sym) +write_proc (gfc_symbol *sym, bool bind_c) { const char *pre, *type_name, *post; bool asterisk; @@ -3299,22 +3347,35 @@ static void gfc_formal_arglist *f; const char *sym_name; const char *intent_in; + bool external_character; + external_character = sym->ts.type == BT_CHARACTER && !bind_c; + if (sym->binding_label) sym_name = sym->binding_label; else sym_name = sym->name; - if (sym->ts.type == BT_UNKNOWN) + if (sym->ts.type == BT_UNKNOWN || external_character) { fprintf (dumpfile, "void "); fputs (sym_name, dumpfile); } else - write_decl (&(sym->ts), sym->as, sym_name, true, &sym->declared_at); + write_decl (&(sym->ts), sym->as, sym_name, true, &sym->declared_at, bind_c); + if (!bind_c) + fputs ("_", dumpfile); + fputs (" (", dumpfile); - + if (external_character) + { + fprintf (dumpfile, "char *result_%s, size_t result_%s_len", + sym_name, sym_name); + if (sym->formal) + fputs (", ", dumpfile); + } + for (f = sym->formal; f; f = f->next) { gfc_symbol *s; @@ -3325,7 +3386,7 @@ static void { gfc_error_now ("Cannot convert %qs to interoperable type at %L", gfc_typename (&s->ts), &s->declared_at); - fprintf (stderr, "/* Cannot convert '%s' to interoperable type */", + fprintf (dumpfile, "/* Cannot convert '%s' to interoperable type */", gfc_typename (&s->ts)); return; } @@ -3346,12 +3407,17 @@ static void fputs (s->name, dumpfile); fputs (post, dumpfile); - if (rok == T_WARN) + if (bind_c && rok == T_WARN) fputs(" /* WARNING: non-interoperable KIND */ ", dumpfile); if (f->next) fputs(", ", dumpfile); } + if (!bind_c) + for (f = sym->formal; f; f = f->next) + if (f->sym->ts.type == BT_CHARACTER) + fprintf (dumpfile, ", size_t %s_len", f->sym->name); + fputs (");\n", dumpfile); } @@ -3375,5 +3441,5 @@ write_interop_decl (gfc_symbol *sym) else if (sym->attr.flavor == FL_DERIVED) write_type (sym); else if (sym->attr.flavor == FL_PROCEDURE) - write_proc (sym); + write_proc (sym, true); } Index: gfortran.h =================================================================== --- gfortran.h (Revision 270622) +++ gfortran.h (Arbeitskopie) @@ -3462,6 +3462,7 @@ void gfc_delete_bbt (void *, void *, compare_fn); /* dump-parse-tree.c */ void gfc_dump_parse_tree (gfc_namespace *, FILE *); void gfc_dump_c_prototypes (gfc_namespace *, FILE *); +void gfc_dump_external_c_prototypes (FILE *); /* parse.c */ bool gfc_parse_file (void); Index: invoke.texi =================================================================== --- invoke.texi (Revision 270622) +++ invoke.texi (Arbeitskopie) @@ -176,7 +176,7 @@ and warnings}. @item Interoperability Options @xref{Interoperability Options,,Options for interoperability}. -@gccoptlist{-fc-prototypes} +@gccoptlist{-fc-prototypes -fc-prototypes-external} @item Code Generation Options @xref{Code Gen Options,,Options for code generation conventions}. @@ -1870,7 +1870,7 @@ shared by @command{gfortran}, @command{gcc}, and o @item -fc-prototypes @opindex @code{c-prototypes} -@cindex Generating C prototypes from Fortran source code +@cindex Generating C prototypes from Fortran BIND(C) enteties This option will generate C prototypes from @code{BIND(C)} variable declarations, types and procedure interfaces and writes them to standard output. @code{ENUM} is not yet supported. @@ -1889,6 +1889,32 @@ $ gfortran -fc-prototypes -fsyntax-only foo.f90 > @end smallexample where the C code intended for interoperating with the Fortran code then uses @code{#include "foo.h"}. + +@item -fc-prototypes-external +@opindex @code{c-prototypes-external} +@cindex Generating C prototypes from external procedures +This option will generate C prototypes from external functions and +subroutines and write them to standard output. This may be useful for +making sure that C bindings to Fortran code are correct. This option +does not generate prototypes for @code{BIND(C)} procedures, use +@option{-fc-prototypes} for that. + +The generated prototypes may need inclusion of an appropriate +header, such as as @code{} or @code{}. + +This is primarily meant for legacy code to ensure that existing C +bindings match what @command{gfortran} emits. The generated C +prototypes should be correct for the current version of the compiler, +but may not match what other compilers or earlier versions of +@command{gfortran} need. For new developments, use of the +@code{BIND(C)} features is recommended. + +Example of use: +@smallexample +$ gfortran -fc-prototypes-external -fsyntax-only foo.f > foo.h +@end smallexample +where the C code intended for interoperating with the Fortran code +then uses @code{#include "foo.h"}. @end table @node Environment Variables Index: lang.opt =================================================================== --- lang.opt (Revision 270622) +++ lang.opt (Arbeitskopie) @@ -428,6 +428,10 @@ fc-prototypes Fortran Var(flag_c_prototypes) Generate C prototypes from BIND(C) declarations. +fc-prototypes-external +Fortran Var(flag_c_prototypes_external) +Generate C prototypes from non-BIND(C) external procedure definitions. + fd-lines-as-code Fortran RejectNegative Ignore 'D' in column one in fixed form. Index: parse.c =================================================================== --- parse.c (Revision 270622) +++ parse.c (Arbeitskopie) @@ -6278,9 +6278,6 @@ loop: if (flag_dump_fortran_original) gfc_dump_parse_tree (gfc_current_ns, stdout); - if (flag_c_prototypes) - gfc_dump_c_prototypes (gfc_current_ns, stdout); - gfc_get_errors (NULL, &errors); if (s.state == COMP_MODULE || s.state == COMP_SUBMODULE) { @@ -6333,6 +6330,18 @@ done: fputs ("------------------------------------------\n\n", stdout); } + /* Dump 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); + } + + /* Dump external prototypes. */ + if (flag_c_prototypes_external) + gfc_dump_external_c_prototypes (stdout); + /* Do the translation. */ translate_all_program_units (gfc_global_ns_list);