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
This commit is contained in:
Paul Thomas
parent
af79605ec2
commit
bbf18dc5d2
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -292,6 +292,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)
|
||||
{
|
||||
|
|
@ -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)
|
||||
{
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
}
|
||||
|
|
@ -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
|
||||
|
|
@ -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;
|
||||
}
|
||||
|
|
@ -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
|
||||
|
|
@ -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" } }
|
||||
|
|
|
|||
|
|
@ -1,3 +1,14 @@
|
|||
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.
|
||||
|
||||
2019-01-12 Jakub Jelinek <jakub@redhat.com>
|
||||
|
||||
PR libfortran/88807
|
||||
|
|
|
|||
|
|
@ -0,0 +1,206 @@
|
|||
/* Declarations for ISO Fortran binding.
|
||||
Copyright (C) 2018 Free Software Foundation, Inc.
|
||||
Contributed by Daniel Celis Garza <celisdanieljr@gmail.com>
|
||||
|
||||
This file is part of the GNU Fortran runtime library (libgfortran).
|
||||
|
||||
Libgfortran is free software; you can redistribute it and/or modify
|
||||
it under the terms of the GNU General Public License as published by
|
||||
the Free Software Foundation; either version 3, or (at your option)
|
||||
any later version.
|
||||
|
||||
Libgfortran is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
Under Section 7 of GPL version 3, you are granted additional
|
||||
permissions described in the GCC Runtime Library Exception, version
|
||||
3.1, as published by the Free Software Foundation.
|
||||
|
||||
You should have received a copy of the GNU General Public License and
|
||||
a copy of the GCC Runtime Library Exception along with this program;
|
||||
see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
||||
<http://www.gnu.org/licenses/>. */
|
||||
|
||||
#ifndef ISO_FORTRAN_BINDING_H
|
||||
#define ISO_FORTRAN_BINDING_H
|
||||
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
|
||||
#include <stddef.h> /* Standard ptrdiff_t tand size_t. */
|
||||
#include <stdint.h> /* Integer types. */
|
||||
|
||||
/* Constants, defined as macros. */
|
||||
#define CFI_VERSION 1
|
||||
#define CFI_MAX_RANK 15
|
||||
|
||||
/* Attributes. */
|
||||
#define CFI_attribute_pointer 0
|
||||
#define CFI_attribute_allocatable 1
|
||||
#define CFI_attribute_other 2
|
||||
|
||||
/* Error codes.
|
||||
CFI_INVALID_STRIDE should be defined in the standard because they are useful to the implementation of the functions.
|
||||
*/
|
||||
#define CFI_SUCCESS 0
|
||||
#define CFI_FAILURE 1
|
||||
#define CFI_ERROR_BASE_ADDR_NULL 2
|
||||
#define CFI_ERROR_BASE_ADDR_NOT_NULL 3
|
||||
#define CFI_INVALID_ELEM_LEN 4
|
||||
#define CFI_INVALID_RANK 5
|
||||
#define CFI_INVALID_TYPE 6
|
||||
#define CFI_INVALID_ATTRIBUTE 7
|
||||
#define CFI_INVALID_EXTENT 8
|
||||
#define CFI_INVALID_STRIDE 9
|
||||
#define CFI_INVALID_DESCRIPTOR 10
|
||||
#define CFI_ERROR_MEM_ALLOCATION 11
|
||||
#define CFI_ERROR_OUT_OF_BOUNDS 12
|
||||
|
||||
/* CFI type definitions. */
|
||||
typedef ptrdiff_t CFI_index_t;
|
||||
typedef int8_t CFI_rank_t;
|
||||
typedef int8_t CFI_attribute_t;
|
||||
typedef int16_t CFI_type_t;
|
||||
|
||||
/* CFI_dim_t. */
|
||||
typedef struct CFI_dim_t
|
||||
{
|
||||
CFI_index_t lower_bound;
|
||||
CFI_index_t extent;
|
||||
CFI_index_t sm;
|
||||
}
|
||||
CFI_dim_t;
|
||||
|
||||
/* CFI_cdesc_t, C descriptors are cast to this structure as follows:
|
||||
CFI_CDESC_T(CFI_MAX_RANK) foo;
|
||||
CFI_cdesc_t * bar = (CFI_cdesc_t *) &foo;
|
||||
*/
|
||||
typedef struct CFI_cdesc_t
|
||||
{
|
||||
void *base_addr;
|
||||
size_t elem_len;
|
||||
int version;
|
||||
CFI_rank_t rank;
|
||||
CFI_attribute_t attribute;
|
||||
CFI_type_t type;
|
||||
CFI_dim_t dim[];
|
||||
}
|
||||
CFI_cdesc_t;
|
||||
|
||||
/* CFI_CDESC_T with an explicit type. */
|
||||
#define CFI_CDESC_TYPE_T(r, base_type) \
|
||||
struct { \
|
||||
base_type *base_addr; \
|
||||
size_t elem_len; \
|
||||
int version; \
|
||||
CFI_rank_t rank; \
|
||||
CFI_attribute_t attribute; \
|
||||
CFI_type_t type; \
|
||||
CFI_dim_t dim[r]; \
|
||||
}
|
||||
#define CFI_CDESC_T(r) CFI_CDESC_TYPE_T (r, void)
|
||||
|
||||
/* CFI function declarations. */
|
||||
extern void *CFI_address (const CFI_cdesc_t *, const CFI_index_t []);
|
||||
extern int CFI_allocate (CFI_cdesc_t *, const CFI_index_t [], const CFI_index_t [],
|
||||
size_t);
|
||||
extern int CFI_deallocate (CFI_cdesc_t *);
|
||||
extern int CFI_establish (CFI_cdesc_t *, void *, CFI_attribute_t, CFI_type_t, size_t,
|
||||
CFI_rank_t, const CFI_index_t []);
|
||||
extern int CFI_is_contiguous (const CFI_cdesc_t *);
|
||||
extern int CFI_section (CFI_cdesc_t *, const CFI_cdesc_t *, const CFI_index_t [],
|
||||
const CFI_index_t [], const CFI_index_t []);
|
||||
extern int CFI_select_part (CFI_cdesc_t *, const CFI_cdesc_t *, size_t, size_t);
|
||||
extern int CFI_setpointer (CFI_cdesc_t *, CFI_cdesc_t *, const CFI_index_t []);
|
||||
|
||||
/* Types and kind numbers. Allows bitwise and to reveal the intrinsic type of a kind type. It also allows us to find the kind parameter by inverting the bit-shift equation.
|
||||
CFI_type_kind_shift = 8
|
||||
CFI_intrinsic_type = 0 0 0 0 0 0 0 0 0 0 1 0
|
||||
CFI_type_kind = 0 0 0 0 0 0 0 0 1 0 0 0
|
||||
CFI_type_example = CFI_intrinsic_type + (CFI_type_kind << CFI_type_kind_shift)
|
||||
Defining the CFI_type_example.
|
||||
CFI_type_kind = 0 0 0 0 0 0 0 0 1 0 0 0 << CFI_type_kind_shift
|
||||
-------------------------
|
||||
1 0 0 0 0 0 0 0 0 0 0 0 +
|
||||
CFI_intrinsic_type = 0 0 0 0 0 0 0 0 0 0 1 0
|
||||
-------------------------
|
||||
CFI_type_example = 1 0 0 0 0 0 0 0 0 0 1 0
|
||||
Finding the intrinsic type with the logical mask.
|
||||
CFI_type_example = 1 0 0 0 0 0 0 0 0 0 1 0 &
|
||||
CFI_type_mask = 0 0 0 0 1 1 1 1 1 1 1 1
|
||||
-------------------------
|
||||
CFI_intrinsic_type = 0 0 0 0 0 0 0 0 0 0 1 0
|
||||
Using the intrinsic type and kind shift to find the kind value of the type.
|
||||
CFI_type_kind = (CFI_type_example - CFI_intrinsic_type) >> CFI_type_kind_shift
|
||||
CFI_type_example = 1 0 0 0 0 0 0 0 0 0 1 0 -
|
||||
CFI_intrinsic_type = 0 0 0 0 0 0 0 0 0 0 1 0
|
||||
-------------------------
|
||||
1 0 0 0 0 0 0 0 0 0 0 0 >> CFI_type_kind_shift
|
||||
-------------------------
|
||||
CFI_type_kind = 0 0 0 0 0 0 0 0 1 0 0 0
|
||||
*/
|
||||
#define CFI_type_mask 0xFF
|
||||
#define CFI_type_kind_shift 8
|
||||
|
||||
/* Intrinsic types. Their kind number defines their storage size. */
|
||||
#define CFI_type_Integer 1
|
||||
#define CFI_type_Logical 2
|
||||
#define CFI_type_Real 3
|
||||
#define CFI_type_Complex 4
|
||||
#define CFI_type_Character 5
|
||||
|
||||
/* Types with no kind. */
|
||||
#define CFI_type_struct 6
|
||||
#define CFI_type_cptr 7
|
||||
#define CFI_type_cfunptr 8
|
||||
#define CFI_type_other -1
|
||||
|
||||
/* Types with kind parameter.
|
||||
The kind parameter represents the type's byte size. The exception is kind = 10, which has byte size of 64 but 80 bit precision. Complex variables are double the byte size of their real counterparts. The ucs4_char matches wchar_t if sizeof (wchar_t) == 4.
|
||||
*/
|
||||
#define CFI_type_char (CFI_type_Character + (1 << CFI_type_kind_shift))
|
||||
#define CFI_type_ucs4_char (CFI_type_Character + (4 << CFI_type_kind_shift))
|
||||
|
||||
/* C-Fortran Interoperability types. */
|
||||
#define CFI_type_signed_char (CFI_type_Integer + (1 << CFI_type_kind_shift))
|
||||
#define CFI_type_short (CFI_type_Integer + (2 << CFI_type_kind_shift))
|
||||
#define CFI_type_int (CFI_type_Integer + (4 << CFI_type_kind_shift))
|
||||
#define CFI_type_long (CFI_type_Integer + (8 << CFI_type_kind_shift))
|
||||
#define CFI_type_long_long (CFI_type_Integer + (8 << CFI_type_kind_shift))
|
||||
#define CFI_type_size_t (CFI_type_Integer + (8 << CFI_type_kind_shift))
|
||||
#define CFI_type_int8_t (CFI_type_Integer + (1 << CFI_type_kind_shift))
|
||||
#define CFI_type_int16_t (CFI_type_Integer + (2 << CFI_type_kind_shift))
|
||||
#define CFI_type_int32_t (CFI_type_Integer + (4 << CFI_type_kind_shift))
|
||||
#define CFI_type_int64_t (CFI_type_Integer + (8 << CFI_type_kind_shift))
|
||||
#define CFI_type_int_least8_t (CFI_type_Integer + (1 << CFI_type_kind_shift))
|
||||
#define CFI_type_int_least16_t (CFI_type_Integer + (2 << CFI_type_kind_shift))
|
||||
#define CFI_type_int_least32_t (CFI_type_Integer + (4 << CFI_type_kind_shift))
|
||||
#define CFI_type_int_least64_t (CFI_type_Integer + (8 << CFI_type_kind_shift))
|
||||
#define CFI_type_int_fast8_t (CFI_type_Integer + (1 << CFI_type_kind_shift))
|
||||
#define CFI_type_int_fast16_t (CFI_type_Integer + (2 << CFI_type_kind_shift))
|
||||
#define CFI_type_int_fast32_t (CFI_type_Integer + (4 << CFI_type_kind_shift))
|
||||
#define CFI_type_int_fast64_t (CFI_type_Integer + (8 << CFI_type_kind_shift))
|
||||
#define CFI_type_intmax_t (CFI_type_Integer + (8 << CFI_type_kind_shift))
|
||||
#define CFI_type_intptr_t (CFI_type_Integer + (8 << CFI_type_kind_shift))
|
||||
#define CFI_type_ptrdiff_t (CFI_type_Integer + (8 << CFI_type_kind_shift))
|
||||
#define CFI_type_int128_t (CFI_type_Integer + (16 << CFI_type_kind_shift))
|
||||
#define CFI_type_int_least128_t (CFI_type_Integer + (16 << CFI_type_kind_shift))
|
||||
#define CFI_type_int_fast128_t (CFI_type_Integer + (16 << CFI_type_kind_shift))
|
||||
#define CFI_type_Bool (CFI_type_Logical + (1 << CFI_type_kind_shift))
|
||||
#define CFI_type_float (CFI_type_Real + (4 << CFI_type_kind_shift))
|
||||
#define CFI_type_double (CFI_type_Real + (8 << CFI_type_kind_shift))
|
||||
#define CFI_type_long_double (CFI_type_Real + (10 << CFI_type_kind_shift))
|
||||
#define CFI_type_float128 (CFI_type_Real + (16 << CFI_type_kind_shift))
|
||||
#define CFI_type_float_Complex (CFI_type_Complex + (4 << CFI_type_kind_shift))
|
||||
#define CFI_type_double_Complex (CFI_type_Complex + (8 << CFI_type_kind_shift))
|
||||
#define CFI_type_long_double_Complex (CFI_type_Complex + (10 << CFI_type_kind_shift))
|
||||
#define CFI_type_float128_Complex (CFI_type_Complex + (16 << CFI_type_kind_shift))
|
||||
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
|
||||
#endif /* ISO_FORTRAN_BINDING_H */
|
||||
|
|
@ -30,6 +30,9 @@ version_arg =
|
|||
version_dep =
|
||||
endif
|
||||
|
||||
gfor_c_HEADERS = $(srcdir)/ISO_Fortran_binding.h
|
||||
gfor_cdir = $(libdir)/gcc/$(target_alias)/$(gcc_version)$(MULTISUBDIR)/include
|
||||
|
||||
LTLDFLAGS = $(shell $(SHELL) $(top_srcdir)/../libtool-ldflags $(LDFLAGS)) \
|
||||
$(lt_host_flags)
|
||||
|
||||
|
|
@ -783,6 +786,9 @@ $(srcdir)/generated/spread_c8.c \
|
|||
$(srcdir)/generated/spread_c10.c \
|
||||
$(srcdir)/generated/spread_c16.c
|
||||
|
||||
i_isobinding_c = \
|
||||
$(srcdir)/runtime/ISO_Fortran_binding.c
|
||||
|
||||
m4_files= m4/iparm.m4 m4/ifunction.m4 m4/iforeach.m4 m4/all.m4 \
|
||||
m4/any.m4 m4/count.m4 m4/maxloc0.m4 m4/maxloc1.m4 m4/maxval.m4 \
|
||||
m4/minloc0.m4 m4/minloc1.m4 m4/minval.m4 m4/product.m4 m4/sum.m4 \
|
||||
|
|
@ -810,7 +816,7 @@ gfor_built_src= $(i_all_c) $(i_any_c) $(i_count_c) $(i_maxloc0_c) \
|
|||
$(i_minloc1s_c) $(i_maxloc2s_c) $(i_minloc2s_c) $(i_maxvals_c) \
|
||||
$(i_maxval0s_c) $(i_minval0s_c) $(i_maxval1s_c) $(i_minval1s_c) \
|
||||
$(i_findloc0_c) $(i_findloc0s_c) $(i_findloc1_c) $(i_findloc1s_c) \
|
||||
$(i_findloc2s_c)
|
||||
$(i_findloc2s_c) $(i_isobinding_c)
|
||||
|
||||
# Machine generated specifics
|
||||
gfor_built_specific_src= \
|
||||
|
|
|
|||
|
|
@ -179,7 +179,7 @@ am__aclocal_m4_deps = $(top_srcdir)/../config/depstand.m4 \
|
|||
am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \
|
||||
$(ACLOCAL_M4)
|
||||
DIST_COMMON = $(srcdir)/Makefile.am $(top_srcdir)/configure \
|
||||
$(am__configure_deps)
|
||||
$(am__configure_deps) $(gfor_c_HEADERS)
|
||||
am__CONFIG_DISTCLEAN_FILES = config.status config.cache config.log \
|
||||
configure.lineno config.status.lineno
|
||||
mkinstalldirs = $(SHELL) $(top_srcdir)/../mkinstalldirs
|
||||
|
|
@ -215,7 +215,7 @@ am__uninstall_files_from_dir = { \
|
|||
}
|
||||
am__installdirs = "$(DESTDIR)$(cafexeclibdir)" \
|
||||
"$(DESTDIR)$(toolexeclibdir)" "$(DESTDIR)$(toolexeclibdir)" \
|
||||
"$(DESTDIR)$(fincludedir)"
|
||||
"$(DESTDIR)$(gfor_cdir)" "$(DESTDIR)$(fincludedir)"
|
||||
LTLIBRARIES = $(cafexeclib_LTLIBRARIES) $(toolexeclib_LTLIBRARIES)
|
||||
libcaf_single_la_LIBADD =
|
||||
am_libcaf_single_la_OBJECTS = single.lo
|
||||
|
|
@ -378,7 +378,8 @@ am__objects_49 = findloc1_i1.lo findloc1_i2.lo findloc1_i4.lo \
|
|||
findloc1_r16.lo findloc1_c4.lo findloc1_c8.lo findloc1_c16.lo
|
||||
am__objects_50 = findloc1_s1.lo findloc1_s4.lo
|
||||
am__objects_51 = findloc2_s1.lo findloc2_s4.lo
|
||||
am__objects_52 = $(am__objects_4) $(am__objects_5) $(am__objects_6) \
|
||||
am__objects_52 = ISO_Fortran_binding.lo
|
||||
am__objects_53 = $(am__objects_4) $(am__objects_5) $(am__objects_6) \
|
||||
$(am__objects_7) $(am__objects_8) $(am__objects_9) \
|
||||
$(am__objects_10) $(am__objects_11) $(am__objects_12) \
|
||||
$(am__objects_13) $(am__objects_14) $(am__objects_15) \
|
||||
|
|
@ -393,14 +394,15 @@ am__objects_52 = $(am__objects_4) $(am__objects_5) $(am__objects_6) \
|
|||
$(am__objects_40) $(am__objects_41) $(am__objects_42) \
|
||||
$(am__objects_43) $(am__objects_44) $(am__objects_45) \
|
||||
$(am__objects_46) $(am__objects_47) $(am__objects_48) \
|
||||
$(am__objects_49) $(am__objects_50) $(am__objects_51)
|
||||
@LIBGFOR_MINIMAL_FALSE@am__objects_53 = close.lo file_pos.lo format.lo \
|
||||
$(am__objects_49) $(am__objects_50) $(am__objects_51) \
|
||||
$(am__objects_52)
|
||||
@LIBGFOR_MINIMAL_FALSE@am__objects_54 = close.lo file_pos.lo format.lo \
|
||||
@LIBGFOR_MINIMAL_FALSE@ inquire.lo intrinsics.lo list_read.lo \
|
||||
@LIBGFOR_MINIMAL_FALSE@ lock.lo open.lo read.lo transfer.lo \
|
||||
@LIBGFOR_MINIMAL_FALSE@ transfer128.lo unit.lo unix.lo write.lo \
|
||||
@LIBGFOR_MINIMAL_FALSE@ fbuf.lo async.lo
|
||||
am__objects_54 = size_from_kind.lo $(am__objects_53)
|
||||
@LIBGFOR_MINIMAL_FALSE@am__objects_55 = access.lo c99_functions.lo \
|
||||
am__objects_55 = size_from_kind.lo $(am__objects_54)
|
||||
@LIBGFOR_MINIMAL_FALSE@am__objects_56 = access.lo c99_functions.lo \
|
||||
@LIBGFOR_MINIMAL_FALSE@ chdir.lo chmod.lo clock.lo cpu_time.lo \
|
||||
@LIBGFOR_MINIMAL_FALSE@ ctime.lo date_and_time.lo dtime.lo \
|
||||
@LIBGFOR_MINIMAL_FALSE@ env.lo etime.lo execute_command_line.lo \
|
||||
|
|
@ -410,19 +412,19 @@ am__objects_54 = size_from_kind.lo $(am__objects_53)
|
|||
@LIBGFOR_MINIMAL_FALSE@ rename.lo stat.lo symlnk.lo \
|
||||
@LIBGFOR_MINIMAL_FALSE@ system_clock.lo time.lo umask.lo \
|
||||
@LIBGFOR_MINIMAL_FALSE@ unlink.lo
|
||||
@IEEE_SUPPORT_TRUE@am__objects_56 = ieee_helper.lo
|
||||
am__objects_57 = associated.lo abort.lo args.lo cshift0.lo eoshift0.lo \
|
||||
@IEEE_SUPPORT_TRUE@am__objects_57 = ieee_helper.lo
|
||||
am__objects_58 = associated.lo abort.lo args.lo cshift0.lo eoshift0.lo \
|
||||
eoshift2.lo erfc_scaled.lo extends_type_of.lo fnum.lo \
|
||||
ierrno.lo ishftc.lo mvbits.lo move_alloc.lo pack_generic.lo \
|
||||
selected_char_kind.lo size.lo is_contiguous.lo spread_generic.lo \
|
||||
string_intrinsics.lo rand.lo random.lo reshape_generic.lo \
|
||||
reshape_packed.lo selected_int_kind.lo selected_real_kind.lo \
|
||||
unpack_generic.lo in_pack_generic.lo in_unpack_generic.lo \
|
||||
$(am__objects_55) $(am__objects_56)
|
||||
@IEEE_SUPPORT_TRUE@am__objects_58 = ieee_arithmetic.lo \
|
||||
ierrno.lo ishftc.lo is_contiguous.lo mvbits.lo move_alloc.lo \
|
||||
pack_generic.lo selected_char_kind.lo size.lo \
|
||||
spread_generic.lo string_intrinsics.lo rand.lo random.lo \
|
||||
reshape_generic.lo reshape_packed.lo selected_int_kind.lo \
|
||||
selected_real_kind.lo unpack_generic.lo in_pack_generic.lo \
|
||||
in_unpack_generic.lo $(am__objects_56) $(am__objects_57)
|
||||
@IEEE_SUPPORT_TRUE@am__objects_59 = ieee_arithmetic.lo \
|
||||
@IEEE_SUPPORT_TRUE@ ieee_exceptions.lo ieee_features.lo
|
||||
am__objects_59 =
|
||||
am__objects_60 = _abs_c4.lo _abs_c8.lo _abs_c10.lo _abs_c16.lo \
|
||||
am__objects_60 =
|
||||
am__objects_61 = _abs_c4.lo _abs_c8.lo _abs_c10.lo _abs_c16.lo \
|
||||
_abs_i4.lo _abs_i8.lo _abs_i16.lo _abs_r4.lo _abs_r8.lo \
|
||||
_abs_r10.lo _abs_r16.lo _aimag_c4.lo _aimag_c8.lo \
|
||||
_aimag_c10.lo _aimag_c16.lo _exp_r4.lo _exp_r8.lo _exp_r10.lo \
|
||||
|
|
@ -446,19 +448,19 @@ am__objects_60 = _abs_c4.lo _abs_c8.lo _abs_c10.lo _abs_c16.lo \
|
|||
_conjg_c4.lo _conjg_c8.lo _conjg_c10.lo _conjg_c16.lo \
|
||||
_aint_r4.lo _aint_r8.lo _aint_r10.lo _aint_r16.lo _anint_r4.lo \
|
||||
_anint_r8.lo _anint_r10.lo _anint_r16.lo
|
||||
am__objects_61 = _sign_i4.lo _sign_i8.lo _sign_i16.lo _sign_r4.lo \
|
||||
am__objects_62 = _sign_i4.lo _sign_i8.lo _sign_i16.lo _sign_r4.lo \
|
||||
_sign_r8.lo _sign_r10.lo _sign_r16.lo _dim_i4.lo _dim_i8.lo \
|
||||
_dim_i16.lo _dim_r4.lo _dim_r8.lo _dim_r10.lo _dim_r16.lo \
|
||||
_atan2_r4.lo _atan2_r8.lo _atan2_r10.lo _atan2_r16.lo \
|
||||
_mod_i4.lo _mod_i8.lo _mod_i16.lo _mod_r4.lo _mod_r8.lo \
|
||||
_mod_r10.lo _mod_r16.lo
|
||||
am__objects_62 = misc_specifics.lo
|
||||
am__objects_63 = $(am__objects_60) $(am__objects_61) $(am__objects_62) \
|
||||
am__objects_63 = misc_specifics.lo
|
||||
am__objects_64 = $(am__objects_61) $(am__objects_62) $(am__objects_63) \
|
||||
dprod_r8.lo f2c_specifics.lo random_init.lo
|
||||
am__objects_64 = $(am__objects_3) $(am__objects_52) $(am__objects_54) \
|
||||
$(am__objects_57) $(am__objects_58) $(am__objects_59) \
|
||||
$(am__objects_63)
|
||||
@onestep_FALSE@am_libgfortran_la_OBJECTS = $(am__objects_64)
|
||||
am__objects_65 = $(am__objects_3) $(am__objects_53) $(am__objects_55) \
|
||||
$(am__objects_58) $(am__objects_59) $(am__objects_60) \
|
||||
$(am__objects_64)
|
||||
@onestep_FALSE@am_libgfortran_la_OBJECTS = $(am__objects_65)
|
||||
@onestep_TRUE@am_libgfortran_la_OBJECTS = libgfortran_c.lo
|
||||
libgfortran_la_OBJECTS = $(am_libgfortran_la_OBJECTS)
|
||||
AM_V_P = $(am__v_P_@AM_V@)
|
||||
|
|
@ -531,7 +533,7 @@ am__can_run_installinfo = \
|
|||
*) (install-info --version) >/dev/null 2>&1;; \
|
||||
esac
|
||||
DATA = $(toolexeclib_DATA)
|
||||
HEADERS = $(nodist_finclude_HEADERS)
|
||||
HEADERS = $(gfor_c_HEADERS) $(nodist_finclude_HEADERS)
|
||||
am__tagged_files = $(HEADERS) $(SOURCES) $(TAGS_FILES) \
|
||||
$(LISP)config.h.in
|
||||
# Read a list of newline-separated strings from the standard input,
|
||||
|
|
@ -690,7 +692,6 @@ pdfdir = @pdfdir@
|
|||
prefix = @prefix@
|
||||
program_transform_name = @program_transform_name@
|
||||
psdir = @psdir@
|
||||
runstatedir = @runstatedir@
|
||||
sbindir = @sbindir@
|
||||
sharedstatedir = @sharedstatedir@
|
||||
srcdir = @srcdir@
|
||||
|
|
@ -715,6 +716,8 @@ gcc_version := $(shell @get_gcc_base_ver@ $(top_srcdir)/../gcc/BASE-VER)
|
|||
@LIBGFOR_USE_SYMVER_FALSE@version_dep =
|
||||
@LIBGFOR_USE_SYMVER_GNU_TRUE@@LIBGFOR_USE_SYMVER_TRUE@version_dep = $(srcdir)/gfortran.map
|
||||
@LIBGFOR_USE_SYMVER_SUN_TRUE@@LIBGFOR_USE_SYMVER_TRUE@version_dep = gfortran.map-sun
|
||||
gfor_c_HEADERS = $(srcdir)/ISO_Fortran_binding.h
|
||||
gfor_cdir = $(libdir)/gcc/$(target_alias)/$(gcc_version)$(MULTISUBDIR)/include
|
||||
LTLDFLAGS = $(shell $(SHELL) $(top_srcdir)/../libtool-ldflags $(LDFLAGS)) \
|
||||
$(lt_host_flags)
|
||||
|
||||
|
|
@ -757,10 +760,10 @@ gfor_helper_src = intrinsics/associated.c intrinsics/abort.c \
|
|||
intrinsics/args.c intrinsics/cshift0.c intrinsics/eoshift0.c \
|
||||
intrinsics/eoshift2.c intrinsics/erfc_scaled.c \
|
||||
intrinsics/extends_type_of.c intrinsics/fnum.c \
|
||||
intrinsics/ierrno.c intrinsics/ishftc.c intrinsics/mvbits.c \
|
||||
intrinsics/ierrno.c intrinsics/ishftc.c \
|
||||
intrinsics/is_contiguous.c intrinsics/mvbits.c \
|
||||
intrinsics/move_alloc.c intrinsics/pack_generic.c \
|
||||
intrinsics/selected_char_kind.c intrinsics/size.c \
|
||||
intrinsics/is_contiguous.c \
|
||||
intrinsics/spread_generic.c intrinsics/string_intrinsics.c \
|
||||
intrinsics/rand.c intrinsics/random.c \
|
||||
intrinsics/reshape_generic.c intrinsics/reshape_packed.c \
|
||||
|
|
@ -1341,6 +1344,9 @@ $(srcdir)/generated/spread_c8.c \
|
|||
$(srcdir)/generated/spread_c10.c \
|
||||
$(srcdir)/generated/spread_c16.c
|
||||
|
||||
i_isobinding_c = \
|
||||
$(srcdir)/runtime/ISO_Fortran_binding.c
|
||||
|
||||
m4_files = m4/iparm.m4 m4/ifunction.m4 m4/iforeach.m4 m4/all.m4 \
|
||||
m4/any.m4 m4/count.m4 m4/maxloc0.m4 m4/maxloc1.m4 m4/maxval.m4 \
|
||||
m4/minloc0.m4 m4/minloc1.m4 m4/minval.m4 m4/product.m4 m4/sum.m4 \
|
||||
|
|
@ -1368,7 +1374,7 @@ gfor_built_src = $(i_all_c) $(i_any_c) $(i_count_c) $(i_maxloc0_c) \
|
|||
$(i_minloc1s_c) $(i_maxloc2s_c) $(i_minloc2s_c) $(i_maxvals_c) \
|
||||
$(i_maxval0s_c) $(i_minval0s_c) $(i_maxval1s_c) $(i_minval1s_c) \
|
||||
$(i_findloc0_c) $(i_findloc0s_c) $(i_findloc1_c) $(i_findloc1s_c) \
|
||||
$(i_findloc2s_c)
|
||||
$(i_findloc2s_c) $(i_isobinding_c)
|
||||
|
||||
|
||||
# Machine generated specifics
|
||||
|
|
@ -1698,6 +1704,7 @@ mostlyclean-compile:
|
|||
distclean-compile:
|
||||
-rm -f *.tab.c
|
||||
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ISO_Fortran_binding.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/abort.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/access.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/all_l1.Plo@am__quote@
|
||||
|
|
@ -1892,6 +1899,7 @@ distclean-compile:
|
|||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/iparity_i2.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/iparity_i4.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/iparity_i8.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/is_contiguous.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ishftc.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/kill.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libgfortran_c.Plo@am__quote@
|
||||
|
|
@ -2199,7 +2207,6 @@ distclean-compile:
|
|||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/single.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/size.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/size_from_kind.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/is_contiguous.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/sleep.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/spread_c10.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/spread_c16.Plo@am__quote@
|
||||
|
|
@ -6089,6 +6096,13 @@ findloc2_s4.lo: $(srcdir)/generated/findloc2_s4.c
|
|||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
|
||||
@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o findloc2_s4.lo `test -f '$(srcdir)/generated/findloc2_s4.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc2_s4.c
|
||||
|
||||
ISO_Fortran_binding.lo: $(srcdir)/runtime/ISO_Fortran_binding.c
|
||||
@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT ISO_Fortran_binding.lo -MD -MP -MF $(DEPDIR)/ISO_Fortran_binding.Tpo -c -o ISO_Fortran_binding.lo `test -f '$(srcdir)/runtime/ISO_Fortran_binding.c' || echo '$(srcdir)/'`$(srcdir)/runtime/ISO_Fortran_binding.c
|
||||
@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/ISO_Fortran_binding.Tpo $(DEPDIR)/ISO_Fortran_binding.Plo
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='$(srcdir)/runtime/ISO_Fortran_binding.c' object='ISO_Fortran_binding.lo' libtool=yes @AMDEPBACKSLASH@
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
|
||||
@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o ISO_Fortran_binding.lo `test -f '$(srcdir)/runtime/ISO_Fortran_binding.c' || echo '$(srcdir)/'`$(srcdir)/runtime/ISO_Fortran_binding.c
|
||||
|
||||
size_from_kind.lo: io/size_from_kind.c
|
||||
@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT size_from_kind.lo -MD -MP -MF $(DEPDIR)/size_from_kind.Tpo -c -o size_from_kind.lo `test -f 'io/size_from_kind.c' || echo '$(srcdir)/'`io/size_from_kind.c
|
||||
@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/size_from_kind.Tpo $(DEPDIR)/size_from_kind.Plo
|
||||
|
|
@ -6285,6 +6299,13 @@ ishftc.lo: intrinsics/ishftc.c
|
|||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
|
||||
@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o ishftc.lo `test -f 'intrinsics/ishftc.c' || echo '$(srcdir)/'`intrinsics/ishftc.c
|
||||
|
||||
is_contiguous.lo: intrinsics/is_contiguous.c
|
||||
@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT is_contiguous.lo -MD -MP -MF $(DEPDIR)/is_contiguous.Tpo -c -o is_contiguous.lo `test -f 'intrinsics/is_contiguous.c' || echo '$(srcdir)/'`intrinsics/is_contiguous.c
|
||||
@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/is_contiguous.Tpo $(DEPDIR)/is_contiguous.Plo
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='intrinsics/is_contiguous.c' object='is_contiguous.lo' libtool=yes @AMDEPBACKSLASH@
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
|
||||
@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o is_contiguous.lo `test -f 'intrinsics/is_contiguous.c' || echo '$(srcdir)/'`intrinsics/is_contiguous.c
|
||||
|
||||
mvbits.lo: intrinsics/mvbits.c
|
||||
@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT mvbits.lo -MD -MP -MF $(DEPDIR)/mvbits.Tpo -c -o mvbits.lo `test -f 'intrinsics/mvbits.c' || echo '$(srcdir)/'`intrinsics/mvbits.c
|
||||
@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/mvbits.Tpo $(DEPDIR)/mvbits.Plo
|
||||
|
|
@ -6320,13 +6341,6 @@ size.lo: intrinsics/size.c
|
|||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
|
||||
@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o size.lo `test -f 'intrinsics/size.c' || echo '$(srcdir)/'`intrinsics/size.c
|
||||
|
||||
is_contiguous.lo: intrinsics/is_contiguous.c
|
||||
@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT is_contiguous.lo -MD -MP -MF $(DEPDIR)/is_contiguous.Tpo -c -o is_contiguous.lo `test -f 'intrinsics/is_contiguous.c' || echo '$(srcdir)/'`intrinsics/is_contiguous.c
|
||||
@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/is_contiguous.Tpo $(DEPDIR)/is_contiguous.Plo
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='intrinsics/is_contiguous.c' object='is_contiguous.lo' libtool=yes @AMDEPBACKSLASH@
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
|
||||
@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o is_contiguous.lo `test -f 'intrinsics/is_contiguous.c' || echo '$(srcdir)/'`intrinsics/is_contiguous.c
|
||||
|
||||
spread_generic.lo: intrinsics/spread_generic.c
|
||||
@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT spread_generic.lo -MD -MP -MF $(DEPDIR)/spread_generic.Tpo -c -o spread_generic.lo `test -f 'intrinsics/spread_generic.c' || echo '$(srcdir)/'`intrinsics/spread_generic.c
|
||||
@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/spread_generic.Tpo $(DEPDIR)/spread_generic.Plo
|
||||
|
|
@ -6664,6 +6678,27 @@ uninstall-toolexeclibDATA:
|
|||
@list='$(toolexeclib_DATA)'; test -n "$(toolexeclibdir)" || list=; \
|
||||
files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \
|
||||
dir='$(DESTDIR)$(toolexeclibdir)'; $(am__uninstall_files_from_dir)
|
||||
install-gfor_cHEADERS: $(gfor_c_HEADERS)
|
||||
@$(NORMAL_INSTALL)
|
||||
@list='$(gfor_c_HEADERS)'; test -n "$(gfor_cdir)" || list=; \
|
||||
if test -n "$$list"; then \
|
||||
echo " $(MKDIR_P) '$(DESTDIR)$(gfor_cdir)'"; \
|
||||
$(MKDIR_P) "$(DESTDIR)$(gfor_cdir)" || exit 1; \
|
||||
fi; \
|
||||
for p in $$list; do \
|
||||
if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \
|
||||
echo "$$d$$p"; \
|
||||
done | $(am__base_list) | \
|
||||
while read files; do \
|
||||
echo " $(INSTALL_HEADER) $$files '$(DESTDIR)$(gfor_cdir)'"; \
|
||||
$(INSTALL_HEADER) $$files "$(DESTDIR)$(gfor_cdir)" || exit $$?; \
|
||||
done
|
||||
|
||||
uninstall-gfor_cHEADERS:
|
||||
@$(NORMAL_UNINSTALL)
|
||||
@list='$(gfor_c_HEADERS)'; test -n "$(gfor_cdir)" || list=; \
|
||||
files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \
|
||||
dir='$(DESTDIR)$(gfor_cdir)'; $(am__uninstall_files_from_dir)
|
||||
install-nodist_fincludeHEADERS: $(nodist_finclude_HEADERS)
|
||||
@$(NORMAL_INSTALL)
|
||||
@list='$(nodist_finclude_HEADERS)'; test -n "$(fincludedir)" || list=; \
|
||||
|
|
@ -6749,7 +6784,7 @@ check: $(BUILT_SOURCES)
|
|||
$(MAKE) $(AM_MAKEFLAGS) check-am
|
||||
all-am: Makefile $(LTLIBRARIES) $(DATA) $(HEADERS) config.h all-local
|
||||
installdirs:
|
||||
for dir in "$(DESTDIR)$(cafexeclibdir)" "$(DESTDIR)$(toolexeclibdir)" "$(DESTDIR)$(toolexeclibdir)" "$(DESTDIR)$(fincludedir)"; do \
|
||||
for dir in "$(DESTDIR)$(cafexeclibdir)" "$(DESTDIR)$(toolexeclibdir)" "$(DESTDIR)$(toolexeclibdir)" "$(DESTDIR)$(gfor_cdir)" "$(DESTDIR)$(fincludedir)"; do \
|
||||
test -z "$$dir" || $(MKDIR_P) "$$dir"; \
|
||||
done
|
||||
install: $(BUILT_SOURCES)
|
||||
|
|
@ -6808,7 +6843,7 @@ info: info-am
|
|||
|
||||
info-am:
|
||||
|
||||
install-data-am: install-nodist_fincludeHEADERS
|
||||
install-data-am: install-gfor_cHEADERS install-nodist_fincludeHEADERS
|
||||
|
||||
install-dvi: install-dvi-am
|
||||
|
||||
|
|
@ -6858,7 +6893,7 @@ ps: ps-am
|
|||
|
||||
ps-am:
|
||||
|
||||
uninstall-am: uninstall-cafexeclibLTLIBRARIES \
|
||||
uninstall-am: uninstall-cafexeclibLTLIBRARIES uninstall-gfor_cHEADERS \
|
||||
uninstall-nodist_fincludeHEADERS uninstall-toolexeclibDATA \
|
||||
uninstall-toolexeclibLTLIBRARIES
|
||||
|
||||
|
|
@ -6873,16 +6908,16 @@ uninstall-am: uninstall-cafexeclibLTLIBRARIES \
|
|||
dvi dvi-am html html-am info info-am install install-am \
|
||||
install-cafexeclibLTLIBRARIES install-data install-data-am \
|
||||
install-dvi install-dvi-am install-exec install-exec-am \
|
||||
install-exec-local install-html install-html-am install-info \
|
||||
install-info-am install-man install-nodist_fincludeHEADERS \
|
||||
install-pdf install-pdf-am install-ps install-ps-am \
|
||||
install-strip install-toolexeclibDATA \
|
||||
install-exec-local install-gfor_cHEADERS install-html \
|
||||
install-html-am install-info install-info-am install-man \
|
||||
install-nodist_fincludeHEADERS install-pdf install-pdf-am \
|
||||
install-ps install-ps-am install-strip install-toolexeclibDATA \
|
||||
install-toolexeclibLTLIBRARIES installcheck installcheck-am \
|
||||
installdirs maintainer-clean maintainer-clean-generic \
|
||||
maintainer-clean-local mostlyclean mostlyclean-compile \
|
||||
mostlyclean-generic mostlyclean-libtool mostlyclean-local pdf \
|
||||
pdf-am ps ps-am tags tags-am uninstall uninstall-am \
|
||||
uninstall-cafexeclibLTLIBRARIES \
|
||||
uninstall-cafexeclibLTLIBRARIES uninstall-gfor_cHEADERS \
|
||||
uninstall-nodist_fincludeHEADERS uninstall-toolexeclibDATA \
|
||||
uninstall-toolexeclibLTLIBRARIES
|
||||
|
||||
|
|
|
|||
|
|
@ -780,7 +780,6 @@ infodir
|
|||
docdir
|
||||
oldincludedir
|
||||
includedir
|
||||
runstatedir
|
||||
localstatedir
|
||||
sharedstatedir
|
||||
sysconfdir
|
||||
|
|
@ -871,7 +870,6 @@ datadir='${datarootdir}'
|
|||
sysconfdir='${prefix}/etc'
|
||||
sharedstatedir='${prefix}/com'
|
||||
localstatedir='${prefix}/var'
|
||||
runstatedir='${localstatedir}/run'
|
||||
includedir='${prefix}/include'
|
||||
oldincludedir='/usr/include'
|
||||
docdir='${datarootdir}/doc/${PACKAGE_TARNAME}'
|
||||
|
|
@ -1124,15 +1122,6 @@ do
|
|||
| -silent | --silent | --silen | --sile | --sil)
|
||||
silent=yes ;;
|
||||
|
||||
-runstatedir | --runstatedir | --runstatedi | --runstated \
|
||||
| --runstate | --runstat | --runsta | --runst | --runs \
|
||||
| --run | --ru | --r)
|
||||
ac_prev=runstatedir ;;
|
||||
-runstatedir=* | --runstatedir=* | --runstatedi=* | --runstated=* \
|
||||
| --runstate=* | --runstat=* | --runsta=* | --runst=* | --runs=* \
|
||||
| --run=* | --ru=* | --r=*)
|
||||
runstatedir=$ac_optarg ;;
|
||||
|
||||
-sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb)
|
||||
ac_prev=sbindir ;;
|
||||
-sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \
|
||||
|
|
@ -1270,7 +1259,7 @@ fi
|
|||
for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \
|
||||
datadir sysconfdir sharedstatedir localstatedir includedir \
|
||||
oldincludedir docdir infodir htmldir dvidir pdfdir psdir \
|
||||
libdir localedir mandir runstatedir
|
||||
libdir localedir mandir
|
||||
do
|
||||
eval ac_val=\$$ac_var
|
||||
# Remove trailing slashes.
|
||||
|
|
@ -1423,7 +1412,6 @@ Fine tuning of the installation directories:
|
|||
--sysconfdir=DIR read-only single-machine data [PREFIX/etc]
|
||||
--sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com]
|
||||
--localstatedir=DIR modifiable single-machine data [PREFIX/var]
|
||||
--runstatedir=DIR modifiable per-process data [LOCALSTATEDIR/run]
|
||||
--libdir=DIR object code libraries [EPREFIX/lib]
|
||||
--includedir=DIR C header files [PREFIX/include]
|
||||
--oldincludedir=DIR C header files for non-gcc [/usr/include]
|
||||
|
|
@ -12696,7 +12684,7 @@ else
|
|||
lt_dlunknown=0; lt_dlno_uscore=1; lt_dlneed_uscore=2
|
||||
lt_status=$lt_dlunknown
|
||||
cat > conftest.$ac_ext <<_LT_EOF
|
||||
#line 12699 "configure"
|
||||
#line 12687 "configure"
|
||||
#include "confdefs.h"
|
||||
|
||||
#if HAVE_DLFCN_H
|
||||
|
|
@ -12802,7 +12790,7 @@ else
|
|||
lt_dlunknown=0; lt_dlno_uscore=1; lt_dlneed_uscore=2
|
||||
lt_status=$lt_dlunknown
|
||||
cat > conftest.$ac_ext <<_LT_EOF
|
||||
#line 12805 "configure"
|
||||
#line 12793 "configure"
|
||||
#include "confdefs.h"
|
||||
|
||||
#if HAVE_DLFCN_H
|
||||
|
|
@ -16051,7 +16039,7 @@ else
|
|||
We can't simply define LARGE_OFF_T to be 9223372036854775807,
|
||||
since some C++ compilers masquerading as C compilers
|
||||
incorrectly reject 9223372036854775807. */
|
||||
#define LARGE_OFF_T ((((off_t) 1 << 31) << 31) - 1 + (((off_t) 1 << 31) << 31))
|
||||
#define LARGE_OFF_T (((off_t) 1 << 62) - 1 + ((off_t) 1 << 62))
|
||||
int off_t_is_large[(LARGE_OFF_T % 2147483629 == 721
|
||||
&& LARGE_OFF_T % 2147483647 == 1)
|
||||
? 1 : -1];
|
||||
|
|
@ -16097,7 +16085,7 @@ else
|
|||
We can't simply define LARGE_OFF_T to be 9223372036854775807,
|
||||
since some C++ compilers masquerading as C compilers
|
||||
incorrectly reject 9223372036854775807. */
|
||||
#define LARGE_OFF_T ((((off_t) 1 << 31) << 31) - 1 + (((off_t) 1 << 31) << 31))
|
||||
#define LARGE_OFF_T (((off_t) 1 << 62) - 1 + ((off_t) 1 << 62))
|
||||
int off_t_is_large[(LARGE_OFF_T % 2147483629 == 721
|
||||
&& LARGE_OFF_T % 2147483647 == 1)
|
||||
? 1 : -1];
|
||||
|
|
@ -16121,7 +16109,7 @@ rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
|
|||
We can't simply define LARGE_OFF_T to be 9223372036854775807,
|
||||
since some C++ compilers masquerading as C compilers
|
||||
incorrectly reject 9223372036854775807. */
|
||||
#define LARGE_OFF_T ((((off_t) 1 << 31) << 31) - 1 + (((off_t) 1 << 31) << 31))
|
||||
#define LARGE_OFF_T (((off_t) 1 << 62) - 1 + ((off_t) 1 << 62))
|
||||
int off_t_is_large[(LARGE_OFF_T % 2147483629 == 721
|
||||
&& LARGE_OFF_T % 2147483647 == 1)
|
||||
? 1 : -1];
|
||||
|
|
@ -16166,7 +16154,7 @@ else
|
|||
We can't simply define LARGE_OFF_T to be 9223372036854775807,
|
||||
since some C++ compilers masquerading as C compilers
|
||||
incorrectly reject 9223372036854775807. */
|
||||
#define LARGE_OFF_T ((((off_t) 1 << 31) << 31) - 1 + (((off_t) 1 << 31) << 31))
|
||||
#define LARGE_OFF_T (((off_t) 1 << 62) - 1 + ((off_t) 1 << 62))
|
||||
int off_t_is_large[(LARGE_OFF_T % 2147483629 == 721
|
||||
&& LARGE_OFF_T % 2147483647 == 1)
|
||||
? 1 : -1];
|
||||
|
|
@ -16190,7 +16178,7 @@ rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
|
|||
We can't simply define LARGE_OFF_T to be 9223372036854775807,
|
||||
since some C++ compilers masquerading as C compilers
|
||||
incorrectly reject 9223372036854775807. */
|
||||
#define LARGE_OFF_T ((((off_t) 1 << 31) << 31) - 1 + (((off_t) 1 << 31) << 31))
|
||||
#define LARGE_OFF_T (((off_t) 1 << 62) - 1 + ((off_t) 1 << 62))
|
||||
int off_t_is_large[(LARGE_OFF_T % 2147483629 == 721
|
||||
&& LARGE_OFF_T % 2147483647 == 1)
|
||||
? 1 : -1];
|
||||
|
|
|
|||
|
|
@ -1486,6 +1486,16 @@ GFORTRAN_C99_8 {
|
|||
|
||||
GFORTRAN_9 {
|
||||
global:
|
||||
CFI_address;
|
||||
CFI_allocate;
|
||||
CFI_deallocate;
|
||||
CFI_establish;
|
||||
CFI_is_contiguous;
|
||||
CFI_section;
|
||||
CFI_select_part;
|
||||
CFI_setpointer;
|
||||
_gfortran_gfc_desc_to_cfi_desc;
|
||||
_gfortran_cfi_desc_to_gfc_desc;
|
||||
_gfortran_findloc0_c16;
|
||||
_gfortran_findloc0_c4;
|
||||
_gfortran_findloc0_c8;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,864 @@
|
|||
/* Functions to convert descriptors between CFI and gfortran
|
||||
and the CFI function declarations whose prototypes appear
|
||||
in ISO_Fortran_binding.h.
|
||||
Copyright (C) 2018 Free Software Foundation, Inc.
|
||||
Contributed by Daniel Celis Garza <celisdanieljr@gmail.com>
|
||||
and Paul Thomas <pault@gcc.gnu.org>
|
||||
|
||||
This file is part of the GNU Fortran runtime library (libgfortran).
|
||||
|
||||
Libgfortran is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public
|
||||
License as published by the Free Software Foundation; either
|
||||
version 3 of the License, or (at your option) any later version.
|
||||
|
||||
Libgfortran is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
Under Section 7 of GPL version 3, you are granted additional
|
||||
permissions described in the GCC Runtime Library Exception, version
|
||||
3.1, as published by the Free Software Foundation.
|
||||
|
||||
You should have received a copy of the GNU General Public License and
|
||||
a copy of the GCC Runtime Library Exception along with this program;
|
||||
see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
||||
<http://www.gnu.org/licenses/>. */
|
||||
|
||||
#include "libgfortran.h"
|
||||
#include <ISO_Fortran_binding.h>
|
||||
#include <string.h>
|
||||
|
||||
extern void cfi_desc_to_gfc_desc (gfc_array_void *, CFI_cdesc_t **);
|
||||
export_proto(cfi_desc_to_gfc_desc);
|
||||
|
||||
void
|
||||
cfi_desc_to_gfc_desc (gfc_array_void *d, CFI_cdesc_t **s_ptr)
|
||||
{
|
||||
int n;
|
||||
CFI_cdesc_t *s = *s_ptr;
|
||||
|
||||
/* If not a full pointer or allocatable array free the descriptor
|
||||
and return. */
|
||||
if (!s || s->attribute == CFI_attribute_other)
|
||||
goto finish;
|
||||
|
||||
GFC_DESCRIPTOR_DATA (d) = s->base_addr;
|
||||
|
||||
if (!s->rank || s->dim[0].sm == (CFI_index_t)s->elem_len)
|
||||
GFC_DESCRIPTOR_SIZE (d) = s->elem_len;
|
||||
else
|
||||
GFC_DESCRIPTOR_SIZE (d) = (index_type)s->dim[0].sm;
|
||||
|
||||
d->dtype.version = s->version;
|
||||
GFC_DESCRIPTOR_RANK (d) = (signed char)s->rank;
|
||||
GFC_DESCRIPTOR_TYPE (d) = (signed char)(s->type & CFI_type_mask);
|
||||
|
||||
/* Correct the unfortunate difference in order with types. */
|
||||
if (GFC_DESCRIPTOR_TYPE (d) == BT_CHARACTER)
|
||||
GFC_DESCRIPTOR_TYPE (d) = BT_DERIVED;
|
||||
else if (GFC_DESCRIPTOR_TYPE (d) == BT_DERIVED)
|
||||
GFC_DESCRIPTOR_TYPE (d) = BT_DERIVED;
|
||||
|
||||
d->dtype.attribute = (signed short)s->attribute;
|
||||
|
||||
if (s->rank)
|
||||
d->span = (index_type)s->dim[0].sm;
|
||||
|
||||
/* On the other hand, CFI_establish can change the bounds. */
|
||||
d->offset = 0;
|
||||
for (n = 0; n < GFC_DESCRIPTOR_RANK (d); n++)
|
||||
{
|
||||
GFC_DESCRIPTOR_LBOUND(d, n) = (index_type)s->dim[n].lower_bound;
|
||||
GFC_DESCRIPTOR_UBOUND(d, n) = (index_type)(s->dim[n].extent
|
||||
+ s->dim[n].lower_bound - 1);
|
||||
GFC_DESCRIPTOR_STRIDE(d, n) = (index_type)(s->dim[n].sm / s->elem_len);
|
||||
d->offset -= GFC_DESCRIPTOR_STRIDE(d, n) * GFC_DESCRIPTOR_LBOUND(d, n);
|
||||
}
|
||||
|
||||
finish:
|
||||
if (s)
|
||||
free (s);
|
||||
s = NULL;
|
||||
}
|
||||
|
||||
extern void gfc_desc_to_cfi_desc (CFI_cdesc_t **, const gfc_array_void *);
|
||||
export_proto(gfc_desc_to_cfi_desc);
|
||||
|
||||
void
|
||||
gfc_desc_to_cfi_desc (CFI_cdesc_t **d_ptr, const gfc_array_void *s)
|
||||
{
|
||||
int n;
|
||||
CFI_cdesc_t *d;
|
||||
|
||||
/* Play it safe with allocation of the flexible array member 'dim'
|
||||
by setting the length to CFI_MAX_RANK. This should not be necessary
|
||||
but valgrind complains accesses after the allocated block. */
|
||||
d = malloc (sizeof (CFI_cdesc_t)
|
||||
+ (CFI_type_t)(CFI_MAX_RANK * sizeof (CFI_dim_t)));
|
||||
|
||||
d->base_addr = GFC_DESCRIPTOR_DATA (s);
|
||||
d->elem_len = GFC_DESCRIPTOR_SIZE (s);
|
||||
d->version = s->dtype.version;
|
||||
d->rank = (CFI_rank_t)GFC_DESCRIPTOR_RANK (s);
|
||||
d->attribute = (CFI_attribute_t)s->dtype.attribute;
|
||||
|
||||
if (GFC_DESCRIPTOR_TYPE (s) == BT_CHARACTER)
|
||||
d->type = CFI_type_struct;
|
||||
else if (GFC_DESCRIPTOR_TYPE (s) == BT_DERIVED)
|
||||
d->type = CFI_type_Character;
|
||||
else
|
||||
d->type = (CFI_type_t)GFC_DESCRIPTOR_TYPE (s);
|
||||
|
||||
d->type = (CFI_type_t)(d->type
|
||||
+ ((CFI_type_t)d->elem_len << CFI_type_kind_shift));
|
||||
|
||||
/* Full pointer or allocatable arrays have zero lower_bound. */
|
||||
for (n = 0; n < GFC_DESCRIPTOR_RANK (s); n++)
|
||||
{
|
||||
if (d->attribute == CFI_attribute_other)
|
||||
d->dim[n].lower_bound = (CFI_index_t)GFC_DESCRIPTOR_LBOUND(s, n);
|
||||
else
|
||||
d->dim[n].lower_bound = 0;
|
||||
|
||||
/* Assumed size arrays have gfc ubound == 0 and CFI extent = -1. */
|
||||
if ((n == GFC_DESCRIPTOR_RANK (s) - 1)
|
||||
&& GFC_DESCRIPTOR_LBOUND(s, n) == 1
|
||||
&& GFC_DESCRIPTOR_UBOUND(s, n) == 0)
|
||||
d->dim[n].extent = -1;
|
||||
else
|
||||
d->dim[n].extent = (CFI_index_t)GFC_DESCRIPTOR_UBOUND(s, n)
|
||||
- (CFI_index_t)GFC_DESCRIPTOR_LBOUND(s, n) + 1;
|
||||
d->dim[n].sm = (CFI_index_t)(GFC_DESCRIPTOR_STRIDE(s, n) * s->span);
|
||||
}
|
||||
|
||||
*d_ptr = d;
|
||||
}
|
||||
|
||||
void *CFI_address (const CFI_cdesc_t *dv, const CFI_index_t subscripts[])
|
||||
{
|
||||
int i;
|
||||
char *base_addr = (char *)dv->base_addr;
|
||||
|
||||
if (unlikely (compile_options.bounds_check))
|
||||
{
|
||||
/* C Descriptor must not be NULL. */
|
||||
if (dv == NULL)
|
||||
{
|
||||
fprintf (stderr, "CFI_address: C Descriptor is NULL.\n");
|
||||
return NULL;
|
||||
}
|
||||
|
||||
/* Base address of C Descriptor must not be NULL. */
|
||||
if (dv->base_addr == NULL)
|
||||
{
|
||||
fprintf (stderr, "CFI_address: base address of C Descriptor "
|
||||
"must not be NULL.\n");
|
||||
return NULL;
|
||||
}
|
||||
}
|
||||
|
||||
/* Return base address if C descriptor is a scalar. */
|
||||
if (dv->rank == 0)
|
||||
return dv->base_addr;
|
||||
|
||||
/* Calculate the appropriate base address if dv is not a scalar. */
|
||||
else
|
||||
{
|
||||
/* Base address is the C address of the element of the object
|
||||
specified by subscripts. */
|
||||
for (i = 0; i < dv->rank; i++)
|
||||
{
|
||||
if (unlikely (compile_options.bounds_check)
|
||||
&& ((dv->dim[i].extent != -1
|
||||
&& subscripts[i] >= dv->dim[i].extent)
|
||||
|| subscripts[i] < 0))
|
||||
{
|
||||
fprintf (stderr, "CFI_address: subscripts[%d], is out of "
|
||||
"bounds. dv->dim[%d].extent = %d subscripts[%d] "
|
||||
"= %d.\n", i, i, (int)dv->dim[i].extent, i,
|
||||
(int)subscripts[i]);
|
||||
return NULL;
|
||||
}
|
||||
|
||||
base_addr = base_addr + (CFI_index_t)(subscripts[i] * dv->dim[i].sm);
|
||||
}
|
||||
}
|
||||
|
||||
return (void *)base_addr;
|
||||
}
|
||||
|
||||
|
||||
int
|
||||
CFI_allocate (CFI_cdesc_t *dv, const CFI_index_t lower_bounds[],
|
||||
const CFI_index_t upper_bounds[], size_t elem_len)
|
||||
{
|
||||
if (unlikely (compile_options.bounds_check))
|
||||
{
|
||||
/* C Descriptor must not be NULL. */
|
||||
if (dv == NULL)
|
||||
{
|
||||
fprintf (stderr, "CFI_allocate: C Descriptor is NULL.\n");
|
||||
return CFI_INVALID_DESCRIPTOR;
|
||||
}
|
||||
|
||||
/* The C Descriptor must be for an allocatable or pointer object. */
|
||||
if (dv->attribute == CFI_attribute_other)
|
||||
{
|
||||
fprintf (stderr, "CFI_allocate: The object of the C descriptor "
|
||||
"must be a pointer or allocatable variable.\n");
|
||||
return CFI_INVALID_ATTRIBUTE;
|
||||
}
|
||||
|
||||
/* Base address of C Descriptor must be NULL. */
|
||||
if (dv->base_addr != NULL)
|
||||
{
|
||||
fprintf (stderr, "CFI_allocate: Base address of C descriptor "
|
||||
"must be NULL.\n");
|
||||
return CFI_ERROR_BASE_ADDR_NOT_NULL;
|
||||
}
|
||||
}
|
||||
|
||||
/* If the type is a character, the descriptor's element length is replaced
|
||||
* by the elem_len argument. */
|
||||
if (dv->type == CFI_type_char || dv->type == CFI_type_ucs4_char ||
|
||||
dv->type == CFI_type_signed_char)
|
||||
dv->elem_len = elem_len;
|
||||
|
||||
/* Dimension information and calculating the array length. */
|
||||
size_t arr_len = 1;
|
||||
|
||||
/* If rank is greater than 0, lower_bounds and upper_bounds are used. They're
|
||||
* ignored otherwhise. */
|
||||
if (dv->rank > 0)
|
||||
{
|
||||
if (unlikely (compile_options.bounds_check)
|
||||
&& (lower_bounds == NULL || upper_bounds == NULL))
|
||||
{
|
||||
fprintf (stderr, "CFI_allocate: If 0 < rank (= %d) upper_bounds[] "
|
||||
"and lower_bounds[], must not be NULL.\n", dv->rank);
|
||||
return CFI_INVALID_EXTENT;
|
||||
}
|
||||
|
||||
for (int i = 0; i < dv->rank; i++)
|
||||
{
|
||||
dv->dim[i].lower_bound = lower_bounds[i];
|
||||
dv->dim[i].extent = upper_bounds[i] - dv->dim[i].lower_bound + 1;
|
||||
if (i == 0)
|
||||
dv->dim[i].sm = dv->elem_len;
|
||||
else
|
||||
dv->dim[i].sm = dv->elem_len * dv->dim[i - 1].extent;
|
||||
arr_len *= dv->dim[i].extent;
|
||||
}
|
||||
}
|
||||
|
||||
dv->base_addr = calloc (arr_len, dv->elem_len);
|
||||
if (dv->base_addr == NULL)
|
||||
{
|
||||
fprintf (stderr, "CFI_allocate: Failure in memory allocation.\n");
|
||||
return CFI_ERROR_MEM_ALLOCATION;
|
||||
}
|
||||
|
||||
return CFI_SUCCESS;
|
||||
}
|
||||
|
||||
|
||||
int
|
||||
CFI_deallocate (CFI_cdesc_t *dv)
|
||||
{
|
||||
if (unlikely (compile_options.bounds_check))
|
||||
{
|
||||
/* C Descriptor must not be NULL */
|
||||
if (dv == NULL)
|
||||
{
|
||||
fprintf (stderr, "CFI_deallocate: C Descriptor is NULL.\n");
|
||||
return CFI_INVALID_DESCRIPTOR;
|
||||
}
|
||||
|
||||
/* Base address must not be NULL. */
|
||||
if (dv->base_addr == NULL)
|
||||
{
|
||||
fprintf (stderr, "CFI_deallocate: Base address is already NULL.\n");
|
||||
return CFI_ERROR_BASE_ADDR_NULL;
|
||||
}
|
||||
|
||||
/* C Descriptor must be for an allocatable or pointer variable. */
|
||||
if (dv->attribute == CFI_attribute_other)
|
||||
{
|
||||
fprintf (stderr, "CFI_deallocate: C Descriptor must describe a "
|
||||
"pointer or allocatable object.\n");
|
||||
return CFI_INVALID_ATTRIBUTE;
|
||||
}
|
||||
}
|
||||
|
||||
/* Free and nullify memory. */
|
||||
free (dv->base_addr);
|
||||
dv->base_addr = NULL;
|
||||
|
||||
return CFI_SUCCESS;
|
||||
}
|
||||
|
||||
|
||||
int CFI_establish (CFI_cdesc_t *dv, void *base_addr, CFI_attribute_t attribute,
|
||||
CFI_type_t type, size_t elem_len, CFI_rank_t rank,
|
||||
const CFI_index_t extents[])
|
||||
{
|
||||
if (unlikely (compile_options.bounds_check))
|
||||
{
|
||||
/* C descriptor must not be NULL. */
|
||||
if (dv == NULL)
|
||||
{
|
||||
fprintf (stderr, "CFI_establish: C descriptor is NULL.\n");
|
||||
return CFI_INVALID_DESCRIPTOR;
|
||||
}
|
||||
|
||||
/* Rank must be between 0 and CFI_MAX_RANK. */
|
||||
if (rank < 0 || rank > CFI_MAX_RANK)
|
||||
{
|
||||
fprintf (stderr, "CFI_establish: Rank must be between 0 and %d, "
|
||||
"0 < rank (0 !< %d).\n", CFI_MAX_RANK, (int)rank);
|
||||
return CFI_INVALID_RANK;
|
||||
}
|
||||
|
||||
/* C Descriptor must not be an allocated allocatable. */
|
||||
if (dv->attribute == CFI_attribute_allocatable && dv->base_addr != NULL)
|
||||
{
|
||||
fprintf (stderr, "CFI_establish: If the C Descriptor represents an "
|
||||
"allocatable variable (dv->attribute = %d), its base "
|
||||
"address must be NULL (dv->base_addr = NULL).\n",
|
||||
CFI_attribute_allocatable);
|
||||
return CFI_INVALID_DESCRIPTOR;
|
||||
}
|
||||
|
||||
/* If base address is not NULL, the established C Descriptor is for a
|
||||
nonallocatable entity. */
|
||||
if (attribute == CFI_attribute_allocatable && base_addr != NULL)
|
||||
{
|
||||
fprintf (stderr, "CFI_establish: If base address is not NULL "
|
||||
"(base_addr != NULL), the established C descriptor is "
|
||||
"for a nonallocatable entity (attribute != %d).\n",
|
||||
CFI_attribute_allocatable);
|
||||
return CFI_INVALID_ATTRIBUTE;
|
||||
}
|
||||
}
|
||||
|
||||
dv->base_addr = base_addr;
|
||||
|
||||
if (type == CFI_type_char || type == CFI_type_ucs4_char ||
|
||||
type == CFI_type_signed_char || type == CFI_type_struct ||
|
||||
type == CFI_type_other)
|
||||
dv->elem_len = elem_len;
|
||||
else
|
||||
{
|
||||
/* base_type describes the intrinsic type with kind parameter. */
|
||||
size_t base_type = type & CFI_type_mask;
|
||||
/* base_type_size is the size in bytes of the variable as given by its
|
||||
* kind parameter. */
|
||||
size_t base_type_size = (type - base_type) >> CFI_type_kind_shift;
|
||||
/* Kind types 10 have a size of 64 bytes. */
|
||||
if (base_type_size == 10)
|
||||
{
|
||||
base_type_size = 64;
|
||||
}
|
||||
/* Complex numbers are twice the size of their real counterparts. */
|
||||
if (base_type == CFI_type_Complex)
|
||||
{
|
||||
base_type_size *= 2;
|
||||
}
|
||||
dv->elem_len = base_type_size;
|
||||
}
|
||||
|
||||
dv->version = CFI_VERSION;
|
||||
dv->rank = rank;
|
||||
dv->attribute = attribute;
|
||||
dv->type = type;
|
||||
|
||||
/* Extents must not be NULL if rank is greater than zero and base_addr is not
|
||||
* NULL */
|
||||
if (rank > 0 && base_addr != NULL)
|
||||
{
|
||||
if (unlikely (compile_options.bounds_check) && extents == NULL)
|
||||
{
|
||||
fprintf (stderr, "CFI_establish: Extents must not be NULL "
|
||||
"(extents != NULL) if rank (= %d) > 0 nd base address"
|
||||
"is not NULL (base_addr != NULL).\n", (int)rank);
|
||||
return CFI_INVALID_EXTENT;
|
||||
}
|
||||
|
||||
for (int i = 0; i < rank; i++)
|
||||
{
|
||||
/* If the C Descriptor is for a pointer then the lower bounds of every
|
||||
* dimension are set to zero. */
|
||||
if (attribute == CFI_attribute_pointer)
|
||||
dv->dim[i].lower_bound = 0;
|
||||
else
|
||||
dv->dim[i].lower_bound = 1;
|
||||
|
||||
dv->dim[i].extent = extents[i];
|
||||
if (i == 0)
|
||||
dv->dim[i].sm = dv->elem_len;
|
||||
else
|
||||
dv->dim[i].sm = (CFI_index_t)(dv->elem_len * extents[i - 1]);
|
||||
}
|
||||
}
|
||||
|
||||
return CFI_SUCCESS;
|
||||
}
|
||||
|
||||
|
||||
int CFI_is_contiguous (const CFI_cdesc_t *dv)
|
||||
{
|
||||
if (unlikely (compile_options.bounds_check))
|
||||
{
|
||||
/* C descriptor must not be NULL. */
|
||||
if (dv == NULL)
|
||||
{
|
||||
fprintf (stderr, "CFI_is_contiguous: C descriptor is NULL.\n");
|
||||
return CFI_INVALID_DESCRIPTOR;
|
||||
}
|
||||
|
||||
/* Base address must not be NULL. */
|
||||
if (dv->base_addr == NULL)
|
||||
{
|
||||
fprintf (stderr, "CFI_is_contiguous: Base address of C Descriptor "
|
||||
"is already NULL.\n");
|
||||
return CFI_ERROR_BASE_ADDR_NULL;
|
||||
}
|
||||
|
||||
/* Must be an array. */
|
||||
if (dv->rank == 0)
|
||||
{
|
||||
fprintf (stderr, "CFI_is_contiguous: C Descriptor must describe an "
|
||||
"array (0 < dv->rank = %d).\n", dv->rank);
|
||||
return CFI_INVALID_RANK;
|
||||
}
|
||||
}
|
||||
|
||||
/* Assumed size arrays are always contiguous. */
|
||||
if (dv->rank > 0 && dv->dim[dv->rank - 1].extent == -1)
|
||||
return CFI_SUCCESS;
|
||||
|
||||
/* If an array is not contiguous the memory stride is different to the element
|
||||
* length. */
|
||||
for (int i = 0; i < dv->rank; i++)
|
||||
{
|
||||
if (i == 0 && dv->dim[i].sm == (CFI_index_t)dv->elem_len)
|
||||
continue;
|
||||
else if (i > 0
|
||||
&& dv->dim[i].sm == (CFI_index_t)(dv->elem_len
|
||||
* dv->dim[i - 1].extent))
|
||||
continue;
|
||||
|
||||
return CFI_FAILURE;
|
||||
}
|
||||
|
||||
/* Array sections are guaranteed to be contiguous by the previous test. */
|
||||
return CFI_SUCCESS;
|
||||
}
|
||||
|
||||
|
||||
int CFI_section (CFI_cdesc_t *result, const CFI_cdesc_t *source,
|
||||
const CFI_index_t lower_bounds[],
|
||||
const CFI_index_t upper_bounds[], const CFI_index_t strides[])
|
||||
{
|
||||
/* Dimension information. */
|
||||
CFI_index_t lower[CFI_MAX_RANK];
|
||||
CFI_index_t upper[CFI_MAX_RANK];
|
||||
CFI_index_t stride[CFI_MAX_RANK];
|
||||
int zero_count = 0;
|
||||
bool assumed_size;
|
||||
|
||||
if (unlikely (compile_options.bounds_check))
|
||||
{
|
||||
/* C Descriptors must not be NULL. */
|
||||
if (source == NULL)
|
||||
{
|
||||
fprintf (stderr, "CFI_section: Source must not be NULL.\n");
|
||||
return CFI_INVALID_DESCRIPTOR;
|
||||
}
|
||||
|
||||
if (result == NULL)
|
||||
{
|
||||
fprintf (stderr, "CFI_section: Result must not be NULL.\n");
|
||||
return CFI_INVALID_DESCRIPTOR;
|
||||
}
|
||||
|
||||
/* Base address of source must not be NULL. */
|
||||
if (source->base_addr == NULL)
|
||||
{
|
||||
fprintf (stderr, "CFI_section: Base address of source must "
|
||||
"not be NULL.\n");
|
||||
return CFI_ERROR_BASE_ADDR_NULL;
|
||||
}
|
||||
|
||||
/* Result must not be an allocatable array. */
|
||||
if (result->attribute == CFI_attribute_allocatable)
|
||||
{
|
||||
fprintf (stderr, "CFI_section: Result must not describe an "
|
||||
"allocatable array.\n");
|
||||
return CFI_INVALID_ATTRIBUTE;
|
||||
}
|
||||
|
||||
/* Source must be some form of array (nonallocatable nonpointer array,
|
||||
allocated allocatable array or an associated pointer array). */
|
||||
if (source->rank <= 0)
|
||||
{
|
||||
fprintf (stderr, "CFI_section: Source must describe an array "
|
||||
"(0 < source->rank, 0 !< %d).\n", source->rank);
|
||||
return CFI_INVALID_RANK;
|
||||
}
|
||||
|
||||
/* Element lengths of source and result must be equal. */
|
||||
if (result->elem_len != source->elem_len)
|
||||
{
|
||||
fprintf (stderr, "CFI_section: The element lengths of "
|
||||
"source (source->elem_len = %d) and result "
|
||||
"(result->elem_len = %d) must be equal.\n",
|
||||
(int)source->elem_len, (int)result->elem_len);
|
||||
return CFI_INVALID_ELEM_LEN;
|
||||
}
|
||||
|
||||
/* Types must be equal. */
|
||||
if (result->type != source->type)
|
||||
{
|
||||
fprintf (stderr, "CFI_section: Types of source "
|
||||
"(source->type = %d) and result (result->type = %d) "
|
||||
"must be equal.\n", source->type, result->type);
|
||||
return CFI_INVALID_TYPE;
|
||||
}
|
||||
}
|
||||
|
||||
/* Stride of zero in the i'th dimension means rank reduction in that
|
||||
dimension. */
|
||||
for (int i = 0; i < source->rank; i++)
|
||||
{
|
||||
if (strides[i] == 0)
|
||||
zero_count++;
|
||||
}
|
||||
|
||||
/* Rank of result must be equal the the rank of source minus the number of
|
||||
* zeros in strides. */
|
||||
if (unlikely (compile_options.bounds_check)
|
||||
&& result->rank != source->rank - zero_count)
|
||||
{
|
||||
fprintf (stderr, "CFI_section: Rank of result must be equal to the "
|
||||
"rank of source minus the number of zeros in strides "
|
||||
"(result->rank = source->rank - zero_count, %d != %d "
|
||||
"- %d).\n", result->rank, source->rank, zero_count);
|
||||
return CFI_INVALID_RANK;
|
||||
}
|
||||
|
||||
/* Lower bounds. */
|
||||
if (lower_bounds == NULL)
|
||||
{
|
||||
for (int i = 0; i < source->rank; i++)
|
||||
lower[i] = source->dim[i].lower_bound;
|
||||
}
|
||||
else
|
||||
{
|
||||
for (int i = 0; i < source->rank; i++)
|
||||
lower[i] = lower_bounds[i];
|
||||
}
|
||||
|
||||
/* Upper bounds. */
|
||||
if (upper_bounds == NULL)
|
||||
{
|
||||
if (unlikely (compile_options.bounds_check)
|
||||
&& source->dim[source->rank - 1].extent == -1)
|
||||
{
|
||||
fprintf (stderr, "CFI_section: Source must not be an assumed size "
|
||||
"array if upper_bounds is NULL.\n");
|
||||
return CFI_INVALID_EXTENT;
|
||||
}
|
||||
|
||||
for (int i = 0; i < source->rank; i++)
|
||||
upper[i] = source->dim[i].lower_bound + source->dim[i].extent - 1;
|
||||
}
|
||||
else
|
||||
{
|
||||
for (int i = 0; i < source->rank; i++)
|
||||
upper[i] = upper_bounds[i];
|
||||
}
|
||||
|
||||
/* Stride */
|
||||
if (strides == NULL)
|
||||
{
|
||||
for (int i = 0; i < source->rank; i++)
|
||||
stride[i] = 1;
|
||||
}
|
||||
else
|
||||
{
|
||||
for (int i = 0; i < source->rank; i++)
|
||||
{
|
||||
stride[i] = strides[i];
|
||||
/* If stride[i] == 0 then lower[i] and upper[i] must be equal. */
|
||||
if (unlikely (compile_options.bounds_check)
|
||||
&& stride[i] == 0 && lower[i] != upper[i])
|
||||
{
|
||||
fprintf (stderr, "CFI_section: If strides[%d] = 0, then the "
|
||||
"lower bounds, lower_bounds[%d] = %d, and "
|
||||
"upper_bounds[%d] = %d, must be equal.\n",
|
||||
i, i, (int)lower_bounds[i], i, (int)upper_bounds[i]);
|
||||
return CFI_ERROR_OUT_OF_BOUNDS;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
/* Check that section upper and lower bounds are within the array bounds. */
|
||||
for (int i = 0; i < source->rank; i++)
|
||||
{
|
||||
assumed_size = (i == source->rank - 1)
|
||||
&& (source->dim[i].extent == -1);
|
||||
if (unlikely (compile_options.bounds_check)
|
||||
&& lower_bounds != NULL
|
||||
&& (lower[i] < source->dim[i].lower_bound ||
|
||||
(!assumed_size && lower[i] > source->dim[i].lower_bound
|
||||
+ source->dim[i].extent - 1)))
|
||||
{
|
||||
fprintf (stderr, "CFI_section: Lower bounds must be within the "
|
||||
"bounds of the fortran array (source->dim[%d].lower_bound "
|
||||
"<= lower_bounds[%d] <= source->dim[%d].lower_bound "
|
||||
"+ source->dim[%d].extent - 1, %d <= %d <= %d).\n",
|
||||
i, i, i, i, (int)source->dim[i].lower_bound, (int)lower[i],
|
||||
(int)(source->dim[i].lower_bound
|
||||
+ source->dim[i].extent - 1));
|
||||
return CFI_ERROR_OUT_OF_BOUNDS;
|
||||
}
|
||||
|
||||
if (unlikely (compile_options.bounds_check)
|
||||
&& upper_bounds != NULL
|
||||
&& (upper[i] < source->dim[i].lower_bound
|
||||
|| (!assumed_size
|
||||
&& upper[i] > source->dim[i].lower_bound
|
||||
+ source->dim[i].extent - 1)))
|
||||
{
|
||||
fprintf (stderr, "CFI_section: Upper bounds must be within the "
|
||||
"bounds of the fortran array (source->dim[%d].lower_bound "
|
||||
"<= upper_bounds[%d] <= source->dim[%d].lower_bound + "
|
||||
"source->dim[%d].extent - 1, %d !<= %d !<= %d).\n",
|
||||
i, i, i, i, (int)source->dim[i].lower_bound, (int)upper[i],
|
||||
(int)(source->dim[i].lower_bound
|
||||
+ source->dim[i].extent - 1));
|
||||
return CFI_ERROR_OUT_OF_BOUNDS;
|
||||
}
|
||||
|
||||
if (unlikely (compile_options.bounds_check)
|
||||
&& upper[i] < lower[i] && stride[i] >= 0)
|
||||
{
|
||||
fprintf (stderr, "CFI_section: If the upper bound is smaller than "
|
||||
"the lower bound for a given dimension (upper[%d] < "
|
||||
"lower[%d], %d < %d), then he stride for said dimension"
|
||||
"t must be negative (stride[%d] < 0, %d < 0).\n",
|
||||
i, i, (int)upper[i], (int)lower[i], i, (int)stride[i]);
|
||||
return CFI_INVALID_STRIDE;
|
||||
}
|
||||
}
|
||||
|
||||
/* Set the appropriate dimension information that gives us access to the
|
||||
* data. */
|
||||
int aux = 0;
|
||||
for (int i = 0; i < source->rank; i++)
|
||||
{
|
||||
if (stride[i] == 0)
|
||||
{
|
||||
aux++;
|
||||
/* Adjust 'lower' for the base address offset. */
|
||||
lower[i] = lower[i] - source->dim[i].lower_bound;
|
||||
continue;
|
||||
}
|
||||
int idx = i - aux;
|
||||
result->dim[idx].lower_bound = lower[i];
|
||||
result->dim[idx].extent = upper[i] - lower[i] + 1;
|
||||
result->dim[idx].sm = stride[i] * source->dim[i].sm;
|
||||
/* Adjust 'lower' for the base address offset. */
|
||||
lower[idx] = lower[idx] - source->dim[i].lower_bound;
|
||||
}
|
||||
|
||||
/* Set the base address. */
|
||||
result->base_addr = CFI_address (source, lower);
|
||||
|
||||
return CFI_SUCCESS;
|
||||
}
|
||||
|
||||
|
||||
int CFI_select_part (CFI_cdesc_t *result, const CFI_cdesc_t *source,
|
||||
size_t displacement, size_t elem_len)
|
||||
{
|
||||
if (unlikely (compile_options.bounds_check))
|
||||
{
|
||||
/* C Descriptors must not be NULL. */
|
||||
if (source == NULL)
|
||||
{
|
||||
fprintf (stderr, "CFI_select_part: Source must not be NULL.\n");
|
||||
return CFI_INVALID_DESCRIPTOR;
|
||||
}
|
||||
|
||||
if (result == NULL)
|
||||
{
|
||||
fprintf (stderr, "CFI_select_part: Result must not be NULL.\n");
|
||||
return CFI_INVALID_DESCRIPTOR;
|
||||
}
|
||||
|
||||
/* Attribute of result will be CFI_attribute_other or
|
||||
CFI_attribute_pointer. */
|
||||
if (result->attribute == CFI_attribute_allocatable)
|
||||
{
|
||||
fprintf (stderr, "CFI_select_part: Result must not describe an "
|
||||
"allocatable object (result->attribute != %d).\n",
|
||||
CFI_attribute_allocatable);
|
||||
return CFI_INVALID_ATTRIBUTE;
|
||||
}
|
||||
|
||||
/* Base address of source must not be NULL. */
|
||||
if (source->base_addr == NULL)
|
||||
{
|
||||
fprintf (stderr, "CFI_select_part: Base address of source must "
|
||||
"not be NULL.\n");
|
||||
return CFI_ERROR_BASE_ADDR_NULL;
|
||||
}
|
||||
|
||||
/* Source and result must have the same rank. */
|
||||
if (source->rank != result->rank)
|
||||
{
|
||||
fprintf (stderr, "CFI_select_part: Source and result must have "
|
||||
"the same rank (source->rank = %d, result->rank = %d).\n",
|
||||
(int)source->rank, (int)result->rank);
|
||||
return CFI_INVALID_RANK;
|
||||
}
|
||||
|
||||
/* Nonallocatable nonpointer must not be an assumed size array. */
|
||||
if (source->rank > 0 && source->dim[source->rank - 1].extent == -1)
|
||||
{
|
||||
fprintf (stderr, "CFI_select_part: Source must not describe an "
|
||||
"assumed size array (source->dim[%d].extent != -1).\n",
|
||||
source->rank - 1);
|
||||
return CFI_INVALID_DESCRIPTOR;
|
||||
}
|
||||
}
|
||||
|
||||
/* Element length. */
|
||||
if (result->type == CFI_type_char || result->type == CFI_type_ucs4_char ||
|
||||
result->type == CFI_type_signed_char)
|
||||
result->elem_len = elem_len;
|
||||
|
||||
if (unlikely (compile_options.bounds_check))
|
||||
{
|
||||
/* Ensure displacement is within the bounds of the element length
|
||||
of source.*/
|
||||
if (displacement > source->elem_len - 1)
|
||||
{
|
||||
fprintf (stderr, "CFI_select_part: Displacement must be within the "
|
||||
"bounds of source (0 <= displacement <= source->elem_len "
|
||||
"- 1, 0 <= %d <= %d).\n", (int)displacement,
|
||||
(int)(source->elem_len - 1));
|
||||
return CFI_ERROR_OUT_OF_BOUNDS;
|
||||
}
|
||||
|
||||
/* Ensure displacement and element length of result are less than or
|
||||
equal to the element length of source. */
|
||||
if (displacement + result->elem_len > source->elem_len)
|
||||
{
|
||||
fprintf (stderr, "CFI_select_part: Displacement plus the element "
|
||||
"length of result must be less than or equal to the "
|
||||
"element length of source (displacement + result->elem_len "
|
||||
"<= source->elem_len, %d + %d = %d <= %d).\n",
|
||||
(int)displacement, (int)result->elem_len,
|
||||
(int)(displacement + result->elem_len),
|
||||
(int)source->elem_len);
|
||||
return CFI_ERROR_OUT_OF_BOUNDS;
|
||||
}
|
||||
}
|
||||
|
||||
if (result->rank > 0)
|
||||
{
|
||||
for (int i = 0; i < result->rank; i++)
|
||||
{
|
||||
result->dim[i].lower_bound = source->dim[i].lower_bound;
|
||||
result->dim[i].extent = source->dim[i].extent;
|
||||
result->dim[i].sm = source->dim[i].sm;
|
||||
}
|
||||
}
|
||||
|
||||
result->base_addr = (char *) source->base_addr + displacement;
|
||||
return CFI_SUCCESS;
|
||||
}
|
||||
|
||||
|
||||
int CFI_setpointer (CFI_cdesc_t *result, CFI_cdesc_t *source,
|
||||
const CFI_index_t lower_bounds[])
|
||||
{
|
||||
/* Result must not be NULL. */
|
||||
if (unlikely (compile_options.bounds_check) && result == NULL)
|
||||
{
|
||||
fprintf (stderr, "CFI_setpointer: Result is NULL.\n");
|
||||
return CFI_INVALID_DESCRIPTOR;
|
||||
}
|
||||
|
||||
/* If source is NULL, the result is a C Descriptor that describes a
|
||||
* disassociated pointer. */
|
||||
if (source == NULL)
|
||||
{
|
||||
result->base_addr = NULL;
|
||||
result->version = CFI_VERSION;
|
||||
result->attribute = CFI_attribute_pointer;
|
||||
}
|
||||
else
|
||||
{
|
||||
/* Check that element lengths, ranks and types of source and result are
|
||||
* the same. */
|
||||
if (unlikely (compile_options.bounds_check))
|
||||
{
|
||||
if (result->elem_len != source->elem_len)
|
||||
{
|
||||
fprintf (stderr, "CFI_setpointer: Element lengths of result "
|
||||
"(result->elem_len = %d) and source (source->elem_len "
|
||||
"= %d) must be the same.\n", (int)result->elem_len,
|
||||
(int)source->elem_len);
|
||||
return CFI_INVALID_ELEM_LEN;
|
||||
}
|
||||
|
||||
if (result->rank != source->rank)
|
||||
{
|
||||
fprintf (stderr, "CFI_setpointer: Ranks of result (result->rank "
|
||||
"= %d) and source (source->rank = %d) must be the same."
|
||||
"\n", result->rank, source->rank);
|
||||
return CFI_INVALID_RANK;
|
||||
}
|
||||
|
||||
if (result->type != source->type)
|
||||
{
|
||||
fprintf (stderr, "CFI_setpointer: Types of result (result->type"
|
||||
"= %d) and source (source->type = %d) must be the same."
|
||||
"\n", result->type, source->type);
|
||||
return CFI_INVALID_TYPE;
|
||||
}
|
||||
}
|
||||
|
||||
/* If the source is a disassociated pointer, the result must also describe
|
||||
* a disassociated pointer. */
|
||||
if (source->base_addr == NULL &&
|
||||
source->attribute == CFI_attribute_pointer)
|
||||
result->base_addr = NULL;
|
||||
else
|
||||
result->base_addr = source->base_addr;
|
||||
|
||||
/* Assign components to result. */
|
||||
result->version = source->version;
|
||||
result->attribute = source->attribute;
|
||||
|
||||
/* Dimension information. */
|
||||
for (int i = 0; i < source->rank; i++)
|
||||
{
|
||||
if (lower_bounds != NULL)
|
||||
result->dim[i].lower_bound = lower_bounds[i];
|
||||
else
|
||||
result->dim[i].lower_bound = source->dim[i].lower_bound;
|
||||
|
||||
result->dim[i].extent = source->dim[i].extent;
|
||||
result->dim[i].sm = source->dim[i].sm;
|
||||
}
|
||||
}
|
||||
|
||||
return CFI_SUCCESS;
|
||||
}
|
||||
Loading…
Reference in New Issue