From patchwork Fri Jul 28 18:50:36 2017 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Thomas Koenig X-Patchwork-Id: 794998 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-459289-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="GhfLaGkg"; 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 3xJybp0qcQz9s7m for ; Sat, 29 Jul 2017 04:50:59 +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=r36URTMPT6c7GPoYXLeCMxj1NG3ek3t3zTJR2RdjGjYkgxHL4q VzkN56Pz2ihM4zsrLawkoHXXsdHodGUosNUeLlkuNpccDrHUPxwM3hgNnlEEnCv8 QEIfcQo2HyKYNu9q85/1jQeUAuwSGXj6jV5KpnG68zL7M1why8++hv5to= 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=B10Nyb4NVCJ2cg1tk12uxMRCqXk=; b=GhfLaGkgRMdx3uMPNyI7 HSpJzrT8FH1hHAlerkEnvs2VUFp3XdD6mxmBenszytfs9LgpsPBTwQD7R2DkvCsE HWmUX/Mnq9tPJoBH+n4/3Q8qdL2z8oPxQ4WOklmDA3AmimlYxyZ8DREOiTp/SjTd 85gtTwb+GBoNMuz6b9Ti9MU= Received: (qmail 50006 invoked by alias); 28 Jul 2017 18:50:48 -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 49963 invoked by uid 89); 28 Jul 2017 18:50:46 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-15.7 required=5.0 tests=AWL, BAYES_00, GIT_PATCH_1, GIT_PATCH_2, GIT_PATCH_3, KAM_ASCII_DIVIDERS, RCVD_IN_DNSWL_LOW, RP_MATCHES_RCVD, SPF_PASS autolearn=ham version=3.3.2 spammy=influencing, dob, H*Ad:U*tkoenig, Suggestions X-Spam-User: qpsmtpd, 2 recipients X-HELO: cc-smtpout2.netcologne.de Received: from cc-smtpout2.netcologne.de (HELO cc-smtpout2.netcologne.de) (89.1.8.212) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Fri, 28 Jul 2017 18:50:42 +0000 Received: from cc-smtpin2.netcologne.de (cc-smtpin2.netcologne.de [89.1.8.202]) by cc-smtpout2.netcologne.de (Postfix) with ESMTP id 65C9012572; Fri, 28 Jul 2017 20:50:38 +0200 (CEST) Received: from localhost (localhost [127.0.0.1]) by cc-smtpin2.netcologne.de (Postfix) with ESMTP id 5659111D95; Fri, 28 Jul 2017 20:50:38 +0200 (CEST) Received: from [78.35.135.193] (helo=cc-smtpin2.netcologne.de) by localhost with ESMTP (eXpurgate 4.1.9) (envelope-from ) id 597b877e-022c-7f0000012729-7f0000019007-1 for ; Fri, 28 Jul 2017 20:50:38 +0200 Received: from [192.168.178.20] (xdsl-78-35-135-193.netcologne.de [78.35.135.193]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by cc-smtpin2.netcologne.de (Postfix) with ESMTPSA; Fri, 28 Jul 2017 20:50:36 +0200 (CEST) To: "fortran@gcc.gnu.org" , gcc-patches From: Thomas Koenig Subject: [patch, fortran] Generate C prototypes from Fortran code Message-ID: <8ccb52b8-fa27-156d-40fa-9ad52297030d@netcologne.de> Date: Fri, 28 Jul 2017 20:50:36 +0200 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:52.0) Gecko/20100101 Thunderbird/52.2.1 MIME-Version: 1.0 Hello world, the attached patch generates C prototypes from all things BIND(C) that it can find and dumps them to standard output, under control of the appropriate flag. Enums are not yet supported (we translate them to parameters almost immediately, so this will need more work). I have added an example for how this could work. It will likely automate my own C interop work. Doing this the other way, writing Fortran interface blocks from C prototypes, is also an interesting project, but not yet. Regarding the documentation: This option didn't really fit into any other section, which is why I put it into its own. Suggestions are welcome. Currently, it turns code like module x use, intrinsic :: iso_c_binding implicit none type(c_funptr), bind(c) :: funptr type(c_ptr), bind(c) :: vptr type, bind(c) :: t_t integer(c_signed_char) :: i type(c_ptr) :: p end type t_t type(t_t), bind(c,name="yourvar") :: myvar integer(c_int64_t), bind(c) :: a(10,10) double precision, bind(c) :: dob interface function my_memcpy(dest, from, n) bind(c) import type(c_ptr) :: my_memcpy type(c_ptr), intent(out) :: dest type(c_ptr), intent(in) :: from; integer(c_size_t), value :: n end function my_memcpy end interface contains subroutine sub(asub) bind(c) real(c_float), value :: asub end subroutine sub integer(c_int) function func(afunc) bind(c) real(c_float), intent(in) :: afunc end function func subroutine inout_test (a_in, a_out) bind(c) real(c_double), dimension(*), intent(in) :: a_in real(c_double), dimension(*), intent(out) :: a_out end subroutine inout_test function xxx(a) bind(c) integer, intent(in) :: a type(c_funptr) :: xxx end function xxx end module x into typedef struct t_t { signed char i; void *p; } t_t; extern int64_t a[100]; extern double dob /* WARNING: non-interoperable KIND */; int func (const float *afunc); extern int (*funptr)(); void inout_test (const double *a_in, double *a_out); void *my_memcpy (void *dest, const void *from, size_t n); extern t_t yourvar; void sub (float asub); extern void *vptr; int (*xxx()) (const int *a /* WARNING: non-interoperable KIND */ ); Of course, I could also add some boilerplate to the generated code, into comments, such as "generated by gfortran xyz on ... from file ...". I have chosen to turn function pointers into old-style K&R pointers, in the hope that this is the correct thing to do. So, is this approach OK in general? Suggestions? Other ideas? OK for trunk? Regards Thomas 2017-07-28 Thomas Koenig PR fortran/45435 * lang.opt (fc-prototypes): Add option. * gfortran.h (gfc_typespec): Add interop_kind to struct. (gfc_dump_c_prototypes): Add prototype. * decl.c (gfc_match_kind_spec): Copy symbol used for kind to typespec. * parse.c (gfc_parse_file): Call gfc_dump_prototypes. * dump-parse-tree.c (gfc_dump_c_prototypes): New function. (type_return): New enum. (get_c_type_name): New function. (write_decl): New function. (write_type): New function. (write_variable): New function. (write_proc): New function. (write_interop_decl): New function. * invoke.texi: Document -fc-prototypes. FFLAGS = -flto -O2 -Wall CFLAGS = -flto -O2 -Wall LFLAGS = -flto -O2 -Wall OBJS = main.o inter.o cexample.o all: $(OBJS) gfortran $(LFLAGS) -o $@ $(OBJS) inter.h: inter.f90 gfortran -fsyntax-only -fc-prototypes $< > inter.h inter.o inter.mod: inter.f90 gfortran -c $(FFLAGS) inter.f90 cexample.o: cexample.c inter.h gcc -c $(CFLAGS) $< main.o: main.f90 inter.mod gfortran -c $(FFLAGS) $< clean: rm -f $(OBJS) all inter.h inter.mod *~ Index: decl.c =================================================================== --- decl.c (Revision 250501) +++ decl.c (Arbeitskopie) @@ -2631,6 +2631,7 @@ kind_expr: of the named constants from iso_c_binding. */ ts->is_c_interop = e->ts.is_iso_c; ts->f90_type = e->ts.f90_type; + ts->interop_kind = e->symtree->n.sym; } gfc_free_expr (e); Index: dump-parse-tree.c =================================================================== --- dump-parse-tree.c (Revision 250501) +++ dump-parse-tree.c (Arbeitskopie) @@ -2891,3 +2891,247 @@ gfc_dump_parse_tree (gfc_namespace *ns, FILE *file show_namespace (ns); } +/* This part writes BIND(C) definition for use in external C programs. */ + +static void write_interop_decl (gfc_symbol *); + +void +gfc_dump_c_prototypes (gfc_namespace *ns, FILE *file) +{ + int error_count; + gfc_get_errors (NULL, &error_count); + if (error_count != 0) + return; + dumpfile = file; + gfc_traverse_ns (ns, write_interop_decl); +} + +enum type_return { T_OK=0, T_WARN, T_ERROR }; + +/* Return the name of the type for later output. Both function pointers and + void pointers will be mapped to void *. */ + +static enum type_return +get_c_type_name (gfc_typespec *ts, gfc_array_spec *as, const char **pre, + const char **type_name, bool *asterisk, const char **post, + bool func_ret) +{ + static char post_buffer[40]; + enum type_return ret; + ret = T_ERROR; + + *pre = " "; + *asterisk = false; + *post = ""; + *type_name = ""; + if (ts->type == BT_REAL || ts->type == BT_INTEGER) + { + + if (ts->is_c_interop && ts->interop_kind) + { + *type_name = ts->interop_kind->name + 2; + if (strcmp (*type_name, "signed_char") == 0) + *type_name = "signed char"; + ret = T_OK; + } + else + { + /* The user did not specify a C interop type. Let's look through + the available table and use the first one, but warn. */ + int i; + for (i=0; itype + && c_interop_kinds_table[i].value == ts->kind) + { + *type_name = c_interop_kinds_table[i].name + 2; + if (strcmp (*type_name, "signed_char") == 0) + *type_name = "signed char"; + ret = T_WARN; + break; + } + } + } + } + else if (ts->type == BT_DERIVED) + { + if (ts->u.derived->from_intmod == INTMOD_ISO_C_BINDING) + { + if (strcmp (ts->u.derived->name, "c_ptr") == 0) + *type_name = "void"; + else if (strcmp (ts->u.derived->name, "c_funptr") == 0) + { + *type_name = "int "; + if (func_ret) + { + *pre = "("; + *post = "())"; + } + else + { + *pre = "("; + *post = ")()"; + } + } + *asterisk = true; + } + else + *type_name = ts->u.derived->name; + + ret = T_OK; + } + if (ret != T_ERROR && as) + { + 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); + } + return ret; +} + +/* Write out a declaration. */ +static void +write_decl (gfc_typespec *ts, gfc_array_spec *as, const char *sym_name, + bool func_ret) +{ + const char *pre, *type_name, *post; + bool asterisk; + enum type_return rok; + + rok = get_c_type_name (ts, as, &pre, &type_name, &asterisk, &post, func_ret); + gcc_assert (rok != T_ERROR); + fputs (type_name, dumpfile); + fputs (pre, dumpfile); + if (asterisk) + fputs ("*", dumpfile); + + fputs (sym_name, dumpfile); + fputs (post, dumpfile); + + if (rok == T_WARN) + fputs(" /* WARNING: non-interoperable KIND */", dumpfile); +} + +/* Write out an interoperable type. It will be written as a typedef + for a struct. */ + +static void +write_type (gfc_symbol *sym) +{ + gfc_component *c; + + fprintf (dumpfile, "typedef struct %s {\n", sym->name); + for (c = sym->components; c; c = c->next) + { + fputs (" ", dumpfile); + write_decl (&(c->ts), c->as, c->name, false); + fputs (";\n", dumpfile); + } + + fprintf (dumpfile, "} %s;\n", sym->name); +} + +/* Write out a variable. */ + +static void +write_variable (gfc_symbol *sym) +{ + const char *sym_name; + + gcc_assert (sym->attr.flavor == FL_VARIABLE); + + if (sym->binding_label) + sym_name = sym->binding_label; + else + sym_name = sym->name; + + fputs ("extern ", dumpfile); + write_decl (&(sym->ts), sym->as, sym_name, false); + fputs (";\n", dumpfile); +} + + +/* Write out a procedure, including its arguments. */ +static void +write_proc (gfc_symbol *sym) +{ + const char *pre, *type_name, *post; + bool asterisk; + enum type_return rok; + gfc_formal_arglist *f; + const char *sym_name; + const char *intent_in; + + if (sym->binding_label) + sym_name = sym->binding_label; + else + sym_name = sym->name; + + if (sym->ts.type == BT_UNKNOWN) + { + fprintf (dumpfile, "void "); + fputs (sym_name, dumpfile); + } + else + write_decl (&(sym->ts), sym->as, sym->name, true); + + fputs (" (", dumpfile); + + for (f = sym->formal; f; f = f->next) + { + gfc_symbol *s; + s = f->sym; + rok = get_c_type_name (&(s->ts), NULL, &pre, &type_name, &asterisk, + &post, false); + gcc_assert (rok != T_ERROR); + + if (!s->attr.value) + asterisk = true; + + if (s->attr.intent == INTENT_IN && !s->attr.value) + intent_in = "const "; + else + intent_in = ""; + + fputs (intent_in, dumpfile); + fputs (type_name, dumpfile); + fputs (pre, dumpfile); + if (asterisk) + fputs ("*", dumpfile); + + fputs (s->name, dumpfile); + fputs (post, dumpfile); + if (rok == T_WARN) + fputs(" /* WARNING: non-interoperable KIND */ ", dumpfile); + + fputs (f->next ? ", " : ")", dumpfile); + } + fputs (";\n", dumpfile); +} + + +/* Write a C-interoperable declaration as a C prototype or extern + declaration. */ + +static void +write_interop_decl (gfc_symbol *sym) +{ + /* Only dump bind(c) entities. */ + if (!sym->attr.is_bind_c) + return; + + /* Don't dump our iso c module. */ + if (sym->from_intmod == INTMOD_ISO_C_BINDING) + return; + + if (sym->attr.flavor == FL_VARIABLE) + write_variable (sym); + else if (sym->attr.flavor == FL_DERIVED) + write_type (sym); + else if (sym->attr.flavor == FL_PROCEDURE) + write_proc (sym); +} Index: gfortran.h =================================================================== --- gfortran.h (Revision 250501) +++ gfortran.h (Arbeitskopie) @@ -1012,6 +1012,7 @@ typedef struct int is_iso_c; bt f90_type; bool deferred; + gfc_symbol *interop_kind; } gfc_typespec; @@ -3311,6 +3312,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 *); /* parse.c */ bool gfc_parse_file (void); Index: invoke.texi =================================================================== --- invoke.texi (Revision 250501) +++ invoke.texi (Arbeitskopie) @@ -100,6 +100,8 @@ one is not the default. * Runtime Options:: Influencing runtime behavior * Code Gen Options:: Specifying conventions for function calls, data layout and register usage. +* Interoperability Options:: Options for interoperability with other + languages. * Environment Variables:: Environment variables that affect @command{gfortran}. @end menu @@ -171,6 +173,10 @@ and warnings}. -frecord-marker=@var{length} -fsign-zero } +@item Interoperability Options +@xref{Interoperability Options,,Options for interoperability}. +@gccoptlist{-fc-prototypes} + @item Code Generation Options @xref{Code Gen Options,,Options for code generation conventions}. @gccoptlist{-faggressive-function-elimination -fblas-matmul-limit=@var{n} @gol @@ -1746,6 +1752,31 @@ shared by @command{gfortran}, @command{gcc}, and o @c man end +@node Interoperability Options +@section Options for interoperability with other languages + +@table @asis + +@item -fc-prototypes +@opindex @code{c-prototypes} +@cindex Generating C prototypes from Fortran source code +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. + +The generated prototypes may need inclusion of an appropriate header, +such as @code{} or @code{}. For types which are +not specified using the appropriate kind from the @code{iso_c_binding} +module, a warning is added as a comment to the code. + +Example of use: +@smallexample +$ gfortran -fc-prototypes foo.f90 -fsyntax-only > 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 @section Environment variables affecting @command{gfortran} @cindex environment variable Index: lang.opt =================================================================== --- lang.opt (Revision 250501) +++ lang.opt (Arbeitskopie) @@ -416,6 +416,10 @@ fcray-pointer Fortran Var(flag_cray_pointer) Use the Cray Pointer extension. +fc-prototypes +Fortran Var(flag_c_prototypes) +Generate C prototypes from BIND(C) declarations. + fd-lines-as-code Fortran RejectNegative Ignore 'D' in column one in fixed form. Index: parse.c =================================================================== --- parse.c (Revision 250501) +++ parse.c (Arbeitskopie) @@ -6218,6 +6218,9 @@ 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) {