This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC project.
| Index Nav: | [Date Index] [Subject Index] [Author Index] [Thread Index] | |
|---|---|---|
| Message Nav: | [Date Prev] [Date Next] | [Thread Prev] [Thread Next] |
| Other format: | [Raw text] | |
The attached is an implementation of ISO_Fortran_binding. Please note that the ChangeLogs contain no mention of the changes that appear in the configure files on building in maintainer mode. The patch only couples to assumed rank and assumed shape formal arguments of bind_c procedures, via trans-expr.c(gfc_conv_procedure_call) calls to gfc_conv_gfc_desc_to_cfi_desc. Such calls in the past would have generated code that would have been 'invalid' unless typedefs for the gfortran descriptor were used. For this reason, I believe that this is safe to commit even at this stage in the release cycle. It would be nice if ISO_Fortran_binding.h were one of the standard C includes but I haven't tried to do this yet. The testing and, indeed, the provision of testcases is incomplete but I thought this to be a good time for review. One question for any reviewer is the need for the error messages in the CFI API functions? Daniel put in the work but they seem potentially excessive for a library function. In my mind, it is probably sufficient to return the error code. Thomas Koenig helped enormously with some build problems for which thanks. He experienced ICEs associated with malloc/free problems, which I did not see but believe to have eliminated with the help of valgrind. All were associated with the use of flexible arrays Bootstrapped and regtested on FC20/x86_64 - OK for trunk? Paul
Index: gcc/configure
===================================================================
*** gcc/configure (revision 266426)
--- gcc/configure (working copy)
*************** foo: .long 25
*** 24393,24404 ****
;;
or1k*-*-*)
conftest_s='
! .section ".tdata","awT",@progbits
! foo: .long 25
! .text
! l.movhi r3, tpoffha(foo)
! l.add r3, r3, r10
! l.lwz r4, tpofflo(foo)(r3)'
tls_first_major=2
tls_first_minor=30
tls_as_opt=--fatal-warnings
--- 24393,24404 ----
;;
or1k*-*-*)
conftest_s='
! .section ".tdata","awT",@progbits
! foo: .long 25
! .text
! l.movhi r3, tpoffha(foo)
! l.add r3, r3, r10
! l.lwz r4, tpofflo(foo)(r3)'
tls_first_major=2
tls_first_minor=30
tls_as_opt=--fatal-warnings
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c (revision 266426)
--- gcc/fortran/trans-array.c (working copy)
*************** gfc_conv_descriptor_rank (tree desc)
*** 293,298 ****
--- 293,314 ----
tree
+ gfc_conv_descriptor_attribute (tree desc)
+ {
+ tree tmp;
+ tree dtype;
+
+ dtype = gfc_conv_descriptor_dtype (desc);
+ tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)),
+ GFC_DTYPE_ATTRIBUTE);
+ gcc_assert (tmp!= NULL_TREE
+ && TREE_TYPE (tmp) == short_integer_type_node);
+ return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
+ dtype, tmp, NULL_TREE);
+ }
+
+
+ tree
gfc_get_descriptor_dimension (tree desc)
{
tree type, field;
*************** gfc_trans_dummy_array_bias (gfc_symbol *
*** 6767,6773 ****
/* Calculate the overall offset, including subreferences. */
! static void
gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
bool subref, gfc_expr *expr)
{
--- 6783,6789 ----
/* Calculate the overall offset, including subreferences. */
! void
gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
bool subref, gfc_expr *expr)
{
Index: gcc/fortran/trans-array.h
===================================================================
*** gcc/fortran/trans-array.h (revision 266426)
--- gcc/fortran/trans-array.h (working copy)
*************** void gfc_conv_tmp_array_ref (gfc_se * se
*** 136,141 ****
--- 136,143 ----
/* 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_offset_get (tre
*** 167,172 ****
--- 169,175 ----
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);
Index: gcc/fortran/trans-decl.c
===================================================================
*** gcc/fortran/trans-decl.c (revision 266426)
--- gcc/fortran/trans-decl.c (working copy)
*************** tree gfor_fndecl_fdate;
*** 114,119 ****
--- 114,121 ----
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;
*************** gfc_build_builtin_function_decls (void)
*** 3612,3617 ****
--- 3614,3627 ----
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);
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c (revision 266426)
--- gcc/fortran/trans-expr.c (working copy)
*************** expr_may_alias_variables (gfc_expr *e, b
*** 4814,4819 ****
--- 4814,4915 ----
}
+ /* 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.
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 5157,5163 ****
tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
parmse.expr = convert (type, tmp);
}
! else if (fsym && fsym->attr.value)
{
if (fsym->ts.type == BT_CHARACTER
&& fsym->ts.is_c_interop
--- 5253,5267 ----
tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
parmse.expr = convert (type, tmp);
}
!
! 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
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 5196,5201 ****
--- 5300,5306 ----
}
}
}
+
else if (arg->name && arg->name[0] == '%')
/* Argument list functions %VAL, %LOC and %REF are signalled
through arg->name. */
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 5210,5215 ****
--- 5315,5321 ----
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
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 5220,5225 ****
--- 5326,5332 ----
if (fsym && fsym->attr.proc_pointer)
parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
}
+
else
{
if (e->ts.type == BT_CLASS && fsym
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 5593,5599 ****
parmse.force_tmp = 1;
}
! if (e->expr_type == EXPR_VARIABLE
&& is_subref_array (e)
&& !(fsym && fsym->attr.pointer))
/* The actual argument is a component reference to an
--- 5700,5713 ----
parmse.force_tmp = 1;
}
! 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_procedure_call (gfc_se * se, gf
*** 5603,5608 ****
--- 5717,5723 ----
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
Index: gcc/fortran/trans.h
===================================================================
*** gcc/fortran/trans.h (revision 266426)
--- gcc/fortran/trans.h (working copy)
*************** extern GTY(()) tree gfor_fndecl_ctime;
*** 801,806 ****
--- 801,808 ----
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;
Index: gcc/testsuite/gfortran.dg/ISO_Fortran_binding.h
===================================================================
*** gcc/testsuite/gfortran.dg/ISO_Fortran_binding.h (nonexistent)
--- gcc/testsuite/gfortran.dg/ISO_Fortran_binding.h (working copy)
***************
*** 0 ****
--- 1,206 ----
+ /* Declarations for ISO Fortran binding.
+ Copyright (C) 2018 Free Software Foundation, Inc.
+ Contributed by Daniel Celis Garza <celisdanieljr@gmail.com>
+
+ This file is part of the GNU Fortran runtime library (libgfortran).
+
+ Libgfortran is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 3, or (at your option)
+ any later version.
+
+ Libgfortran is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ Under Section 7 of GPL version 3, you are granted additional
+ permissions described in the GCC Runtime Library Exception, version
+ 3.1, as published by the Free Software Foundation.
+
+ You should have received a copy of the GNU General Public License and
+ a copy of the GCC Runtime Library Exception along with this program;
+ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
+ <http://www.gnu.org/licenses/>. */
+
+ #ifndef ISO_FORTRAN_BINDING_H
+ #define ISO_FORTRAN_BINDING_H
+
+ #ifdef __cplusplus
+ extern "C" {
+ #endif
+
+ #include <stddef.h> /* Standard ptrdiff_t tand size_t. */
+ #include <stdint.h> /* Integer types. */
+
+ /* Constants, defined as macros. */
+ #define CFI_VERSION 1
+ #define CFI_MAX_RANK 15
+
+ /* Attributes. */
+ #define CFI_attribute_pointer 0
+ #define CFI_attribute_allocatable 1
+ #define CFI_attribute_other 2
+
+ /* Error codes.
+ CFI_INVALID_STRIDE should be defined in the standard because they are useful to the implementation of the functions.
+ */
+ #define CFI_SUCCESS 0
+ #define CFI_FAILURE 1
+ #define CFI_ERROR_BASE_ADDR_NULL 2
+ #define CFI_ERROR_BASE_ADDR_NOT_NULL 3
+ #define CFI_INVALID_ELEM_LEN 4
+ #define CFI_INVALID_RANK 5
+ #define CFI_INVALID_TYPE 6
+ #define CFI_INVALID_ATTRIBUTE 7
+ #define CFI_INVALID_EXTENT 8
+ #define CFI_INVALID_STRIDE 9
+ #define CFI_INVALID_DESCRIPTOR 10
+ #define CFI_ERROR_MEM_ALLOCATION 11
+ #define CFI_ERROR_OUT_OF_BOUNDS 12
+
+ /* CFI type definitions. */
+ typedef ptrdiff_t CFI_index_t;
+ typedef int8_t CFI_rank_t;
+ typedef int8_t CFI_attribute_t;
+ typedef int16_t CFI_type_t;
+
+ /* CFI_dim_t. */
+ typedef struct CFI_dim_t
+ {
+ CFI_index_t lower_bound;
+ CFI_index_t extent;
+ CFI_index_t sm;
+ }
+ CFI_dim_t;
+
+ /* CFI_cdesc_t, C descriptors are cast to this structure as follows:
+ CFI_CDESC_T(CFI_MAX_RANK) foo;
+ CFI_cdesc_t * bar = (CFI_cdesc_t *) &foo;
+ */
+ typedef struct CFI_cdesc_t
+ {
+ void *base_addr;
+ size_t elem_len;
+ int version;
+ CFI_rank_t rank;
+ CFI_attribute_t attribute;
+ CFI_type_t type;
+ CFI_dim_t dim[];
+ }
+ CFI_cdesc_t;
+
+ /* CFI_CDESC_T with an explicit type. */
+ #define CFI_CDESC_TYPE_T(r, base_type) \
+ struct { \
+ base_type *base_addr; \
+ size_t elem_len; \
+ int version; \
+ CFI_rank_t rank; \
+ CFI_attribute_t attribute; \
+ CFI_type_t type; \
+ CFI_dim_t dim[r]; \
+ }
+ #define CFI_CDESC_T(r) CFI_CDESC_TYPE_T (r, void)
+
+ /* CFI function declarations. */
+ extern void *CFI_address (const CFI_cdesc_t *, const CFI_index_t []);
+ extern int CFI_allocate (CFI_cdesc_t *, const CFI_index_t [], const CFI_index_t [],
+ size_t);
+ extern int CFI_deallocate (CFI_cdesc_t *);
+ extern int CFI_establish (CFI_cdesc_t *, void *, CFI_attribute_t, CFI_type_t, size_t,
+ CFI_rank_t, const CFI_index_t []);
+ extern int CFI_is_contiguous (const CFI_cdesc_t *);
+ extern int CFI_section (CFI_cdesc_t *, const CFI_cdesc_t *, const CFI_index_t [],
+ const CFI_index_t [], const CFI_index_t []);
+ extern int CFI_select_part (CFI_cdesc_t *, const CFI_cdesc_t *, size_t, size_t);
+ extern int CFI_setpointer (CFI_cdesc_t *, CFI_cdesc_t *, const CFI_index_t []);
+
+ /* Types and kind numbers. Allows bitwise and to reveal the intrinsic type of a kind type. It also allows us to find the kind parameter by inverting the bit-shift equation.
+ CFI_type_kind_shift = 8
+ CFI_intrinsic_type = 0 0 0 0 0 0 0 0 0 0 1 0
+ CFI_type_kind = 0 0 0 0 0 0 0 0 1 0 0 0
+ CFI_type_example = CFI_intrinsic_type + (CFI_type_kind << CFI_type_kind_shift)
+ Defining the CFI_type_example.
+ CFI_type_kind = 0 0 0 0 0 0 0 0 1 0 0 0 << CFI_type_kind_shift
+ -------------------------
+ 1 0 0 0 0 0 0 0 0 0 0 0 +
+ CFI_intrinsic_type = 0 0 0 0 0 0 0 0 0 0 1 0
+ -------------------------
+ CFI_type_example = 1 0 0 0 0 0 0 0 0 0 1 0
+ Finding the intrinsic type with the logical mask.
+ CFI_type_example = 1 0 0 0 0 0 0 0 0 0 1 0 &
+ CFI_type_mask = 0 0 0 0 1 1 1 1 1 1 1 1
+ -------------------------
+ CFI_intrinsic_type = 0 0 0 0 0 0 0 0 0 0 1 0
+ Using the intrinsic type and kind shift to find the kind value of the type.
+ CFI_type_kind = (CFI_type_example - CFI_intrinsic_type) >> CFI_type_kind_shift
+ CFI_type_example = 1 0 0 0 0 0 0 0 0 0 1 0 -
+ CFI_intrinsic_type = 0 0 0 0 0 0 0 0 0 0 1 0
+ -------------------------
+ 1 0 0 0 0 0 0 0 0 0 0 0 >> CFI_type_kind_shift
+ -------------------------
+ CFI_type_kind = 0 0 0 0 0 0 0 0 1 0 0 0
+ */
+ #define CFI_type_mask 0xFF
+ #define CFI_type_kind_shift 8
+
+ /* Intrinsic types. Their kind number defines their storage size. */
+ #define CFI_type_Integer 1
+ #define CFI_type_Logical 2
+ #define CFI_type_Real 3
+ #define CFI_type_Complex 4
+ #define CFI_type_Character 5
+
+ /* Types with no kind. */
+ #define CFI_type_struct 6
+ #define CFI_type_cptr 7
+ #define CFI_type_cfunptr 8
+ #define CFI_type_other -1
+
+ /* Types with kind parameter.
+ The kind parameter represents the type's byte size. The exception is kind = 10, which has byte size of 64 but 80 bit precision. Complex variables are double the byte size of their real counterparts. The ucs4_char matches wchar_t if sizeof (wchar_t) == 4.
+ */
+ #define CFI_type_char (CFI_type_Character + (1 << CFI_type_kind_shift))
+ #define CFI_type_ucs4_char (CFI_type_Character + (4 << CFI_type_kind_shift))
+
+ /* C-Fortran Interoperability types. */
+ #define CFI_type_signed_char (CFI_type_Integer + (1 << CFI_type_kind_shift))
+ #define CFI_type_short (CFI_type_Integer + (2 << CFI_type_kind_shift))
+ #define CFI_type_int (CFI_type_Integer + (4 << CFI_type_kind_shift))
+ #define CFI_type_long (CFI_type_Integer + (8 << CFI_type_kind_shift))
+ #define CFI_type_long_long (CFI_type_Integer + (8 << CFI_type_kind_shift))
+ #define CFI_type_size_t (CFI_type_Integer + (8 << CFI_type_kind_shift))
+ #define CFI_type_int8_t (CFI_type_Integer + (1 << CFI_type_kind_shift))
+ #define CFI_type_int16_t (CFI_type_Integer + (2 << CFI_type_kind_shift))
+ #define CFI_type_int32_t (CFI_type_Integer + (4 << CFI_type_kind_shift))
+ #define CFI_type_int64_t (CFI_type_Integer + (8 << CFI_type_kind_shift))
+ #define CFI_type_int_least8_t (CFI_type_Integer + (1 << CFI_type_kind_shift))
+ #define CFI_type_int_least16_t (CFI_type_Integer + (2 << CFI_type_kind_shift))
+ #define CFI_type_int_least32_t (CFI_type_Integer + (4 << CFI_type_kind_shift))
+ #define CFI_type_int_least64_t (CFI_type_Integer + (8 << CFI_type_kind_shift))
+ #define CFI_type_int_fast8_t (CFI_type_Integer + (1 << CFI_type_kind_shift))
+ #define CFI_type_int_fast16_t (CFI_type_Integer + (2 << CFI_type_kind_shift))
+ #define CFI_type_int_fast32_t (CFI_type_Integer + (4 << CFI_type_kind_shift))
+ #define CFI_type_int_fast64_t (CFI_type_Integer + (8 << CFI_type_kind_shift))
+ #define CFI_type_intmax_t (CFI_type_Integer + (8 << CFI_type_kind_shift))
+ #define CFI_type_intptr_t (CFI_type_Integer + (8 << CFI_type_kind_shift))
+ #define CFI_type_ptrdiff_t (CFI_type_Integer + (8 << CFI_type_kind_shift))
+ #define CFI_type_int128_t (CFI_type_Integer + (16 << CFI_type_kind_shift))
+ #define CFI_type_int_least128_t (CFI_type_Integer + (16 << CFI_type_kind_shift))
+ #define CFI_type_int_fast128_t (CFI_type_Integer + (16 << CFI_type_kind_shift))
+ #define CFI_type_Bool (CFI_type_Logical + (1 << CFI_type_kind_shift))
+ #define CFI_type_float (CFI_type_Real + (4 << CFI_type_kind_shift))
+ #define CFI_type_double (CFI_type_Real + (8 << CFI_type_kind_shift))
+ #define CFI_type_long_double (CFI_type_Real + (10 << CFI_type_kind_shift))
+ #define CFI_type_float128 (CFI_type_Real + (16 << CFI_type_kind_shift))
+ #define CFI_type_float_Complex (CFI_type_Complex + (4 << CFI_type_kind_shift))
+ #define CFI_type_double_Complex (CFI_type_Complex + (8 << CFI_type_kind_shift))
+ #define CFI_type_long_double_Complex (CFI_type_Complex + (10 << CFI_type_kind_shift))
+ #define CFI_type_float128_Complex (CFI_type_Complex + (16 << CFI_type_kind_shift))
+
+ #ifdef __cplusplus
+ }
+ #endif
+
+ #endif /* ISO_FORTRAN_BINDING_H */
Index: gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.c
===================================================================
*** gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.c (nonexistent)
--- gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.c (working copy)
***************
*** 0 ****
--- 1,205 ----
+ /* Test F2008 18.5: ISO_Fortran_binding.h functions. */
+
+ #include "ISO_Fortran_binding.h"
+ #include <stdio.h>
+ #include <stdlib.h>
+ #include <complex.h>
+
+ /* Test the example in F2008 C.12.9: Processing assumed-shape arrays in C,
+ modified to use CFI_address instead of pointer arithmetic. */
+
+ int elemental_mult_c(CFI_cdesc_t * a_desc, CFI_cdesc_t * b_desc,
+ CFI_cdesc_t * c_desc)
+ {
+ CFI_index_t idx[2];
+ int *res_addr;
+ int err = 1; /* this error code represents all errors */
+
+ if (a_desc->rank == 0)
+ {
+ err = *(int*)a_desc->base_addr;
+ *(int*)a_desc->base_addr = 0;
+ return err;
+ }
+
+ if (a_desc->type != CFI_type_int
+ || b_desc->type != CFI_type_int
+ || c_desc->type != CFI_type_int)
+ return err;
+
+ /* Only support two dimensions. */
+ if (a_desc->rank != 2
+ || b_desc->rank != 2
+ || c_desc->rank != 2)
+ return err;
+
+ for (idx[0] = 0; idx[0] < a_desc->dim[0].extent; idx[0]++)
+ for (idx[1] = 0; idx[1] < a_desc->dim[1].extent; idx[1]++)
+ {
+ res_addr = CFI_address (a_desc, idx);
+ *res_addr = *(int*)CFI_address (b_desc, idx)
+ * *(int*)CFI_address (c_desc, idx);
+ }
+
+ return 0;
+ }
+
+
+ int deallocate_c(CFI_cdesc_t * dd)
+ {
+ return CFI_deallocate(dd);
+ }
+
+
+ int allocate_c(CFI_cdesc_t * da, CFI_index_t lower[], CFI_index_t upper[])
+ {
+ int err = 1;
+ CFI_index_t idx[2];
+ int *res_addr;
+
+ if (CFI_allocate(da, lower, upper, 0)) return err;
+
+
+ for (idx[0] = 0; idx[0] < da->dim[0].extent; idx[0]++)
+ for (idx[1] = 0; idx[1] < da->dim[1].extent; idx[1]++)
+ {
+ res_addr = CFI_address (da, idx);
+ *res_addr = (int)((idx[0] + da->dim[0].lower_bound)
+ * (idx[1] + da->dim[1].lower_bound));
+ }
+
+ return 0;
+ }
+
+ int establish_c(CFI_cdesc_t * desc)
+ {
+ typedef struct {double x; double _Complex y;} t;
+ int err;
+ CFI_index_t idx[1], extent[1];
+ t *res_addr;
+ double value = 1.0;
+ double complex z_value = 0.0 + 2.0 * I;
+
+ extent[0] = 10;
+ err = CFI_establish((CFI_cdesc_t *)desc,
+ malloc ((size_t)(extent[0] * sizeof(t))),
+ CFI_attribute_pointer,
+ CFI_type_struct,
+ sizeof(t), 1, extent);
+ for (idx[0] = 0; idx[0] < extent[0]; idx[0]++)
+ {
+ res_addr = (t*)CFI_address (desc, idx);
+ res_addr->x = value++;
+ res_addr->y = z_value * (idx[0] + 1);
+ }
+ return err;
+ }
+
+ int contiguous_c(CFI_cdesc_t * desc)
+ {
+ return CFI_is_contiguous(desc);
+ }
+
+ float section_c(int *std_case, CFI_cdesc_t * source, int *low, int *str)
+ {
+ CFI_index_t idx[CFI_MAX_RANK], lower[CFI_MAX_RANK],
+ strides[CFI_MAX_RANK], upper[CFI_MAX_RANK];
+ CFI_CDESC_T(1) section;
+ int ind, size;
+ float *ret_addr;
+ float ans = 0.0;
+
+ /* Case (i) from F2018:18.5.5.7. */
+ if (*std_case == 1)
+ {
+ lower[0] = (CFI_index_t)low[0];
+ strides[0] = (CFI_index_t)str[0];
+ ind = CFI_establish((CFI_cdesc_t *)§ion, NULL, CFI_attribute_other,
+ CFI_type_float, 0, 1, NULL);
+ if (ind) return -1.0;
+ ind = CFI_section((CFI_cdesc_t *)§ion, source, lower, NULL, strides);
+ if (ind) return -2.0;
+
+ /* Sum over the section */
+ size = (section.dim[0].extent - 1)
+ * section.elem_len/section.dim[0].sm + 1;
+ for (idx[0] = 0; idx[0] < size; idx[0]++)
+ ans += *(float*)CFI_address ((CFI_cdesc_t*)§ion, idx);
+ return ans;
+ }
+ else if (*std_case == 2)
+ {
+ int ind;
+ lower[0] = source->dim[0].lower_bound;
+ upper[0] = source->dim[0].lower_bound + source->dim[0].extent - 1;
+ strides[0] = str[0];
+ lower[1] = upper[1] = source->dim[1].lower_bound + low[1] - 1;
+ strides[1] = 0;
+ ind = CFI_establish((CFI_cdesc_t *)§ion, NULL, CFI_attribute_other,
+ CFI_type_float, 0, 1, NULL);
+ if (ind) return -1.0;
+ ind = CFI_section((CFI_cdesc_t *)§ion, source,
+ lower, upper, strides);
+ if (ind) return -2.0;
+
+ /* Sum over the section */
+ size = (section.dim[0].extent - 1)
+ * section.elem_len/section.dim[0].sm + 1;
+ for (idx[0] = 0; idx[0] < size; idx[0]++)
+ ans += *(float*)CFI_address ((CFI_cdesc_t*)§ion, idx);
+ return ans;
+ }
+
+ return 0.0;
+ }
+
+
+ double select_part_c (CFI_cdesc_t * source)
+ {
+ typedef struct {
+ double x; double _Complex y;
+ } t;
+ CFI_CDESC_T(2) component;
+ CFI_cdesc_t * comp_cdesc = (CFI_cdesc_t *)&component;
+ CFI_index_t extent[] = {10,10};
+ CFI_index_t idx[] = {4,0};
+ double ans = 0.0;
+ int size;
+
+ (void)CFI_establish(comp_cdesc, NULL, CFI_attribute_other,
+ CFI_type_double_Complex, sizeof(double _Complex),
+ 2, extent);
+ (void)CFI_select_part(comp_cdesc, source, offsetof(t,y), 0);
+
+ /* Sum over comp_cdesc[4,:] */
+ size = comp_cdesc->dim[1].extent;
+ for (idx[1] = 0; idx[1] < size; idx[1]++)
+ ans += cimag (*(double _Complex*)CFI_address ((CFI_cdesc_t*)comp_cdesc,
+ idx));
+ return ans;
+ }
+
+
+ int setpointer_c(CFI_cdesc_t * ptr, int lbounds[])
+ {
+ CFI_index_t lower_bounds[] = {lbounds[0],lbounds[1]};
+ int ind;
+ ind = CFI_setpointer(ptr, ptr, lower_bounds);
+ return ind;
+ }
+
+
+ int assumed_size_c(CFI_cdesc_t * desc)
+ {
+ int ierr;
+
+ ierr = CFI_is_contiguous(desc);
+ if (ierr)
+ return 1;
+ if (desc->rank)
+ ierr = 2 * (desc->dim[desc->rank-1].extent
+ != (CFI_index_t)(long long)(-1));
+ else
+ ierr = 3;
+ return ierr;
+ }
Index: gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90 (nonexistent)
--- gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90 (working copy)
***************
*** 0 ****
--- 1,244 ----
+ ! { dg-do run }
+ ! { dg-additional-sources ISO_Fortran_binding_1.c }
+ !
+ ! Test F2008 18.5: ISO_Fortran_binding.h functions.
+ !
+ USE, INTRINSIC :: ISO_C_BINDING
+
+ TYPE, BIND(C) :: T
+ REAL(C_DOUBLE) :: X
+ complex(C_DOUBLE_COMPLEX) :: Y
+ END TYPE
+
+ type :: mytype
+ integer :: i
+ integer :: j
+ end type
+
+ INTERFACE
+ FUNCTION elemental_mult(a, b, c) BIND(C, NAME="elemental_mult_c") RESULT(err)
+ USE, INTRINSIC :: ISO_C_BINDING
+ INTEGER(C_INT) :: err
+ type(*), DIMENSION(..) :: a, b, c
+ END FUNCTION elemental_mult
+
+ FUNCTION c_deallocate(a) BIND(C, NAME="deallocate_c") RESULT(err)
+ USE, INTRINSIC :: ISO_C_BINDING
+ INTEGER(C_INT) :: err
+ type(*), DIMENSION(..) :: a
+ END FUNCTION c_deallocate
+
+ FUNCTION c_allocate(a, lower, upper) BIND(C, NAME="allocate_c") RESULT(err)
+ USE, INTRINSIC :: ISO_C_BINDING
+ INTEGER(C_INT) :: err
+ type(*), DIMENSION(..) :: a
+ integer(C_LONG_LONG), 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(kind(loc (i))), 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
Index: gcc/testsuite/gfortran.dg/bind_c_array_params_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/bind_c_array_params_2.f90 (revision 266426)
--- gcc/testsuite/gfortran.dg/bind_c_array_params_2.f90 (working copy)
***************
*** 5,11 ****
!
! 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
--- 5,11 ----
!
! 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
*************** end
*** 20,23 ****
! { 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" } }
--- 20,23 ----
! { 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 "cfi_desc_to_gfc_desc \\\(&parm\\." 1 "original" } }
Index: libgfortran/ISO_Fortran_binding.h
===================================================================
*** libgfortran/ISO_Fortran_binding.h (nonexistent)
--- libgfortran/ISO_Fortran_binding.h (working copy)
***************
*** 0 ****
--- 1,206 ----
+ /* Declarations for ISO Fortran binding.
+ Copyright (C) 2018 Free Software Foundation, Inc.
+ Contributed by Daniel Celis Garza <celisdanieljr@gmail.com>
+
+ This file is part of the GNU Fortran runtime library (libgfortran).
+
+ Libgfortran is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 3, or (at your option)
+ any later version.
+
+ Libgfortran is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ Under Section 7 of GPL version 3, you are granted additional
+ permissions described in the GCC Runtime Library Exception, version
+ 3.1, as published by the Free Software Foundation.
+
+ You should have received a copy of the GNU General Public License and
+ a copy of the GCC Runtime Library Exception along with this program;
+ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
+ <http://www.gnu.org/licenses/>. */
+
+ #ifndef ISO_FORTRAN_BINDING_H
+ #define ISO_FORTRAN_BINDING_H
+
+ #ifdef __cplusplus
+ extern "C" {
+ #endif
+
+ #include <stddef.h> /* Standard ptrdiff_t tand size_t. */
+ #include <stdint.h> /* Integer types. */
+
+ /* Constants, defined as macros. */
+ #define CFI_VERSION 1
+ #define CFI_MAX_RANK 15
+
+ /* Attributes. */
+ #define CFI_attribute_pointer 0
+ #define CFI_attribute_allocatable 1
+ #define CFI_attribute_other 2
+
+ /* Error codes.
+ CFI_INVALID_STRIDE should be defined in the standard because they are useful to the implementation of the functions.
+ */
+ #define CFI_SUCCESS 0
+ #define CFI_FAILURE 1
+ #define CFI_ERROR_BASE_ADDR_NULL 2
+ #define CFI_ERROR_BASE_ADDR_NOT_NULL 3
+ #define CFI_INVALID_ELEM_LEN 4
+ #define CFI_INVALID_RANK 5
+ #define CFI_INVALID_TYPE 6
+ #define CFI_INVALID_ATTRIBUTE 7
+ #define CFI_INVALID_EXTENT 8
+ #define CFI_INVALID_STRIDE 9
+ #define CFI_INVALID_DESCRIPTOR 10
+ #define CFI_ERROR_MEM_ALLOCATION 11
+ #define CFI_ERROR_OUT_OF_BOUNDS 12
+
+ /* CFI type definitions. */
+ typedef ptrdiff_t CFI_index_t;
+ typedef int8_t CFI_rank_t;
+ typedef int8_t CFI_attribute_t;
+ typedef int16_t CFI_type_t;
+
+ /* CFI_dim_t. */
+ typedef struct CFI_dim_t
+ {
+ CFI_index_t lower_bound;
+ CFI_index_t extent;
+ CFI_index_t sm;
+ }
+ CFI_dim_t;
+
+ /* CFI_cdesc_t, C descriptors are cast to this structure as follows:
+ CFI_CDESC_T(CFI_MAX_RANK) foo;
+ CFI_cdesc_t * bar = (CFI_cdesc_t *) &foo;
+ */
+ typedef struct CFI_cdesc_t
+ {
+ void *base_addr;
+ size_t elem_len;
+ int version;
+ CFI_rank_t rank;
+ CFI_attribute_t attribute;
+ CFI_type_t type;
+ CFI_dim_t dim[];
+ }
+ CFI_cdesc_t;
+
+ /* CFI_CDESC_T with an explicit type. */
+ #define CFI_CDESC_TYPE_T(r, base_type) \
+ struct { \
+ base_type *base_addr; \
+ size_t elem_len; \
+ int version; \
+ CFI_rank_t rank; \
+ CFI_attribute_t attribute; \
+ CFI_type_t type; \
+ CFI_dim_t dim[r]; \
+ }
+ #define CFI_CDESC_T(r) CFI_CDESC_TYPE_T (r, void)
+
+ /* CFI function declarations. */
+ extern void *CFI_address (const CFI_cdesc_t *, const CFI_index_t []);
+ extern int CFI_allocate (CFI_cdesc_t *, const CFI_index_t [], const CFI_index_t [],
+ size_t);
+ extern int CFI_deallocate (CFI_cdesc_t *);
+ extern int CFI_establish (CFI_cdesc_t *, void *, CFI_attribute_t, CFI_type_t, size_t,
+ CFI_rank_t, const CFI_index_t []);
+ extern int CFI_is_contiguous (const CFI_cdesc_t *);
+ extern int CFI_section (CFI_cdesc_t *, const CFI_cdesc_t *, const CFI_index_t [],
+ const CFI_index_t [], const CFI_index_t []);
+ extern int CFI_select_part (CFI_cdesc_t *, const CFI_cdesc_t *, size_t, size_t);
+ extern int CFI_setpointer (CFI_cdesc_t *, CFI_cdesc_t *, const CFI_index_t []);
+
+ /* Types and kind numbers. Allows bitwise and to reveal the intrinsic type of a kind type. It also allows us to find the kind parameter by inverting the bit-shift equation.
+ CFI_type_kind_shift = 8
+ CFI_intrinsic_type = 0 0 0 0 0 0 0 0 0 0 1 0
+ CFI_type_kind = 0 0 0 0 0 0 0 0 1 0 0 0
+ CFI_type_example = CFI_intrinsic_type + (CFI_type_kind << CFI_type_kind_shift)
+ Defining the CFI_type_example.
+ CFI_type_kind = 0 0 0 0 0 0 0 0 1 0 0 0 << CFI_type_kind_shift
+ -------------------------
+ 1 0 0 0 0 0 0 0 0 0 0 0 +
+ CFI_intrinsic_type = 0 0 0 0 0 0 0 0 0 0 1 0
+ -------------------------
+ CFI_type_example = 1 0 0 0 0 0 0 0 0 0 1 0
+ Finding the intrinsic type with the logical mask.
+ CFI_type_example = 1 0 0 0 0 0 0 0 0 0 1 0 &
+ CFI_type_mask = 0 0 0 0 1 1 1 1 1 1 1 1
+ -------------------------
+ CFI_intrinsic_type = 0 0 0 0 0 0 0 0 0 0 1 0
+ Using the intrinsic type and kind shift to find the kind value of the type.
+ CFI_type_kind = (CFI_type_example - CFI_intrinsic_type) >> CFI_type_kind_shift
+ CFI_type_example = 1 0 0 0 0 0 0 0 0 0 1 0 -
+ CFI_intrinsic_type = 0 0 0 0 0 0 0 0 0 0 1 0
+ -------------------------
+ 1 0 0 0 0 0 0 0 0 0 0 0 >> CFI_type_kind_shift
+ -------------------------
+ CFI_type_kind = 0 0 0 0 0 0 0 0 1 0 0 0
+ */
+ #define CFI_type_mask 0xFF
+ #define CFI_type_kind_shift 8
+
+ /* Intrinsic types. Their kind number defines their storage size. */
+ #define CFI_type_Integer 1
+ #define CFI_type_Logical 2
+ #define CFI_type_Real 3
+ #define CFI_type_Complex 4
+ #define CFI_type_Character 5
+
+ /* Types with no kind. */
+ #define CFI_type_struct 6
+ #define CFI_type_cptr 7
+ #define CFI_type_cfunptr 8
+ #define CFI_type_other -1
+
+ /* Types with kind parameter.
+ The kind parameter represents the type's byte size. The exception is kind = 10, which has byte size of 64 but 80 bit precision. Complex variables are double the byte size of their real counterparts. The ucs4_char matches wchar_t if sizeof (wchar_t) == 4.
+ */
+ #define CFI_type_char (CFI_type_Character + (1 << CFI_type_kind_shift))
+ #define CFI_type_ucs4_char (CFI_type_Character + (4 << CFI_type_kind_shift))
+
+ /* C-Fortran Interoperability types. */
+ #define CFI_type_signed_char (CFI_type_Integer + (1 << CFI_type_kind_shift))
+ #define CFI_type_short (CFI_type_Integer + (2 << CFI_type_kind_shift))
+ #define CFI_type_int (CFI_type_Integer + (4 << CFI_type_kind_shift))
+ #define CFI_type_long (CFI_type_Integer + (8 << CFI_type_kind_shift))
+ #define CFI_type_long_long (CFI_type_Integer + (8 << CFI_type_kind_shift))
+ #define CFI_type_size_t (CFI_type_Integer + (8 << CFI_type_kind_shift))
+ #define CFI_type_int8_t (CFI_type_Integer + (1 << CFI_type_kind_shift))
+ #define CFI_type_int16_t (CFI_type_Integer + (2 << CFI_type_kind_shift))
+ #define CFI_type_int32_t (CFI_type_Integer + (4 << CFI_type_kind_shift))
+ #define CFI_type_int64_t (CFI_type_Integer + (8 << CFI_type_kind_shift))
+ #define CFI_type_int_least8_t (CFI_type_Integer + (1 << CFI_type_kind_shift))
+ #define CFI_type_int_least16_t (CFI_type_Integer + (2 << CFI_type_kind_shift))
+ #define CFI_type_int_least32_t (CFI_type_Integer + (4 << CFI_type_kind_shift))
+ #define CFI_type_int_least64_t (CFI_type_Integer + (8 << CFI_type_kind_shift))
+ #define CFI_type_int_fast8_t (CFI_type_Integer + (1 << CFI_type_kind_shift))
+ #define CFI_type_int_fast16_t (CFI_type_Integer + (2 << CFI_type_kind_shift))
+ #define CFI_type_int_fast32_t (CFI_type_Integer + (4 << CFI_type_kind_shift))
+ #define CFI_type_int_fast64_t (CFI_type_Integer + (8 << CFI_type_kind_shift))
+ #define CFI_type_intmax_t (CFI_type_Integer + (8 << CFI_type_kind_shift))
+ #define CFI_type_intptr_t (CFI_type_Integer + (8 << CFI_type_kind_shift))
+ #define CFI_type_ptrdiff_t (CFI_type_Integer + (8 << CFI_type_kind_shift))
+ #define CFI_type_int128_t (CFI_type_Integer + (16 << CFI_type_kind_shift))
+ #define CFI_type_int_least128_t (CFI_type_Integer + (16 << CFI_type_kind_shift))
+ #define CFI_type_int_fast128_t (CFI_type_Integer + (16 << CFI_type_kind_shift))
+ #define CFI_type_Bool (CFI_type_Logical + (1 << CFI_type_kind_shift))
+ #define CFI_type_float (CFI_type_Real + (4 << CFI_type_kind_shift))
+ #define CFI_type_double (CFI_type_Real + (8 << CFI_type_kind_shift))
+ #define CFI_type_long_double (CFI_type_Real + (10 << CFI_type_kind_shift))
+ #define CFI_type_float128 (CFI_type_Real + (16 << CFI_type_kind_shift))
+ #define CFI_type_float_Complex (CFI_type_Complex + (4 << CFI_type_kind_shift))
+ #define CFI_type_double_Complex (CFI_type_Complex + (8 << CFI_type_kind_shift))
+ #define CFI_type_long_double_Complex (CFI_type_Complex + (10 << CFI_type_kind_shift))
+ #define CFI_type_float128_Complex (CFI_type_Complex + (16 << CFI_type_kind_shift))
+
+ #ifdef __cplusplus
+ }
+ #endif
+
+ #endif /* ISO_FORTRAN_BINDING_H */
Index: libgfortran/Makefile.am
===================================================================
*** libgfortran/Makefile.am (revision 266426)
--- libgfortran/Makefile.am (working copy)
***************
*** 1,6 ****
## Process this file with automake to produce Makefile.in
-
ACLOCAL_AMFLAGS = -I .. -I ../config
## May be used by toolexeclibdir.
--- 1,5 ----
*************** intrinsics/selected_int_kind.f90 \
*** 139,145 ****
intrinsics/selected_real_kind.f90 \
intrinsics/unpack_generic.c \
runtime/in_pack_generic.c \
! runtime/in_unpack_generic.c
if !LIBGFOR_MINIMAL
--- 138,145 ----
intrinsics/selected_real_kind.f90 \
intrinsics/unpack_generic.c \
runtime/in_pack_generic.c \
! runtime/in_unpack_generic.c \
! runtime/ISO_Fortran_binding.c
if !LIBGFOR_MINIMAL
*************** $(srcdir)/generated/spread_r16.c \
*** 780,786 ****
$(srcdir)/generated/spread_c4.c \
$(srcdir)/generated/spread_c8.c \
$(srcdir)/generated/spread_c10.c \
! $(srcdir)/generated/spread_c16.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 \
--- 780,786 ----
$(srcdir)/generated/spread_c4.c \
$(srcdir)/generated/spread_c8.c \
$(srcdir)/generated/spread_c10.c \
! $(srcdir)/generated/spread_c16.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 \
*************** libgfortran_c.lo: $(filter %.c,$(prereq_
*** 1019,1025 ****
#libgfortran_F.o: $(filter %.F %.F90,$(prereq_SRC))
# $(PPFCCOMPILE) -c $^ -o $@ -combine
#
! #libgfortran_F.lo:
# $(LTPPFCCOMPILE) -c -o $@ $^ -combine
libgfortran_la_SOURCES = libgfortran_c.c $(filter-out %.c,$(prereq_SRC))
--- 1019,1025 ----
#libgfortran_F.o: $(filter %.F %.F90,$(prereq_SRC))
# $(PPFCCOMPILE) -c $^ -o $@ -combine
#
! #libgfortran_F.lo:
# $(LTPPFCCOMPILE) -c -o $@ $^ -combine
libgfortran_la_SOURCES = libgfortran_c.c $(filter-out %.c,$(prereq_SRC))
Index: libgfortran/Makefile.in
===================================================================
*** libgfortran/Makefile.in (revision 266426)
--- libgfortran/Makefile.in (working copy)
*************** am__objects_57 = associated.lo abort.lo
*** 418,424 ****
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 \
@IEEE_SUPPORT_TRUE@ ieee_exceptions.lo ieee_features.lo
am__objects_59 =
--- 418,424 ----
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 \
! ISO_Fortran_binding.lo $(am__objects_55) $(am__objects_56)
@IEEE_SUPPORT_TRUE@am__objects_58 = ieee_arithmetic.lo \
@IEEE_SUPPORT_TRUE@ ieee_exceptions.lo ieee_features.lo
am__objects_59 =
*************** pdfdir = @pdfdir@
*** 690,696 ****
prefix = @prefix@
program_transform_name = @program_transform_name@
psdir = @psdir@
- runstatedir = @runstatedir@
sbindir = @sbindir@
sharedstatedir = @sharedstatedir@
srcdir = @srcdir@
--- 690,695 ----
*************** gfor_helper_src = intrinsics/associated.
*** 766,772 ****
intrinsics/selected_int_kind.f90 \
intrinsics/selected_real_kind.f90 intrinsics/unpack_generic.c \
runtime/in_pack_generic.c runtime/in_unpack_generic.c \
! $(am__append_3) $(am__append_4)
@IEEE_SUPPORT_FALSE@gfor_ieee_src =
@IEEE_SUPPORT_TRUE@gfor_ieee_src = \
@IEEE_SUPPORT_TRUE@ieee/ieee_arithmetic.F90 \
--- 765,771 ----
intrinsics/selected_int_kind.f90 \
intrinsics/selected_real_kind.f90 intrinsics/unpack_generic.c \
runtime/in_pack_generic.c runtime/in_unpack_generic.c \
! runtime/ISO_Fortran_binding.c $(am__append_3) $(am__append_4)
@IEEE_SUPPORT_FALSE@gfor_ieee_src =
@IEEE_SUPPORT_TRUE@gfor_ieee_src = \
@IEEE_SUPPORT_TRUE@ieee/ieee_arithmetic.F90 \
*************** $(srcdir)/generated/spread_r16.c \
*** 1338,1344 ****
$(srcdir)/generated/spread_c4.c \
$(srcdir)/generated/spread_c8.c \
$(srcdir)/generated/spread_c10.c \
! $(srcdir)/generated/spread_c16.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 \
--- 1337,1343 ----
$(srcdir)/generated/spread_c4.c \
$(srcdir)/generated/spread_c8.c \
$(srcdir)/generated/spread_c10.c \
! $(srcdir)/generated/spread_c16.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 \
*************** prereq_SRC = $(gfor_src) $(gfor_built_sr
*** 1537,1543 ****
#libgfortran_F.o: $(filter %.F %.F90,$(prereq_SRC))
# $(PPFCCOMPILE) -c $^ -o $@ -combine
#
! #libgfortran_F.lo:
# $(LTPPFCCOMPILE) -c -o $@ $^ -combine
@onestep_TRUE@libgfortran_la_SOURCES = libgfortran_c.c $(filter-out %.c,$(prereq_SRC))
I_M4_DEPS = m4/iparm.m4
--- 1536,1542 ----
#libgfortran_F.o: $(filter %.F %.F90,$(prereq_SRC))
# $(PPFCCOMPILE) -c $^ -o $@ -combine
#
! #libgfortran_F.lo:
# $(LTPPFCCOMPILE) -c -o $@ $^ -combine
@onestep_TRUE@libgfortran_la_SOURCES = libgfortran_c.c $(filter-out %.c,$(prereq_SRC))
I_M4_DEPS = m4/iparm.m4
*************** mostlyclean-compile:
*** 1697,1702 ****
--- 1696,1702 ----
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@
*************** in_unpack_generic.lo: runtime/in_unpack_
*** 6381,6386 ****
--- 6381,6393 ----
@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 in_unpack_generic.lo `test -f 'runtime/in_unpack_generic.c' || echo '$(srcdir)/'`runtime/in_unpack_generic.c
+ ISO_Fortran_binding.lo: 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 'runtime/ISO_Fortran_binding.c' || echo '$(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='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 'runtime/ISO_Fortran_binding.c' || echo '$(srcdir)/'`runtime/ISO_Fortran_binding.c
+
access.lo: intrinsics/access.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 access.lo -MD -MP -MF $(DEPDIR)/access.Tpo -c -o access.lo `test -f 'intrinsics/access.c' || echo '$(srcdir)/'`intrinsics/access.c
@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/access.Tpo $(DEPDIR)/access.Plo
Index: libgfortran/configure
===================================================================
*** libgfortran/configure (revision 266426)
--- libgfortran/configure (working copy)
*************** infodir
*** 780,786 ****
docdir
oldincludedir
includedir
- runstatedir
localstatedir
sharedstatedir
sysconfdir
--- 780,785 ----
*************** datadir='${datarootdir}'
*** 871,877 ****
sysconfdir='${prefix}/etc'
sharedstatedir='${prefix}/com'
localstatedir='${prefix}/var'
- runstatedir='${localstatedir}/run'
includedir='${prefix}/include'
oldincludedir='/usr/include'
docdir='${datarootdir}/doc/${PACKAGE_TARNAME}'
--- 870,875 ----
*************** do
*** 1124,1138 ****
| -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=* \
--- 1122,1127 ----
*************** fi
*** 1270,1276 ****
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
do
eval ac_val=\$$ac_var
# Remove trailing slashes.
--- 1259,1265 ----
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
do
eval ac_val=\$$ac_var
# Remove trailing slashes.
*************** Fine tuning of the installation director
*** 1423,1429 ****
--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]
--- 1412,1417 ----
*************** else
*** 12696,12702 ****
lt_dlunknown=0; lt_dlno_uscore=1; lt_dlneed_uscore=2
lt_status=$lt_dlunknown
cat > conftest.$ac_ext <<_LT_EOF
! #line 12699 "configure"
#include "confdefs.h"
#if HAVE_DLFCN_H
--- 12684,12690 ----
lt_dlunknown=0; lt_dlno_uscore=1; lt_dlneed_uscore=2
lt_status=$lt_dlunknown
cat > conftest.$ac_ext <<_LT_EOF
! #line 12687 "configure"
#include "confdefs.h"
#if HAVE_DLFCN_H
*************** else
*** 12802,12808 ****
lt_dlunknown=0; lt_dlno_uscore=1; lt_dlneed_uscore=2
lt_status=$lt_dlunknown
cat > conftest.$ac_ext <<_LT_EOF
! #line 12805 "configure"
#include "confdefs.h"
#if HAVE_DLFCN_H
--- 12790,12796 ----
lt_dlunknown=0; lt_dlno_uscore=1; lt_dlneed_uscore=2
lt_status=$lt_dlunknown
cat > conftest.$ac_ext <<_LT_EOF
! #line 12793 "configure"
#include "confdefs.h"
#if HAVE_DLFCN_H
*************** else
*** 16051,16057 ****
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))
int off_t_is_large[(LARGE_OFF_T % 2147483629 == 721
&& LARGE_OFF_T % 2147483647 == 1)
? 1 : -1];
--- 16039,16045 ----
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 << 62) - 1 + ((off_t) 1 << 62))
int off_t_is_large[(LARGE_OFF_T % 2147483629 == 721
&& LARGE_OFF_T % 2147483647 == 1)
? 1 : -1];
*************** else
*** 16097,16103 ****
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))
int off_t_is_large[(LARGE_OFF_T % 2147483629 == 721
&& LARGE_OFF_T % 2147483647 == 1)
? 1 : -1];
--- 16085,16091 ----
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 << 62) - 1 + ((off_t) 1 << 62))
int off_t_is_large[(LARGE_OFF_T % 2147483629 == 721
&& LARGE_OFF_T % 2147483647 == 1)
? 1 : -1];
*************** rm -f core conftest.err conftest.$ac_obj
*** 16121,16127 ****
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))
int off_t_is_large[(LARGE_OFF_T % 2147483629 == 721
&& LARGE_OFF_T % 2147483647 == 1)
? 1 : -1];
--- 16109,16115 ----
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 << 62) - 1 + ((off_t) 1 << 62))
int off_t_is_large[(LARGE_OFF_T % 2147483629 == 721
&& LARGE_OFF_T % 2147483647 == 1)
? 1 : -1];
*************** else
*** 16166,16172 ****
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))
int off_t_is_large[(LARGE_OFF_T % 2147483629 == 721
&& LARGE_OFF_T % 2147483647 == 1)
? 1 : -1];
--- 16154,16160 ----
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 << 62) - 1 + ((off_t) 1 << 62))
int off_t_is_large[(LARGE_OFF_T % 2147483629 == 721
&& LARGE_OFF_T % 2147483647 == 1)
? 1 : -1];
*************** rm -f core conftest.err conftest.$ac_obj
*** 16190,16196 ****
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))
int off_t_is_large[(LARGE_OFF_T % 2147483629 == 721
&& LARGE_OFF_T % 2147483647 == 1)
? 1 : -1];
--- 16178,16184 ----
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 << 62) - 1 + ((off_t) 1 << 62))
int off_t_is_large[(LARGE_OFF_T % 2147483629 == 721
&& LARGE_OFF_T % 2147483647 == 1)
? 1 : -1];
Index: libgfortran/gfortran.map
===================================================================
*** libgfortran/gfortran.map (revision 266426)
--- libgfortran/gfortran.map (working copy)
*************** GFORTRAN_C99_8 {
*** 1486,1491 ****
--- 1486,1501 ----
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;
Index: libgfortran/runtime/ISO_Fortran_binding.c
===================================================================
*** libgfortran/runtime/ISO_Fortran_binding.c (nonexistent)
--- libgfortran/runtime/ISO_Fortran_binding.c (working copy)
***************
*** 0 ****
--- 1,916 ----
+ /* 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 > 1)
+ 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));
+
+ /* We have to assume that pointers to element of arrays of derived
+ types will never be encountered. Full pointer or allocatable
+ arrays have zero lower_bound. */
+ for (n = 0; n < GFC_DESCRIPTOR_RANK (s); n++)
+ {
+ if (d->attribute > 1)
+ 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;
+
+ /* C Descriptor must not be NULL. */
+ if (dv == NULL)
+ {
+ fprintf (stderr, "ISO_Fortran_binding.c: CFI_address: C Descriptor is "
+ "NULL. (Error No. %d).\n", CFI_INVALID_DESCRIPTOR);
+ return NULL;
+ }
+
+ /* Base address of C Descriptor must not be NULL. */
+ if (dv->base_addr == NULL)
+ {
+ fprintf (stderr, "ISO_Fortran_binding.c: CFI_address: base address of C "
+ "Descriptor must not be NULL. (Error No. %d).\n",
+ CFI_ERROR_BASE_ADDR_NULL);
+ 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 ((dv->dim[i].extent != -1
+ && subscripts[i] >= dv->dim[i].extent) || subscripts[i] < 0)
+ {
+ fprintf (stderr, "ISO_Fortran_binding.c: CFI_address: "
+ "subscripts[%d], is out of bounds. "
+ "dv->dim[%d].extent = %d subscripts[%d] = %d "
+ "(Error No. %d).\n",
+ i, i, dv->dim[i].extent, i, subscripts[i],
+ CFI_ERROR_OUT_OF_BOUNDS);
+ 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)
+ {
+ /* C Descriptor must not be NULL. */
+ if (dv == NULL)
+ {
+ fprintf (stderr, "ISO_Fortran_binding.c: CFI_allocate: C Descriptor is "
+ "NULL. (Error No. %d).\n",
+ CFI_INVALID_DESCRIPTOR);
+ return CFI_INVALID_DESCRIPTOR;
+ }
+
+ /* Base address of C Descriptor must be NULL. */
+ if (dv->base_addr != NULL)
+ {
+ fprintf (stderr, "ISO_Fortran_binding.c: CFI_allocate: Base address of C "
+ "Descriptor must be NULL. (Error No. %d).\n",
+ CFI_ERROR_BASE_ADDR_NOT_NULL);
+ return CFI_ERROR_BASE_ADDR_NOT_NULL;
+ }
+
+ /* The C Descriptor must be for an allocatable or pointer object. */
+ if (dv->attribute == CFI_attribute_other)
+ {
+ fprintf (stderr,
+ "ISO_Fortran_binding.c: CFI_allocate: The object of the C "
+ "Descriptor must be a pointer or allocatable variable. "
+ "(Error No. %d).\n",
+ CFI_INVALID_ATTRIBUTE);
+ return CFI_INVALID_ATTRIBUTE;
+ }
+
+ /* 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 (lower_bounds == NULL || upper_bounds == NULL)
+ {
+ fprintf (stderr, "ISO_Fortran_binding.c: CFI_allocate: If 0 < rank "
+ "(= %d) upper_bounds[] and lower_bounds[], must not "
+ "be NULL. (Error No. %d).\n",
+ dv->rank, CFI_INVALID_EXTENT);
+ 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)
+ {
+ printf ("ISO_Fortran_binding.c: CFI_allocate: Failure in memory "
+ "allocation. (Error no. %d).\n",
+ CFI_ERROR_MEM_ALLOCATION);
+ return CFI_ERROR_MEM_ALLOCATION;
+ }
+
+ return CFI_SUCCESS;
+ }
+
+
+ int
+ CFI_deallocate (CFI_cdesc_t *dv)
+ {
+ /* C Descriptor must not be NULL */
+ if (dv == NULL)
+ {
+ fprintf (stderr, "ISO_Fortran_binding.c: CFI_deallocate: C Descriptor. "
+ "is NULL. (Error No. %d).\n",
+ CFI_INVALID_DESCRIPTOR);
+ return CFI_INVALID_DESCRIPTOR;
+ }
+
+ /* Base address must not be NULL. */
+ if (dv->base_addr == NULL)
+ {
+ fprintf (stderr, "ISO_Fortran_binding.c: CFI_deallocate: Base address is "
+ "NULL already. (Error No. %d).\n",
+ CFI_ERROR_BASE_ADDR_NULL);
+ return CFI_ERROR_BASE_ADDR_NULL;
+ }
+
+ /* C Descriptor must be for an allocatable or pointer variable. */
+ if (dv->attribute == CFI_attribute_other)
+ {
+ fprintf (stderr, "ISO_Fortran_binding.c: CFI_deallocate: C Descriptor "
+ "must describe a pointer or allocatabale object. (Error "
+ "No. %d).\n",
+ CFI_INVALID_ATTRIBUTE);
+ 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[])
+ {
+ /* C descriptor must not be NULL. */
+ if (dv == NULL)
+ {
+ fprintf (stderr, "ISO_Fortran_binding.c: CFI_establish: C descriptor is "
+ "NULL. (Error No. %d).\n",
+ CFI_INVALID_DESCRIPTOR);
+ return CFI_INVALID_DESCRIPTOR;
+ }
+
+ /* Rank must be between 0 and CFI_MAX_RANK. */
+ if (rank < 0 || rank > CFI_MAX_RANK)
+ {
+ fprintf (stderr, "ISO_Fortran_binding.c: CFI_establish: Rank must be "
+ "between 0 and %d, 0 < rank (0 !< %d). (Error No. "
+ "%d).\n",
+ CFI_MAX_RANK, rank, CFI_INVALID_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,
+ "ISO_Fortran_binding.c: CFI_establish: If the C Descriptor "
+ "represents an allocatable variable (dv->attribute = %d), its "
+ "base address must be NULL (dv->base_addr = NULL). (Error No. "
+ "%d).\n",
+ CFI_attribute_allocatable, CFI_INVALID_DESCRIPTOR);
+ 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, "ISO_Fortran_binding.c: CFI_establish: If base address "
+ "is not NULL (base_addr != NULL), the established C "
+ "Descriptor is for a nonallocatable entity (attribute "
+ "!= %d). (Error No. %d).\n",
+ CFI_attribute_allocatable, CFI_INVALID_ATTRIBUTE);
+ 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 (extents == NULL)
+ {
+ fprintf (stderr, "ISO_Fortran_binding.c: CFI_establish: Extents must "
+ "not be NULL (extents != NULL) if rank (= %d) > 0 "
+ "and base address is not NULL (base_addr != NULL). "
+ "(Error No. %d).\n",
+ rank, CFI_INVALID_EXTENT);
+ 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)
+ {
+ /* C descriptor must not be NULL. */
+ if (dv == NULL)
+ {
+ fprintf (stderr, "ISO_Fortran_binding.c: CFI_is_contiguous: C descriptor "
+ "is NULL. (Error No. %d).\n",
+ CFI_INVALID_DESCRIPTOR);
+ return CFI_INVALID_DESCRIPTOR;
+ }
+
+ /* Base address must not be NULL. */
+ if (dv->base_addr == NULL)
+ {
+ fprintf (stderr, "ISO_Fortran_binding.c: CFI_is_contiguous: Base address "
+ "of C Descriptor is already NULL. (Error No. %d).\n",
+ CFI_ERROR_BASE_ADDR_NULL);
+ return CFI_ERROR_BASE_ADDR_NULL;
+ }
+
+ /* Must be an array. */
+ if (dv->rank == 0)
+ {
+ fprintf (stderr, "ISO_Fortran_binding.c: CFI_is_contiguous: C Descriptor "
+ "must describe an array (0 < dv->rank = %d). (Error No. "
+ "%d).\n",
+ dv->rank, CFI_INVALID_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 == dv->elem_len)
+ continue;
+ else if (i > 0 && dv->dim[i].sm == 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];
+
+ bool assumed_size;
+
+ /* C Descriptors must not be NULL. */
+ if (source == NULL)
+ {
+ fprintf (stderr, "ISO_Fortran_binding.c: CFI_section: Source must not be "
+ "NULL. (Error No. %d).\n",
+ CFI_INVALID_DESCRIPTOR);
+ return CFI_INVALID_DESCRIPTOR;
+ }
+ if (result == NULL)
+ {
+ fprintf (stderr, "ISO_Fortran_binding.c: CFI_section: Result must not be "
+ "NULL. (Error No. %d).\n",
+ CFI_INVALID_DESCRIPTOR);
+ return CFI_INVALID_DESCRIPTOR;
+ }
+
+ /* Base address of source must not be NULL. */
+ if (source->base_addr == NULL)
+ {
+ fprintf (stderr, "ISO_Fortran_binding.c: CFI_section: Base address of "
+ "source must not be NULL. (Error No. %d).\n",
+ CFI_ERROR_BASE_ADDR_NULL);
+ return CFI_ERROR_BASE_ADDR_NULL;
+ }
+
+ /* Result must not be an allocatable array. */
+ if (result->attribute == CFI_attribute_allocatable)
+ {
+ fprintf (stderr, "ISO_Fortran_binding.c: CFI_section: Result must not "
+ "describe an allocatable array. (Error No. %d).\n",
+ CFI_INVALID_ATTRIBUTE);
+ 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, "ISO_Fortran_binding.c: CFI_section: Source must "
+ "describe an array (0 < source->rank, 0 !< %d). (Error No. "
+ "%d).\n",
+ source->rank, CFI_INVALID_RANK);
+ return CFI_INVALID_RANK;
+ }
+
+ /* Element lengths of source and result must be equal. */
+ if (result->elem_len != source->elem_len)
+ {
+ fprintf (stderr, "ISO_Fortran_binding.c: CFI_section: The element "
+ "lengths of source (source->elem_len = %ld) and result "
+ "(result->elem_len = %ld) must be equal. (Error No. "
+ "%d).\n",
+ source->elem_len, result->elem_len, CFI_INVALID_ELEM_LEN);
+ return CFI_INVALID_ELEM_LEN;
+ }
+
+ /* Types must be equal. */
+ if (result->type != source->type)
+ {
+ fprintf (stderr, "ISO_Fortran_binding.c: CFI_section: Types of source "
+ "(source->type = %d) and result (result->type = %d) "
+ "must be equal. (Error No. %d).\n",
+ source->type, result->type, CFI_INVALID_TYPE);
+ return CFI_INVALID_TYPE;
+ }
+
+ /* Stride of zero in the i'th dimension means rank reduction in that
+ * dimension. */
+ int zero_count = 0;
+ 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 (result->rank != source->rank - zero_count)
+ {
+ fprintf (stderr, "ISO_Fortran_binding.c: 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) (Error No. %d).\n",
+ result->rank, source->rank, zero_count, CFI_INVALID_RANK);
+ 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 (source->dim[source->rank - 1].extent == -1)
+ {
+ fprintf (stderr,
+ "ISO_Fortran_binding.c: CFI_section: Source must not "
+ "be an assumed size array if upper_bounds is NULL. (Error "
+ "No. %d).\n",
+ CFI_INVALID_EXTENT);
+ 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 (stride[i] == 0 && lower[i] != upper[i])
+ {
+ fprintf (stderr, "ISO_Fortran_binding.c: CFI_section: If "
+ "strides[%d] = 0, then the lower bounds, "
+ "lower_bounds[%d] = %ld, and upper_bounds[%d] = "
+ "%ld, must be equal. (Error No. %d).\n",
+ i, i, lower_bounds[i], i, upper_bounds[i],
+ CFI_ERROR_OUT_OF_BOUNDS);
+ 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 (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, "ISO_Fortran_binding.c: 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, %ld <= %ld <= %ld). "
+ "(Error No. %d).\n",
+ i, i, i, i, source->dim[i].lower_bound, lower[i],
+ source->dim[i].lower_bound + source->dim[i].extent - 1,
+ CFI_ERROR_OUT_OF_BOUNDS);
+ return CFI_ERROR_OUT_OF_BOUNDS;
+ }
+ if (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, "ISO_Fortran_binding.c: 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, %ld !<= %ld !<= %ld). "
+ "(Error No. %d).\n",
+ i, i, i, i, source->dim[i].lower_bound, upper[i],
+ source->dim[i].lower_bound + source->dim[i].extent - 1,
+ CFI_ERROR_OUT_OF_BOUNDS);
+ return CFI_ERROR_OUT_OF_BOUNDS;
+ }
+ if (upper[i] < lower[i] && stride[i] >= 0)
+ {
+ fprintf (stderr, "ISO_Fortran_binding.c: CFI_section: If the upper "
+ "bound is smaller than the lower bound for a given "
+ "dimension (upper[%d] < lower[%d], %ld < %ld), then "
+ "the stride for said dimension must be negative "
+ "(stride[%d] < 0, %ld < 0). (Error No. %d)\n",
+ i, i, upper[i], lower[i], i, stride[i], CFI_INVALID_STRIDE);
+ 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)
+ {
+ /* C Descriptors must not be NULL. */
+ if (source == NULL)
+ {
+ fprintf (stderr, "ISO_Fortran_binding.c: CFI_select_part: Source must "
+ "not be NULL. (Error No. %d).\n",
+ CFI_INVALID_DESCRIPTOR);
+ return CFI_INVALID_DESCRIPTOR;
+ }
+ if (result == NULL)
+ {
+ fprintf (stderr, "ISO_Fortran_binding.c: CFI_select_part: Result must "
+ "not be NULL. (Error No. %d).\n",
+ CFI_INVALID_DESCRIPTOR);
+ return CFI_INVALID_DESCRIPTOR;
+ }
+
+ /* Attribute of result will be CFI_attribute_other or CFI_attribute_pointer.
+ */
+ if (result->attribute == CFI_attribute_allocatable)
+ {
+ fprintf (stderr, "ISO_Fortran_binding.c: CFI_select_part: Result must "
+ "not describe an allocatable object (result->attribute "
+ "!= %d). (Error No. %d).\n",
+ CFI_attribute_allocatable, CFI_INVALID_ATTRIBUTE);
+ return CFI_INVALID_ATTRIBUTE;
+ }
+
+ /* Base address of source must not be NULL. */
+ if (source->base_addr == NULL)
+ {
+ fprintf (stderr, "ISO_Fortran_binding.c: CFI_select_part: Base address "
+ "of source must not be NULL. (Error No. %d).\n",
+ CFI_ERROR_BASE_ADDR_NULL);
+ return CFI_ERROR_BASE_ADDR_NULL;
+ }
+
+ /* Source and result must have the same rank. */
+ if (source->rank != result->rank)
+ {
+ fprintf (stderr, "ISO_Fortran_binding.c: CFI_select_part: Source and "
+ "result must have the same rank (source->rank = %d, "
+ "result->rank = %d). (Error No. %d).\n",
+ source->rank, result->rank, CFI_INVALID_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, "ISO_Fortran_binding.c: CFI_select_part: Source must "
+ "not describe an assumed size array "
+ "(source->dim[%d].extent != -1). (Error No. %d).\n",
+ source->rank - 1, CFI_INVALID_DESCRIPTOR);
+ 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;
+ }
+
+ /* Ensure displacement is within the bounds of the element length of source.
+ */
+ if (displacement > source->elem_len - 1)
+ {
+ fprintf (stderr, "ISO_Fortran_binding.c: CFI_select_part: Displacement "
+ "must be within the bounds of source (0 <= displacement "
+ "<= source->elem_len - 1, 0 <= %ld <= %ld). (Error No. "
+ "%d).\n",
+ displacement, source->elem_len - 1, CFI_ERROR_OUT_OF_BOUNDS);
+ 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, "ISO_Fortran_binding.c: 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, %ld + %ld = %ld "
+ "<= %ld). (Error No. %d).\n",
+ displacement, result->elem_len, displacement + result->elem_len,
+ source->elem_len, CFI_ERROR_OUT_OF_BOUNDS);
+ 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 (result == NULL)
+ {
+ fprintf (stderr, "ISO_Fortran_binding.c: CFI_setpointer: Result is NULL. "
+ "(Error No. %d).\n",
+ CFI_INVALID_DESCRIPTOR);
+ 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 (result->elem_len != source->elem_len)
+ {
+ fprintf (stderr, "ISO_Fortran_binding.c: CFI_setpointer: Element "
+ "lengths of result (result->elem_len = %ld) and "
+ "source (source->elem_len = %ld) must be the same. "
+ "(Error No. %d).\n",
+ result->elem_len, source->elem_len, CFI_INVALID_ELEM_LEN);
+ return CFI_INVALID_ELEM_LEN;
+ }
+
+ if (result->rank != source->rank)
+ {
+ fprintf (stderr, "ISO_Fortran_binding.c: CFI_setpointer: Ranks of "
+ "result (result->rank = %d) and source "
+ "(source->rank = %d) must be the same. (Error "
+ "No. %d).\n",
+ result->rank, source->rank, CFI_INVALID_RANK);
+ return CFI_INVALID_RANK;
+ }
+
+ if (result->type != source->type)
+ {
+ fprintf (stderr, "ISO_Fortran_binding.c: CFI_setpointer: Types of "
+ "result (result->type = %d) and source "
+ "(source->type = %d) must be the same. (Error "
+ "No. %d).\n",
+ result->type, source->type, CFI_INVALID_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;
+ }
Attachment:
Change.Logs
Description: Binary data
| Index Nav: | [Date Index] [Subject Index] [Author Index] [Thread Index] | |
|---|---|---|
| Message Nav: | [Date Prev] [Date Next] | [Thread Prev] [Thread Next] |