+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
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.
@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}.
@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
@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.
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.
@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.
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,
@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}
@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
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}
@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
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')
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.
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}
@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}.
@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.
@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.:
@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
@smallexample
c Variable declaration
CHARACTER(LEN=20) FMT
-c
+c
c Other code here...
c
WRITE(FMT,'("(I", I0, ")")') N+1
@smallexample
c Variable declaration
CHARACTER(LEN=20) FMT
-c
+c
c Other code here...
c
WRITE(FMT,*) N+1
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:
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
}
+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)
{
/* 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)
{
/* 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. */
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);
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;
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);
}
+/* 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.
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
}
}
}
+
else if (arg->name && arg->name[0] == '%')
/* Argument list functions %VAL, %LOC and %REF are signalled
through arg->name. */
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
if (fsym && fsym->attr.proc_pointer)
parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
}
+
else
{
if (e->ts.type == BT_CLASS && fsym
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
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
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;
--- /dev/null
+/* 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;
+}
--- /dev/null
+! { 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
--- /dev/null
+/* 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;
+}
--- /dev/null
+! { 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
!
! 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
! { 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" } }
+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
--- /dev/null
+/* 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 */
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)
$(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 \
$(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= \
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
}
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
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) \
$(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 \
@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 \
_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@)
*) (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,
prefix = @prefix@
program_transform_name = @program_transform_name@
psdir = @psdir@
-runstatedir = @runstatedir@
sbindir = @sbindir@
sharedstatedir = @sharedstatedir@
srcdir = @srcdir@
@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)
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 \
$(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 \
$(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
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@
@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@
@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@
@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
@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
@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
@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=; \
$(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)
info-am:
-install-data-am: install-nodist_fincludeHEADERS
+install-data-am: install-gfor_cHEADERS install-nodist_fincludeHEADERS
install-dvi: install-dvi-am
ps-am:
-uninstall-am: uninstall-cafexeclibLTLIBRARIES \
+uninstall-am: uninstall-cafexeclibLTLIBRARIES uninstall-gfor_cHEADERS \
uninstall-nodist_fincludeHEADERS uninstall-toolexeclibDATA \
uninstall-toolexeclibLTLIBRARIES
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
docdir
oldincludedir
includedir
-runstatedir
localstatedir
sharedstatedir
sysconfdir
sysconfdir='${prefix}/etc'
sharedstatedir='${prefix}/com'
localstatedir='${prefix}/var'
-runstatedir='${localstatedir}/run'
includedir='${prefix}/include'
oldincludedir='/usr/include'
docdir='${datarootdir}/doc/${PACKAGE_TARNAME}'
| -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=* \
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.
--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]
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
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
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];
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];
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];
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];
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];
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;
--- /dev/null
+/* 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;
+}
projects / gcc.git / commitdiff