diff options
author | Paul Thomas <pault@gcc.gnu.org> | 2019-01-12 15:25:52 +0000 |
---|---|---|
committer | Paul Thomas <pault@gcc.gnu.org> | 2019-01-12 15:25:52 +0000 |
commit | bbf18dc5d248a79a20ebf4b3a751669cd75485fd (patch) | |
tree | dfff4a53d274e517577746cfd677e88335f966dd /gcc | |
parent | af79605ec27c0db7dee9ee001cd7d768eb6fcf02 (diff) | |
download | gcc-bbf18dc5d248a79a20ebf4b3a751669cd75485fd.zip gcc-bbf18dc5d248a79a20ebf4b3a751669cd75485fd.tar.gz gcc-bbf18dc5d248a79a20ebf4b3a751669cd75485fd.tar.bz2 |
gfortran.texi: Add description in sections on TS 29113 and further interoperability with C.
2019-01-12 Paul Thomas <pault@gcc.gnu.org>
* gfortran.texi : Add description in sections on TS 29113 and
further interoperability with C.
* trans-array.c (gfc_conv_descriptor_attribute): New function.
(gfc_get_dataptr_offset): Remove static function attribute.
* trans-array.h : Add prototypes for above functions.
* trans-decl.c : Add declarations for the library functions
cfi_desc_to_gfc_desc and gfc_desc_to_cfi_desc.
* trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): New function.
(gfc_conv_procedure_call): Call it for scalar and array actual
arguments, when the formal arguments are bind_c with assumed
shape or assumed rank.
* trans.h : External declarations for gfor_fndecl_cfi_to_gfc
and gfor_fndecl_gfc_to_cfi.
2019-01-12 Paul Thomas <pault@gcc.gnu.org>
* gfortran.dg/ISO_Fortran_binding_1.f90 : New test.
* gfortran.dg/ISO_Fortran_binding_1.c : Auxilliary file for test.
* gfortran.dg/ISO_Fortran_binding_2.f90 : New test.
* gfortran.dg/ISO_Fortran_binding_2.c : Auxilliary file for test.
* gfortran.dg/bind_c_array_params_2.f90 : Change search string
for dump tree scan.
2019-01-12 Paul Thomas <pault@gcc.gnu.org>
* ISO_Fortran_binding.h : New file.
* Makefile.am : Include ISO_Fortran_binding.c in the list of
files to compile.
* Makefile.in : Regenerated.
* gfortran.map : Add _gfortran_cfi_desc_to_gfc_desc,
_gfortran_gfc_desc_to_cfi_desc and the CFI API functions.
* runtime/ISO_Fortran_binding.c : New file containing the new
functions added to the map.
From-SVN: r267881
Diffstat (limited to 'gcc')
-rw-r--r-- | gcc/fortran/ChangeLog | 16 | ||||
-rw-r--r-- | gcc/fortran/gfortran.texi | 95 | ||||
-rw-r--r-- | gcc/fortran/trans-array.c | 18 | ||||
-rw-r--r-- | gcc/fortran/trans-array.h | 3 | ||||
-rw-r--r-- | gcc/fortran/trans-decl.c | 10 | ||||
-rw-r--r-- | gcc/fortran/trans-expr.c | 119 | ||||
-rw-r--r-- | gcc/fortran/trans.h | 2 | ||||
-rw-r--r-- | gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.c | 205 | ||||
-rw-r--r-- | gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90 | 244 | ||||
-rw-r--r-- | gcc/testsuite/gfortran.dg/ISO_Fortran_binding_2.c | 115 | ||||
-rw-r--r-- | gcc/testsuite/gfortran.dg/ISO_Fortran_binding_2.f90 | 193 | ||||
-rw-r--r-- | gcc/testsuite/gfortran.dg/bind_c_array_params_2.f90 | 4 |
12 files changed, 974 insertions, 50 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index b05c594..a34fbd8 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,19 @@ +2019-01-12 Paul Thomas <pault@gcc.gnu.org> + + * gfortran.texi : Add description in sections on TS 29113 and + further interoperability with C. + * trans-array.c (gfc_conv_descriptor_attribute): New function. + (gfc_get_dataptr_offset): Remove static function attribute. + * trans-array.h : Add prototypes for above functions. + * trans-decl.c : Add declarations for the library functions + cfi_desc_to_gfc_desc and gfc_desc_to_cfi_desc. + * trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): New function. + (gfc_conv_procedure_call): Call it for scalar and array actual + arguments, when the formal arguments are bind_c with assumed + shape or assumed rank. + * trans.h : External declarations for gfor_fndecl_cfi_to_gfc + and gfor_fndecl_gfc_to_cfi. + 2019-01-11 Steven G. Kargl <kargl@gcc.gnu.org> PR fortran/35031 diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi index 9b13346..e44b8cc 100644 --- a/gcc/fortran/gfortran.texi +++ b/gcc/fortran/gfortran.texi @@ -384,7 +384,7 @@ extension are also run through preprocessing. This manual specifically documents the Fortran front end, which handles the programming language's syntax and semantics. The aspects of GCC which relate to the optimization passes and the back-end code generation -are documented in the GCC manual; see +are documented in the GCC manual; see @ref{Top,,Introduction,gcc,Using the GNU Compiler Collection (GCC)}. The two manuals together provide a complete reference for the GNU Fortran compiler. @@ -446,11 +446,11 @@ to preprocess such files (@uref{http://www.daniellnagle.com/coco.html}). @cindex Fortran 77 @cindex @command{g77} -The GNU Fortran compiler is the successor to @command{g77}, the Fortran -77 front end included in GCC prior to version 4. It is an entirely new -program that has been designed to provide Fortran 95 support and -extensibility for future Fortran language standards, as well as providing -backwards compatibility for Fortran 77 and nearly all of the GNU language +The GNU Fortran compiler is the successor to @command{g77}, the Fortran +77 front end included in GCC prior to version 4. It is an entirely new +program that has been designed to provide Fortran 95 support and +extensibility for future Fortran language standards, as well as providing +backwards compatibility for Fortran 77 and nearly all of the GNU language extensions supported by @command{g77}. @@ -490,10 +490,10 @@ change in future versions of GCC. See @uref{https://gcc.gnu.org/wiki/OpenACC} for more information. At present, the GNU Fortran compiler passes the -@uref{http://www.fortran-2000.com/ArnaudRecipes/fcvs21_f95.html, +@uref{http://www.fortran-2000.com/ArnaudRecipes/fcvs21_f95.html, NIST Fortran 77 Test Suite}, and produces acceptable results on the @uref{http://www.netlib.org/lapack/faq.html#1.21, LAPACK Test Suite}. -It also provides respectable performance on +It also provides respectable performance on the @uref{http://www.polyhedron.com/fortran-compiler-comparisons/polyhedron-benchmark-suite, Polyhedron Fortran compiler benchmarks} and the @@ -668,7 +668,7 @@ This is the default. @section @env{GFORTRAN_UNBUFFERED_PRECONNECTED}---Do not buffer I/O on preconnected units The environment variable named @env{GFORTRAN_UNBUFFERED_PRECONNECTED} controls -whether I/O on a preconnected unit (i.e.@: STDOUT or STDERR) is unbuffered. If +whether I/O on a preconnected unit (i.e.@: STDOUT or STDERR) is unbuffered. If the first letter is @samp{y}, @samp{Y} or @samp{1}, I/O is unbuffered. This will slow down small sequential reads and writes. If the first letter is @samp{n}, @samp{N} or @samp{0}, I/O is buffered. This is the default. @@ -733,7 +733,7 @@ A missing mode for an exception is taken to mean @code{BIG_ENDIAN}. Examples of values for @env{GFORTRAN_CONVERT_UNIT} are: @itemize @w{} @item @code{'big_endian'} Do all unformatted I/O in big_endian mode. -@item @code{'little_endian;native:10-20,25'} Do all unformatted I/O +@item @code{'little_endian;native:10-20,25'} Do all unformatted I/O in little_endian mode, except for units 10 to 20 and 25, which are in native format. @item @code{'10-20'} Units 10 to 20 are big-endian, the rest is native. @@ -834,7 +834,7 @@ initialization are available. @item The @code{ASSOCIATE} construct. -@item Interoperability with C including enumerations, +@item Interoperability with C including enumerations, @item In structure constructors the components with default values may be omitted. @@ -999,7 +999,7 @@ about the current Fortran 2008 implementation status. In particular, the following is implemented. @itemize -@item The @option{-std=f2008} option and support for the file extensions +@item The @option{-std=f2008} option and support for the file extensions @file{.f08} and @file{.F08}. @item The @code{OPEN} statement now supports the @code{NEWUNIT=} option, @@ -1103,8 +1103,6 @@ arrays are supported for named constants (@code{PARAMETER}). @node Fortran 2018 status @section Status of Fortran 2018 support -So far very little work has been done to support Fortran 2018. - @itemize @item ERROR STOP in a PURE procedure An @code{ERROR STOP} statement is permitted in a @code{PURE} @@ -1143,8 +1141,12 @@ attribute is compatible with TS 29113. @item Assumed types (@code{TYPE(*)}). -@item Assumed-rank (@code{DIMENSION(..)}). However, the array descriptor -of the TS is not yet supported. +@item Assumed-rank (@code{DIMENSION(..)}). + +@item ISO_Fortran_binding (now in Fortran 2018 18.4) is implemented such that +conversion of the array descriptor for assumed type or assumed rank arrays is +done in the library. The include file ISO_Fortran_binding.h is can be found in +@code{~prefix/lib/gcc/$target/$version}. @end itemize @@ -1300,7 +1302,7 @@ being called from a multi-threaded program. The GNU Fortran runtime library, (@code{libgfortran}), supports being called concurrently from multiple threads with the following -exceptions. +exceptions. During library initialization, the C @code{getenv} function is used, which need not be thread-safe. Similarly, the @code{getenv} @@ -1430,7 +1432,7 @@ processor dependent. GNU Fortran behaves as follows: @cindex file, symbolic link This section documents the behavior of GNU Fortran for file operations on -symbolic links, on systems that support them. +symbolic links, on systems that support them. @itemize @@ -1497,7 +1499,7 @@ record containing a single subrecord: program main use iso_fortran_env, only: int32 implicit none - integer(int32) :: i + integer(int32) :: i real, dimension(10) :: a, b call random_number(a) open (10,file='test.dat',form='unformatted',access='stream') @@ -1725,7 +1727,7 @@ PROGRAM test_print END PROGRAM test_print @end smallexample -Expanded namelist reads are permitted. This causes an error if +Expanded namelist reads are permitted. This causes an error if @option{-std=f95} is used. In the following example, the first element of the array will be given the value 0.00 and the two succeeding elements will be given the values 1.00 and 2.00. @@ -1988,7 +1990,7 @@ pointer in order to increment it. Consider the following example: real pointee(10) pointer (ipt, pointee) ipt = loc (target) - ipt = ipt + 1 + ipt = ipt + 1 @end smallexample The last statement does not set @code{ipt} to the address of @code{target(1)}, as it would in C pointer arithmetic. Adding @code{1} @@ -2120,13 +2122,13 @@ portable. @cindex OpenMP OpenMP (Open Multi-Processing) is an application programming -interface (API) that supports multi-platform shared memory -multiprocessing programming in C/C++ and Fortran on many +interface (API) that supports multi-platform shared memory +multiprocessing programming in C/C++ and Fortran on many architectures, including Unix and Microsoft Windows platforms. It consists of a set of compiler directives, library routines, and environment variables that influence run-time behavior. -GNU Fortran strives to be compatible to the +GNU Fortran strives to be compatible to the @uref{http://openmp.org/wp/openmp-specifications/, OpenMP Application Program Interface v4.5}. @@ -2169,7 +2171,7 @@ if the stacksize is limited. @item On glibc-based systems, OpenMP enabled applications cannot be statically linked due to limitations of the underlying pthreads-implementation. It -might be possible to get a working solution if +might be possible to get a working solution if @command{-Wl,--whole-archive -lpthread -Wl,--no-whole-archive} is added to the command line. However, this is not supported by @command{gcc} and thus not recommended. @@ -2213,20 +2215,20 @@ change in future versions of GCC. See @cindex @code{%REF} @cindex @code{%LOC} -GNU Fortran supports argument list functions @code{%VAL}, @code{%REF} -and @code{%LOC} statements, for backward compatibility with g77. -It is recommended that these should be used only for code that is -accessing facilities outside of GNU Fortran, such as operating system -or windowing facilities. It is best to constrain such uses to isolated -portions of a program--portions that deal specifically and exclusively -with low-level, system-dependent facilities. Such portions might well -provide a portable interface for use by the program as a whole, but are -themselves not portable, and should be thoroughly tested each time they +GNU Fortran supports argument list functions @code{%VAL}, @code{%REF} +and @code{%LOC} statements, for backward compatibility with g77. +It is recommended that these should be used only for code that is +accessing facilities outside of GNU Fortran, such as operating system +or windowing facilities. It is best to constrain such uses to isolated +portions of a program--portions that deal specifically and exclusively +with low-level, system-dependent facilities. Such portions might well +provide a portable interface for use by the program as a whole, but are +themselves not portable, and should be thoroughly tested each time they are rebuilt using a new compiler or version of a compiler. -@code{%VAL} passes a scalar argument by value, @code{%REF} passes it by -reference and @code{%LOC} passes its memory location. Since gfortran -already passes scalar arguments by reference, @code{%REF} is in effect +@code{%VAL} passes a scalar argument by value, @code{%REF} passes it by +reference and @code{%LOC} passes its memory location. Since gfortran +already passes scalar arguments by reference, @code{%REF} is in effect a do-nothing. @code{%LOC} has the same effect as a Fortran pointer. An example of passing an argument by value to a C subroutine foo.: @@ -2384,7 +2386,7 @@ following shows some examples: @example structure /appointment/ ! nested structure definition: app_time is an array of two 'time' - structure /time/ app_time (2) + structure /time/ app_time (2) integer(1) hour, minute end structure character(10) memo @@ -2970,7 +2972,7 @@ with the following: @smallexample c Variable declaration CHARACTER(LEN=20) FMT -c +c c Other code here... c WRITE(FMT,'("(I", I0, ")")') N+1 @@ -2983,7 +2985,7 @@ or with: @smallexample c Variable declaration CHARACTER(LEN=20) FMT -c +c c Other code here... c WRITE(FMT,*) N+1 @@ -3430,11 +3432,14 @@ and constraints, it adds assumed-type (@code{TYPE(*)}) and assumed-rank assumed-shape, assumed-rank and deferred-shape arrays, including allocatables and pointers. -Note: Currently, GNU Fortran does not support the array descriptor +Note: Currently, GNU Fortran does not use internally the array descriptor (dope vector) as specified in the Technical Specification, but uses -an array descriptor with different fields. The Chasm Language -Interoperability Tools, @url{http://chasm-interop.sourceforge.net/}, -provide an interface to GNU Fortran's array descriptor. +an array descriptor with different fields. Assumed type and assumed rank +formal arguments are converted in the library to the specified form. The +ISO_Fortran_binding API functions (also Fortran 2018 18.4) are implemented +in libgfortran. Alternatively, the Chasm Language Interoperability Tools, +@url{http://chasm-interop.sourceforge.net/}, provide an interface to GNU +Fortran's array descriptor. The Technical Specification adds the following new features, which are supported by GNU Fortran: @@ -5735,7 +5740,7 @@ ideas and significant help to the GNU Fortran project The following people have contributed bug reports, smaller or larger patches, and much needed feedback and encouragement for the -GNU Fortran project: +GNU Fortran project: @itemize @minus @item Bill Clodius diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index af3a2d8..6b3c0e2 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -293,6 +293,22 @@ gfc_conv_descriptor_rank (tree desc) tree +gfc_conv_descriptor_attribute (tree desc) +{ + tree tmp; + tree dtype; + + dtype = gfc_conv_descriptor_dtype (desc); + tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), + GFC_DTYPE_ATTRIBUTE); + gcc_assert (tmp!= NULL_TREE + && TREE_TYPE (tmp) == short_integer_type_node); + return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp), + dtype, tmp, NULL_TREE); +} + + +tree gfc_get_descriptor_dimension (tree desc) { tree type, field; @@ -6767,7 +6783,7 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, /* Calculate the overall offset, including subreferences. */ -static void +void gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset, bool subref, gfc_expr *expr) { diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index aaca62b..a6d7167 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -136,6 +136,8 @@ void gfc_conv_tmp_array_ref (gfc_se * se); /* Translate a reference to an array temporary. */ void gfc_conv_tmp_ref (gfc_se *); +/* Calculate the overall offset, including subreferences. */ +void gfc_get_dataptr_offset (stmtblock_t*, tree, tree, tree, bool, gfc_expr*); /* Obtain the span of an array. */ tree gfc_get_array_span (tree, gfc_expr *); /* Evaluate an array expression. */ @@ -167,6 +169,7 @@ tree gfc_conv_descriptor_offset_get (tree); tree gfc_conv_descriptor_span_get (tree); tree gfc_conv_descriptor_dtype (tree); tree gfc_conv_descriptor_rank (tree); +tree gfc_conv_descriptor_attribute (tree); tree gfc_get_descriptor_dimension (tree); tree gfc_conv_descriptor_stride_get (tree, tree); tree gfc_conv_descriptor_lbound_get (tree, tree); diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 474ad0b..c4cdcd6 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -114,6 +114,8 @@ tree gfor_fndecl_fdate; tree gfor_fndecl_ttynam; tree gfor_fndecl_in_pack; tree gfor_fndecl_in_unpack; +tree gfor_fndecl_cfi_to_gfc; +tree gfor_fndecl_gfc_to_cfi; tree gfor_fndecl_associated; tree gfor_fndecl_system_clock4; tree gfor_fndecl_system_clock8; @@ -3619,6 +3621,14 @@ gfc_build_builtin_function_decls (void) get_identifier (PREFIX("internal_unpack")), ".wR", void_type_node, 2, pvoid_type_node, pvoid_type_node); + gfor_fndecl_cfi_to_gfc = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("cfi_desc_to_gfc_desc")), ".ww", + void_type_node, 2, pvoid_type_node, ppvoid_type_node); + + gfor_fndecl_gfc_to_cfi = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("gfc_desc_to_cfi_desc")), ".wR", + void_type_node, 2, ppvoid_type_node, pvoid_type_node); + gfor_fndecl_associated = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("associated")), ".RR", integer_type_node, 2, ppvoid_type_node, ppvoid_type_node); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index c45752e..c3388d7 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -4891,6 +4891,102 @@ expr_may_alias_variables (gfc_expr *e, bool array_may_alias) } +/* Provide an interface between gfortran array descriptors and the F2018:18.4 + ISO_Fortran_binding array descriptors. */ + +static void +gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym) +{ + tree tmp; + tree cfi_desc_ptr; + tree gfc_desc_ptr; + tree type; + int attribute; + symbol_attribute attr = gfc_expr_attr (e); + + /* If this is a full array or a scalar, the allocatable and pointer + attributes can be passed. Otherwise it is 'CFI_attribute_other'*/ + attribute = 2; + if (!e->rank || gfc_get_full_arrayspec_from_expr (e)) + { + if (attr.pointer) + attribute = 0; + else if (attr.allocatable) + attribute = 1; + } + + if (e->rank) + { + gfc_conv_expr_descriptor (parmse, e); + + /* All the temporary descriptors are marked as DECL_ARTIFICIAL. If + the expression type is different from the descriptor type, then + the offset must be found (eg. to a component ref or substring) + and the dtype updated. */ + type = gfc_typenode_for_spec (&e->ts); + if (DECL_ARTIFICIAL (parmse->expr) + && type != gfc_get_element_type (TREE_TYPE (parmse->expr))) + { + /* Obtain the offset to the data. */ + gfc_get_dataptr_offset (&parmse->pre, parmse->expr, parmse->expr, + gfc_index_zero_node, true, e); + + /* Update the dtype. */ + gfc_add_modify (&parmse->pre, + gfc_conv_descriptor_dtype (parmse->expr), + gfc_get_dtype_rank_type (e->rank, type)); + } + else if (!is_subref_array (e) && !DECL_ARTIFICIAL (parmse->expr)) + { + /* Make sure that the span is set for expressions where it + might not have been done already. */ + tmp = TREE_TYPE (parmse->expr); + tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp)); + tmp = fold_convert (gfc_array_index_type, tmp); + gfc_conv_descriptor_span_set (&parmse->pre, parmse->expr, tmp); + } + } + else + { + gfc_conv_expr (parmse, e); + /* Copy the scalar for INTENT_IN. */ + if (e->expr_type == EXPR_VARIABLE && fsym->attr.intent == INTENT_IN) + parmse->expr = gfc_evaluate_now (parmse->expr, &parmse->pre); + parmse->expr = gfc_conv_scalar_to_descriptor (parmse, + parmse->expr, attr); + } + + /* Set the CFI attribute field. */ + tmp = gfc_conv_descriptor_attribute (parmse->expr); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, + void_type_node, tmp, + build_int_cst (TREE_TYPE (tmp), attribute)); + gfc_add_expr_to_block (&parmse->pre, tmp); + + /* Now pass the gfc_descriptor by reference. */ + parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr); + + /* Variables to point to the gfc and CFI descriptors. */ + gfc_desc_ptr = parmse->expr; + cfi_desc_ptr = gfc_create_var (pvoid_type_node, "cfi"); + + /* Allocate the CFI descriptor and fill the fields. */ + tmp = gfc_build_addr_expr (NULL_TREE, cfi_desc_ptr); + tmp = build_call_expr_loc (input_location, + gfor_fndecl_gfc_to_cfi, 2, tmp, gfc_desc_ptr); + gfc_add_expr_to_block (&parmse->pre, tmp); + + /* The CFI descriptor is passed to the bind_C procedure. */ + parmse->expr = cfi_desc_ptr; + + /* Transfer values back to gfc descriptor and free the CFI descriptor. */ + tmp = gfc_build_addr_expr (NULL_TREE, parmse->expr); + tmp = build_call_expr_loc (input_location, + gfor_fndecl_cfi_to_gfc, 2, gfc_desc_ptr, tmp); + gfc_prepend_expr_to_block (&parmse->post, tmp); +} + + /* Generate code for a procedure call. Note can return se->post != NULL. If se->direct_byref is set then se->expr contains the return parameter. Return nonzero, if the call has alternate specifiers. @@ -5234,7 +5330,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer); parmse.expr = convert (type, tmp); } - else if (fsym && fsym->attr.value) + + else if (sym->attr.is_bind_c && e + && fsym && fsym->attr.dimension + && (fsym->as->type == AS_ASSUMED_RANK + || fsym->as->type == AS_ASSUMED_SHAPE)) + /* Implement F2018, C.12.6.1: paragraph (2). */ + gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym); + + else if (fsym && fsym->attr.value) { if (fsym->ts.type == BT_CHARACTER && fsym->ts.is_c_interop @@ -5273,6 +5377,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, } } } + else if (arg->name && arg->name[0] == '%') /* Argument list functions %VAL, %LOC and %REF are signalled through arg->name. */ @@ -5287,6 +5392,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, gfc_conv_expr (&parmse, e); parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr); } + else if (e->expr_type == EXPR_FUNCTION && e->symtree->n.sym->result && e->symtree->n.sym->result != e->symtree->n.sym @@ -5297,6 +5403,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, if (fsym && fsym->attr.proc_pointer) parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr); } + else { if (e->ts.type == BT_CLASS && fsym @@ -5670,7 +5777,14 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, parmse.force_tmp = 1; } - if (e->expr_type == EXPR_VARIABLE + if (sym->attr.is_bind_c && e + && fsym && fsym->attr.dimension + && (fsym->as->type == AS_ASSUMED_RANK + || fsym->as->type == AS_ASSUMED_SHAPE)) + /* Implement F2018, C.12.6.1: paragraph (2). */ + gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym); + + else if (e->expr_type == EXPR_VARIABLE && is_subref_array (e) && !(fsym && fsym->attr.pointer)) /* The actual argument is a component reference to an @@ -5680,6 +5794,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, gfc_conv_subref_array_arg (&parmse, e, nodesc_arg, fsym ? fsym->attr.intent : INTENT_INOUT, fsym && fsym->attr.pointer); + else if (gfc_is_class_array_ref (e, NULL) && fsym && fsym->ts.type == BT_DERIVED) /* The actual argument is a component reference to an diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index e42160b..805ed76 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -801,6 +801,8 @@ extern GTY(()) tree gfor_fndecl_ctime; extern GTY(()) tree gfor_fndecl_fdate; extern GTY(()) tree gfor_fndecl_in_pack; extern GTY(()) tree gfor_fndecl_in_unpack; +extern GTY(()) tree gfor_fndecl_cfi_to_gfc; +extern GTY(()) tree gfor_fndecl_gfc_to_cfi; extern GTY(()) tree gfor_fndecl_associated; extern GTY(()) tree gfor_fndecl_system_clock4; extern GTY(()) tree gfor_fndecl_system_clock8; diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.c b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.c new file mode 100644 index 0000000..3bf5c3d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.c @@ -0,0 +1,205 @@ +/* Test F2008 18.5: ISO_Fortran_binding.h functions. */ + +#include <ISO_Fortran_binding.h> +#include <stdio.h> +#include <stdlib.h> +#include <complex.h> + +/* Test the example in F2008 C.12.9: Processing assumed-shape arrays in C, + modified to use CFI_address instead of pointer arithmetic. */ + +int elemental_mult_c(CFI_cdesc_t * a_desc, CFI_cdesc_t * b_desc, + CFI_cdesc_t * c_desc) +{ + CFI_index_t idx[2]; + int *res_addr; + int err = 1; /* this error code represents all errors */ + + if (a_desc->rank == 0) + { + err = *(int*)a_desc->base_addr; + *(int*)a_desc->base_addr = 0; + return err; + } + + if (a_desc->type != CFI_type_int + || b_desc->type != CFI_type_int + || c_desc->type != CFI_type_int) + return err; + + /* Only support two dimensions. */ + if (a_desc->rank != 2 + || b_desc->rank != 2 + || c_desc->rank != 2) + return err; + + for (idx[0] = 0; idx[0] < a_desc->dim[0].extent; idx[0]++) + for (idx[1] = 0; idx[1] < a_desc->dim[1].extent; idx[1]++) + { + res_addr = CFI_address (a_desc, idx); + *res_addr = *(int*)CFI_address (b_desc, idx) + * *(int*)CFI_address (c_desc, idx); + } + + return 0; +} + + +int deallocate_c(CFI_cdesc_t * dd) +{ + return CFI_deallocate(dd); +} + + +int allocate_c(CFI_cdesc_t * da, CFI_index_t lower[], CFI_index_t upper[]) +{ + int err = 1; + CFI_index_t idx[2]; + int *res_addr; + + if (CFI_allocate(da, lower, upper, 0)) return err; + + + for (idx[0] = 0; idx[0] < da->dim[0].extent; idx[0]++) + for (idx[1] = 0; idx[1] < da->dim[1].extent; idx[1]++) + { + res_addr = CFI_address (da, idx); + *res_addr = (int)((idx[0] + da->dim[0].lower_bound) + * (idx[1] + da->dim[1].lower_bound)); + } + + return 0; +} + +int establish_c(CFI_cdesc_t * desc) +{ + typedef struct {double x; double _Complex y;} t; + int err; + CFI_index_t idx[1], extent[1]; + t *res_addr; + double value = 1.0; + double complex z_value = 0.0 + 2.0 * I; + + extent[0] = 10; + err = CFI_establish((CFI_cdesc_t *)desc, + malloc ((size_t)(extent[0] * sizeof(t))), + CFI_attribute_pointer, + CFI_type_struct, + sizeof(t), 1, extent); + for (idx[0] = 0; idx[0] < extent[0]; idx[0]++) + { + res_addr = (t*)CFI_address (desc, idx); + res_addr->x = value++; + res_addr->y = z_value * (idx[0] + 1); + } + return err; +} + +int contiguous_c(CFI_cdesc_t * desc) +{ + return CFI_is_contiguous(desc); +} + +float section_c(int *std_case, CFI_cdesc_t * source, int *low, int *str) +{ + CFI_index_t idx[CFI_MAX_RANK], lower[CFI_MAX_RANK], + strides[CFI_MAX_RANK], upper[CFI_MAX_RANK]; + CFI_CDESC_T(1) section; + int ind, size; + float *ret_addr; + float ans = 0.0; + + /* Case (i) from F2018:18.5.5.7. */ + if (*std_case == 1) + { + lower[0] = (CFI_index_t)low[0]; + strides[0] = (CFI_index_t)str[0]; + ind = CFI_establish((CFI_cdesc_t *)§ion, NULL, CFI_attribute_other, + CFI_type_float, 0, 1, NULL); + if (ind) return -1.0; + ind = CFI_section((CFI_cdesc_t *)§ion, source, lower, NULL, strides); + if (ind) return -2.0; + + /* Sum over the section */ + size = (section.dim[0].extent - 1) + * section.elem_len/section.dim[0].sm + 1; + for (idx[0] = 0; idx[0] < size; idx[0]++) + ans += *(float*)CFI_address ((CFI_cdesc_t*)§ion, idx); + return ans; + } + else if (*std_case == 2) + { + int ind; + lower[0] = source->dim[0].lower_bound; + upper[0] = source->dim[0].lower_bound + source->dim[0].extent - 1; + strides[0] = str[0]; + lower[1] = upper[1] = source->dim[1].lower_bound + low[1] - 1; + strides[1] = 0; + ind = CFI_establish((CFI_cdesc_t *)§ion, NULL, CFI_attribute_other, + CFI_type_float, 0, 1, NULL); + if (ind) return -1.0; + ind = CFI_section((CFI_cdesc_t *)§ion, source, + lower, upper, strides); + if (ind) return -2.0; + + /* Sum over the section */ + size = (section.dim[0].extent - 1) + * section.elem_len/section.dim[0].sm + 1; + for (idx[0] = 0; idx[0] < size; idx[0]++) + ans += *(float*)CFI_address ((CFI_cdesc_t*)§ion, idx); + return ans; + } + + return 0.0; +} + + +double select_part_c (CFI_cdesc_t * source) +{ + typedef struct { + double x; double _Complex y; + } t; + CFI_CDESC_T(2) component; + CFI_cdesc_t * comp_cdesc = (CFI_cdesc_t *)&component; + CFI_index_t extent[] = {10,10}; + CFI_index_t idx[] = {4,0}; + double ans = 0.0; + int size; + + (void)CFI_establish(comp_cdesc, NULL, CFI_attribute_other, + CFI_type_double_Complex, sizeof(double _Complex), + 2, extent); + (void)CFI_select_part(comp_cdesc, source, offsetof(t,y), 0); + + /* Sum over comp_cdesc[4,:] */ + size = comp_cdesc->dim[1].extent; + for (idx[1] = 0; idx[1] < size; idx[1]++) + ans += cimag (*(double _Complex*)CFI_address ((CFI_cdesc_t*)comp_cdesc, + idx)); + return ans; +} + + +int setpointer_c(CFI_cdesc_t * ptr, int lbounds[]) +{ + CFI_index_t lower_bounds[] = {lbounds[0],lbounds[1]}; + int ind; + ind = CFI_setpointer(ptr, ptr, lower_bounds); + return ind; +} + + +int assumed_size_c(CFI_cdesc_t * desc) +{ + int ierr; + + ierr = CFI_is_contiguous(desc); + if (ierr) + return 1; + if (desc->rank) + ierr = 2 * (desc->dim[desc->rank-1].extent + != (CFI_index_t)(long long)(-1)); + else + ierr = 3; + return ierr; +} diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90 b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90 new file mode 100644 index 0000000..4a11e22 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90 @@ -0,0 +1,244 @@ +! { dg-do run } +! { dg-additional-sources ISO_Fortran_binding_1.c } +! +! Test F2008 18.5: ISO_Fortran_binding.h functions. +! + USE, INTRINSIC :: ISO_C_BINDING + + TYPE, BIND(C) :: T + REAL(C_DOUBLE) :: X + complex(C_DOUBLE_COMPLEX) :: Y + END TYPE + + type :: mytype + integer :: i + integer :: j + end type + + INTERFACE + FUNCTION elemental_mult(a, b, c) BIND(C, NAME="elemental_mult_c") RESULT(err) + USE, INTRINSIC :: ISO_C_BINDING + INTEGER(C_INT) :: err + type(*), DIMENSION(..) :: a, b, c + END FUNCTION elemental_mult + + FUNCTION c_deallocate(a) BIND(C, NAME="deallocate_c") RESULT(err) + USE, INTRINSIC :: ISO_C_BINDING + INTEGER(C_INT) :: err + type(*), DIMENSION(..) :: a + END FUNCTION c_deallocate + + FUNCTION c_allocate(a, lower, upper) BIND(C, NAME="allocate_c") RESULT(err) + USE, INTRINSIC :: ISO_C_BINDING + INTEGER(C_INT) :: err + type(*), DIMENSION(..) :: a + integer(C_INTPTR_T), DIMENSION(15) :: lower, upper + END FUNCTION c_allocate + + FUNCTION c_establish(a) BIND(C, NAME="establish_c") RESULT(err) + USE, INTRINSIC :: ISO_C_BINDING + import + INTEGER(C_INT) :: err + type (T), DIMENSION(..), intent(out) :: a + END FUNCTION c_establish + + FUNCTION c_contiguous(a) BIND(C, NAME="contiguous_c") RESULT(err) + USE, INTRINSIC :: ISO_C_BINDING + INTEGER(C_INT) :: err + type(*), DIMENSION(..) :: a + END FUNCTION c_contiguous + + FUNCTION c_section(std_case, a, lower, strides) BIND(C, NAME="section_c") RESULT(ans) + USE, INTRINSIC :: ISO_C_BINDING + real(C_FLOAT) :: ans + INTEGER(C_INT) :: std_case + INTEGER(C_INT), dimension(15) :: lower + INTEGER(C_INT), dimension(15) :: strides + type(*), DIMENSION(..) :: a + END FUNCTION c_section + + FUNCTION c_select_part(a) BIND(C, NAME="select_part_c") RESULT(ans) + USE, INTRINSIC :: ISO_C_BINDING + real(C_DOUBLE) :: ans + type(*), DIMENSION(..) :: a + END FUNCTION c_select_part + + FUNCTION c_setpointer(a, lbounds) BIND(C, NAME="setpointer_c") RESULT(err) + USE, INTRINSIC :: ISO_C_BINDING + INTEGER(C_INT) :: err + INTEGER(C_INT), dimension(2) :: lbounds + type(*), DIMENSION(..) :: a + END FUNCTION c_setpointer + + FUNCTION c_assumed_size(a) BIND(C, NAME="assumed_size_c") RESULT(err) + USE, INTRINSIC :: ISO_C_BINDING + INTEGER(C_INT) :: err + type(*), DIMENSION(..) :: a + END FUNCTION c_assumed_size + + END INTERFACE + + integer, dimension(:,:), allocatable :: x, y, z + integer, dimension(2,2) :: a, b, c + integer, dimension(4,4) :: d + integer :: i = 42, j, k + integer(C_INTPTR_T), dimension(15) :: lower, upper + real, dimension(10,10) :: arg + type (mytype), dimension(2,2) :: der + + allocate (x, source = reshape ([4,3,2,1], [2,2])) + allocate (y, source = reshape ([2,3,4,5], [2,2])) + allocate (z, source = reshape ([0,0,0,0], [2,2])) + + call test_CFI_address + call test_CFI_deallocate + call test_CFI_allocate + call test_CFI_establish + call test_CFI_contiguous (a) + call test_CFI_section (arg) + call test_CFI_select_part + call test_CFI_setpointer + call test_assumed_size (a) +contains + subroutine test_CFI_address +! Basic test that CFI_desc_t can be passed and that CFI_address works + if (elemental_mult (z, x, y) .ne. 0) stop 1 + if (any (z .ne. reshape ([8,9,8,5], [2,2]))) stop 2 + + a = reshape ([4,3,2,1], [2,2]) + b = reshape ([2,3,4,5], [2,2]) + c = 0 +! Verify that components of arrays of derived types are OK. + der%j = a +! Check that non-pointer/non-allocatable arguments are OK + if (elemental_mult (c, der%j, b) .ne. 0) stop 3 + if (any (c .ne. reshape ([8,9,8,5], [2,2]))) stop 4 + +! Check array sections + d = 0 + d(4:2:-2, 1:3:2) = b + if (elemental_mult (c, a, d(4:2:-2, 1:3:2)) .ne. 0) stop 5 + if (any (c .ne. reshape ([8,9,8,5], [2,2]))) stop 6 + +! If a scalar result is passed to 'elemental_mult' it is returned +! as the function result and then zeroed. This tests that scalars +! are correctly converted to CF_desc_t. + if ((elemental_mult (i, a, b) .ne. 42) & + .or. (i .ne. 0)) stop 7 + deallocate (y,z) +end subroutine test_CFI_address + + subroutine test_CFI_deallocate +! Test CFI_deallocate. + if (c_deallocate (x) .ne. 0) stop 8 + if (allocated (x)) stop 9 + end subroutine test_CFI_deallocate + + subroutine test_CFI_allocate +! Test CFI_allocate. + lower(1:2) = [2,2] + upper(1:2) = [10,10] + + if (c_allocate (x, lower, upper) .ne. 0) stop 10 + if (.not.allocated (x)) stop 11 + if (any (lbound (x) .ne. lower(1:2))) stop 12 + if (any (ubound (x) .ne. upper(1:2))) stop 13 + +! Elements are filled by 'c_allocate' with the product of the fortran indices + do j = lower(1) , upper(1) + do k = lower(2) , upper(2) + x(j,k) = x(j,k) - j * k + end do + end do + if (any (x .ne. 0)) stop 14 + deallocate (x) + end subroutine test_CFI_allocate + + subroutine test_CFI_establish +! Test CFI_establish. + type(T), pointer :: case2(:) => null() + if (c_establish(case2) .ne. 0) stop 14 + if (ubound(case2, 1) .ne. 9) stop 15 + if (.not.associated(case2)) stop 16 + if (sizeof(case2) .ne. 240) stop 17 + if (int (sum (case2%x)) .ne. 55) stop 18 + if (int (sum (imag (case2%y))) .ne. 110) stop 19 + deallocate (case2) + end subroutine test_CFI_establish + + subroutine test_CFI_contiguous (arg) + integer, dimension (2,*) :: arg + character(4), dimension(2) :: chr +! These are contiguous + if (c_contiguous (arg) .ne. 0) stop 20 + if (.not.allocated (x)) allocate (x(2, 2)) + if (c_contiguous (x) .ne. 0) stop 22 + deallocate (x) + if (c_contiguous (chr) .ne. 0) stop 23 +! These are not contiguous + if (c_contiguous (der%i) .eq. 0) stop 24 + if (c_contiguous (arg(1:1,1:2)) .eq. 0) stop 25 + if (c_contiguous (d(4:2:-2, 1:3:2)) .eq. 0) stop 26 + if (c_contiguous (chr(:)(2:3)) .eq. 0) stop 27 + end subroutine test_CFI_contiguous + + subroutine test_CFI_section (arg) + real, dimension (100) :: a + real, dimension (10,*) :: arg + integer, dimension(15) :: lower, strides + integer :: i + +! Case (i) from F2018:18.5.5.7. + a = [(real(i), i = 1, 100)] + lower(1) = 10 + strides(1) = 5 + if (int (sum(a(lower(1)::strides(1))) & + - c_section(1, a, lower, strides)) .ne. 0) stop 28 +! Case (ii) from F2018:18.5.5.7. + arg(:,1:10) = reshape ([(real(i), i = 1, 100)], [10,10]) + lower(1) = 1 + lower(2) = 5 + strides(1) = 1 + strides(2) = 0 + if (int (sum(arg(:,5)) & + - c_section (2, arg, lower, strides)) .ne. 0) stop 29 + end subroutine test_CFI_section + + subroutine test_CFI_select_part +! Test the example from F2018:18.5.5.8. +! Modify to take rank 2 and sum the section type_t(5, :)%y%im +! Note that sum_z_5 = sum (type_t(5, :)%y%im) is broken on Darwin. +! + type (t), dimension(10, 10) :: type_t + real(kind(type_t%x)) :: v, sum_z_5 = 0.0 + complex(kind(type_t%y)) :: z +! Set the array 'type_t'. + do j = 1, 10 + do k = 1, 10 + v = dble (j * k) + z = cmplx (2 * v, 3 * v) + type_t(j, k) = t (v, z) + if (j .eq. 5) sum_z_5 = sum_z_5 + imag (z) + end do + end do +! Now do the test. + if (int (c_select_part (type_t) - sum_z_5) .ne. 0) stop 28 + end subroutine test_CFI_select_part + + subroutine test_CFI_setpointer +! Test the example from F2018:18.5.5.9. + integer, dimension(:,:), pointer :: ptr => NULL () + integer, dimension(2,2), target :: tgt + integer, dimension(2) :: lbounds = [-1, -2] +! The C-function resets the lbounds + ptr(1:, 1:) => tgt + if (c_setpointer (ptr, lbounds) .ne. 0) stop 30 + if (any (lbound(ptr) .ne. lbounds)) stop 31 + end subroutine test_CFI_setpointer + + subroutine test_assumed_size (arg) + integer, dimension(2,*) :: arg +! The C-function checks contiguousness and that extent[1] == -1. + if (c_assumed_size (arg) .ne. 0) stop 32 + end subroutine +end diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_2.c b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_2.c new file mode 100644 index 0000000..1c1af20 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_2.c @@ -0,0 +1,115 @@ +/* Test F2018 18.5: ISO_Fortran_binding.h functions. */ + +#include <ISO_Fortran_binding.h> +#include <stdio.h> +#include <stdlib.h> +#include <complex.h> + +/* Test the example in F2018 C.12.9: Processing assumed-shape arrays in C, + modified to use CFI_address instead of pointer arithmetic. */ + +int address_c(CFI_cdesc_t * a_desc, const int idx[]) +{ + int *res_addr; + CFI_index_t CFI_idx[1]; + + CFI_idx[0] = (CFI_index_t)idx[0]; + + res_addr = CFI_address (a_desc, CFI_idx); + if (res_addr == NULL) + return -1; + return *res_addr; +} + + +int deallocate_c(CFI_cdesc_t * dd) +{ + return CFI_deallocate(dd); +} + + +int allocate_c(CFI_cdesc_t * da, CFI_index_t lower[], CFI_index_t upper[]) +{ + return CFI_allocate(da, lower, upper, 0); +} + +int establish_c(CFI_cdesc_t * desc, int *rank, int *attr) +{ + typedef struct {double x; double _Complex y;} t; + int err; + CFI_index_t idx[1], extent[1]; + void *ptr; + + extent[0] = 1; + ptr = malloc ((size_t)(extent[0] * sizeof(t))); + err = CFI_establish((CFI_cdesc_t *)desc, + ptr, + (CFI_attribute_t)*attr, + CFI_type_struct, + sizeof(t), (CFI_rank_t)*rank, extent); + free (ptr); + return err; +} + +int contiguous_c(CFI_cdesc_t * desc) +{ + return CFI_is_contiguous(desc); +} + +float section_c(int *std_case, CFI_cdesc_t * source, int *low, int *str) +{ + CFI_index_t idx[CFI_MAX_RANK], lower[CFI_MAX_RANK], + strides[CFI_MAX_RANK], upper[CFI_MAX_RANK]; + CFI_CDESC_T(1) section; + int ind, size; + float *ret_addr; + float ans = 0.0; + + if (*std_case == 1) + { + lower[0] = (CFI_index_t)low[0]; + strides[0] = (CFI_index_t)str[0]; + ind = CFI_establish((CFI_cdesc_t *)§ion, NULL, CFI_attribute_other, + CFI_type_float, 0, 1, NULL); + if (ind) return -1.0; + ind = CFI_section((CFI_cdesc_t *)§ion, source, lower, NULL, strides); + if (ind) return (float)ind; + } + + return 0.0; +} + + +int select_part_c (CFI_cdesc_t * source) +{ + typedef struct + { + double x; + double _Complex y; + } t; + CFI_CDESC_T(2) component; + CFI_cdesc_t * comp_cdesc = (CFI_cdesc_t *)&component; + CFI_index_t extent[] = {10,10}; + CFI_index_t idx[] = {4,0}; + int res; + + res = CFI_establish(comp_cdesc, NULL, CFI_attribute_other, + CFI_type_double_Complex, sizeof(double _Complex), + 2, extent); + if (res) + return res; + + res = CFI_select_part(comp_cdesc, source, offsetof(t,y), 0); + + return res; +} + + +int setpointer_c(CFI_cdesc_t * ptr1, CFI_cdesc_t * ptr2, int lbounds[]) +{ + CFI_index_t lower_bounds[] = {lbounds[0],lbounds[1]}; + int ind; + + ind = CFI_setpointer(ptr1, ptr2, lower_bounds); + return ind; +} diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_2.f90 b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_2.f90 new file mode 100644 index 0000000..2670045 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_2.f90 @@ -0,0 +1,193 @@ +! { dg-do run } +! { dg-additional-sources ISO_Fortran_binding_2.c } +! { dg-options "-fbounds-check" } +! +! Test F2018 18.5: ISO_Fortran_binding.h function errors. +! + USE, INTRINSIC :: ISO_C_BINDING + + TYPE, BIND(C) :: T + REAL(C_DOUBLE) :: X + complex(C_DOUBLE_COMPLEX) :: Y + END TYPE + + type :: mytype + integer :: i + integer :: j + end type + + INTERFACE + FUNCTION c_address(a, idx) BIND(C, NAME="address_c") RESULT(err) + USE, INTRINSIC :: ISO_C_BINDING + INTEGER(C_INT) :: err + INTEGER(C_INT), dimension(1) :: idx + type(*), DIMENSION(..) :: a + END FUNCTION c_address + + FUNCTION c_deallocate(a) BIND(C, NAME="deallocate_c") RESULT(err) + USE, INTRINSIC :: ISO_C_BINDING + INTEGER(C_INT) :: err + type(*), DIMENSION(..) :: a + END FUNCTION c_deallocate + + FUNCTION c_allocate(a, lower, upper) BIND(C, NAME="allocate_c") RESULT(err) + USE, INTRINSIC :: ISO_C_BINDING + INTEGER(C_INT) :: err + type(*), DIMENSION(..) :: a + integer(C_INTPTR_T), DIMENSION(15) :: lower, upper + END FUNCTION c_allocate + + FUNCTION c_establish(a, rank, attr) BIND(C, NAME="establish_c") RESULT(err) + USE, INTRINSIC :: ISO_C_BINDING + import + INTEGER(C_INT) :: err + INTEGER(C_INT) :: rank, attr + type (T), DIMENSION(..), intent(out) :: a + END FUNCTION c_establish + + FUNCTION c_contiguous(a) BIND(C, NAME="contiguous_c") RESULT(err) + USE, INTRINSIC :: ISO_C_BINDING + INTEGER(C_INT) :: err + type(*), DIMENSION(..) :: a + END FUNCTION c_contiguous + + FUNCTION c_section(std_case, a, lower, strides) BIND(C, NAME="section_c") RESULT(ans) + USE, INTRINSIC :: ISO_C_BINDING + real(C_FLOAT) :: ans + INTEGER(C_INT) :: std_case + INTEGER(C_INT), dimension(15) :: lower + INTEGER(C_INT), dimension(15) :: strides + type(*), DIMENSION(..) :: a + END FUNCTION c_section + + FUNCTION c_select_part(a) BIND(C, NAME="select_part_c") RESULT(ans) + USE, INTRINSIC :: ISO_C_BINDING + INTEGER(C_INT) :: ans + type(*), DIMENSION(..) :: a + END FUNCTION c_select_part + + FUNCTION c_setpointer(a, b, lbounds) BIND(C, NAME="setpointer_c") RESULT(err) + USE, INTRINSIC :: ISO_C_BINDING + INTEGER(C_INT) :: err + INTEGER(C_INT), dimension(2) :: lbounds + type(*), DIMENSION(..) :: a, b + END FUNCTION c_setpointer + END INTERFACE + + integer(C_INTPTR_T), dimension(15) :: lower, upper + + call test_CFI_address + call test_CFI_deallocate + call test_CFI_allocate + call test_CFI_establish + call test_CFI_contiguous + call test_CFI_section + call test_CFI_select_part + call test_CFI_setpointer + +contains + subroutine test_CFI_address + integer, dimension(:), allocatable :: a + allocate (a, source = [1,2,3]) + if (c_address (a, [2]) .ne. 3) stop 1 ! OK + if (c_address (a, [3]) .ne. -1) stop 2 ! "subscripts[0], is out of bounds" + if (c_address (a, [-1]) .ne. -1) stop 3 ! "subscripts[0], is out of bounds" + deallocate (a) + if (c_address (a, [2]) .ne. -1) stop 4 ! "C Descriptor must not be NULL" + end subroutine test_CFI_address + + subroutine test_CFI_deallocate + integer, dimension(:), allocatable :: a + integer, dimension(2,2) :: b + if (c_deallocate (a) .ne. 2) stop 5 ! "Base address is already NULL" + allocate (a(2)) + if (c_deallocate (a) .ne. 0) stop 6 ! OK + if (c_deallocate (b) .ne. 7) stop 7 ! "must describe a pointer or allocatable" + end subroutine test_CFI_deallocate + + subroutine test_CFI_allocate + integer, dimension(:,:), allocatable :: a + integer, dimension(2,2) :: b + lower(1:2) = [2,2] + upper(1:2) = [10,10] + allocate (a(1,1)) + if (c_allocate (a, lower, upper) .ne. 3) stop 8 ! "C descriptor must be NULL" + if (allocated (a)) deallocate (a) + if (c_allocate (a, lower, upper) .ne. 0) stop 9 ! OK + if (c_allocate (b, lower, upper) .ne. 7) STOP 10 ! "must describe a pointer or allocatable" + end subroutine test_CFI_allocate + + subroutine test_CFI_establish + type(T), allocatable :: a(:) + INTEGER(C_INT) :: rank + INTEGER(C_INT) :: attr + attr = 0 ! establish a pointer + rank = 16 + if (c_establish (a, rank, attr) .ne. 5) stop 11 ! "Rank must be between 0 and 15" + rank = 1 + if (c_establish (a, rank, attr) .ne. 0) stop 12 ! OK + if (allocated (a)) deallocate (a) + if (c_establish (a, rank, attr) .ne. 0) Stop 13 ! OK the first time + if (c_establish (a, rank, attr) .ne. 10) Stop 14 ! "its base address must be NULL" + if (allocated (a)) deallocate (a) + attr = 1 ! establish an allocatable + if (c_establish (a, rank, attr) .ne. 7) Stop 15 ! "is for a nonallocatable entity" + end subroutine test_CFI_establish + + subroutine test_CFI_contiguous + integer, allocatable :: a + if (c_contiguous (a) .ne. 2) stop 16 ! "Descriptor is already NULL" + allocate (a) + if (c_contiguous (a) .ne. 5) stop 17 ! "must describe an array" + end subroutine test_CFI_contiguous + + subroutine test_CFI_section + real, allocatable, dimension (:) :: a + integer, dimension(15) :: lower, strides + integer :: i + real :: b + lower(1) = 10 + strides(1) = 5 + if (int (c_section (1, a, lower, strides)) .ne. 2) & + stop 18 ! "Base address of source must not be NULL" + allocate (a(100)) + if (int (c_section (1, a, lower, strides)) .ne. 0) & + stop 19 ! OK + if (int (c_section (1, b, lower, strides)) .ne. 5) & + stop 20 ! "Source must describe an array" + strides(1) = 0 + if (int (c_section (1, a, lower, strides)) .ne. 5) & + stop 21 ! "Rank of result must be equal to the rank of source" + strides(1) = 5 + lower(1) = -1 + if (int (c_section (1, a, lower, strides)) .ne. 12) & + stop 22 ! "Lower bounds must be within the bounds of the fortran array" + lower(1) = 100 + if (int (c_section (1, a, lower, strides)) .ne. 12) & + stop 23 ! "Lower bounds must be within the bounds of the fortran array" + end subroutine test_CFI_section + + subroutine test_CFI_select_part + type(t), allocatable, dimension(:) :: a + type(t) :: src + allocate (a(1), source = src) + if (c_select_part (a) .ne. 5) stop 24 ! "Source and result must have the same rank" + deallocate (a) + if (c_select_part (a) .ne. 2) stop 25 ! "source must not be NULL" + end subroutine test_CFI_select_part + + subroutine test_CFI_setpointer + integer, dimension(2,2), target :: tgt1 + integer, dimension(:,:), pointer :: src + type (t), dimension(2), target :: tgt2 + type (t), dimension(:), pointer :: res + type (t), dimension(2, 2), target, save :: tgt3 + type (t), dimension(:, :), pointer :: src1 + integer, dimension(2) :: lbounds = [-1, -2] + src => tgt1 + res => tgt2 + if (c_setpointer (res, src, lbounds) .ne. 4) stop 26 ! "Element lengths" + src1 => tgt3 + if (c_setpointer (res, src1, lbounds) .ne. 5) stop 27 ! "Ranks of result" + end subroutine test_CFI_setpointer +end diff --git a/gcc/testsuite/gfortran.dg/bind_c_array_params_2.f90 b/gcc/testsuite/gfortran.dg/bind_c_array_params_2.f90 index 25f5dda..ad7a9aa 100644 --- a/gcc/testsuite/gfortran.dg/bind_c_array_params_2.f90 +++ b/gcc/testsuite/gfortran.dg/bind_c_array_params_2.f90 @@ -5,7 +5,7 @@ ! ! Check that assumed-shape variables are correctly passed to BIND(C) ! as defined in TS 29913 -! +! interface subroutine test (xx) bind(C, name="myBindC") type(*), dimension(:,:) :: xx @@ -20,4 +20,4 @@ end ! { dg-final { scan-assembler-times "myBindC,%r2" 1 { target { hppa*-*-* } } } } ! { dg-final { scan-assembler-times "call\tmyBindC" 1 { target { *-*-cygwin* } } } } ! { dg-final { scan-assembler-times "brasl\t%r\[0-9\]*,myBindC" 1 { target { s390*-*-* } } } } -! { dg-final { scan-tree-dump-times "test \\\(&parm\\." 1 "original" } } +! { dg-final { scan-tree-dump-times "cfi_desc_to_gfc_desc \\\(&parm\\." 1 "original" } } |