+2019-04-14 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/89843
+ * trans-decl.c (gfc_get_symbol_decl): Assumed shape and assumed
+ rank dummies of bind C procs require deferred initialization.
+ (convert_CFI_desc): New procedure to convert incoming CFI
+ descriptors to gfc types and back again.
+ (gfc_trans_deferred_vars): Call it.
+ * trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): Null the CFI
+ descriptor pointer. Free the descriptor in all cases.
+
+ PR fortran/89846
+ * expr.c (is_CFI_desc): New function.
+ (is_subref_array): Tidy up by referencing the symbol directly.
+ * gfortran.h : Prototype for is_CFI_desc.
+ * trans_array.c (get_CFI_desc): New function.
+ (gfc_get_array_span, gfc_conv_scalarized_array_ref,
+ gfc_conv_array_ref): Use it.
+ * trans.c (get_array_span): Extract the span from descriptors
+ that are indirect references.
+
+ PR fortran/90022
+ * trans-decl.c (gfc_get_symbol_decl): Make sure that the se
+ expression is a pointer type before converting it to the symbol
+ backend_decl type.
+ * trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): Eliminate
+ temporary creation for intent(in).
+
2019-04-13 Dominique d'Humieres <dominiq@gcc.gnu.org>
PR fortran/79842
}
+/* Is true if the expression or symbol is a passed CFI descriptor. */
+bool
+is_CFI_desc (gfc_symbol *sym, gfc_expr *e)
+{
+ if (sym == NULL
+ && e && e->expr_type == EXPR_VARIABLE)
+ sym = e->symtree->n.sym;
+
+ if (sym && sym->attr.dummy
+ && sym->ns->proc_name->attr.is_bind_c
+ && sym->attr.dimension
+ && (sym->attr.pointer
+ || sym->attr.allocatable
+ || sym->as->type == AS_ASSUMED_SHAPE
+ || sym->as->type == AS_ASSUMED_RANK))
+ return true;
+
+return false;
+}
+
+
/* Is true if an array reference is followed by a component or substring
reference. */
bool
{
gfc_ref * ref;
bool seen_array;
+ gfc_symbol *sym;
if (e->expr_type != EXPR_VARIABLE)
return false;
- if (e->symtree->n.sym->attr.subref_array_pointer)
+ sym = e->symtree->n.sym;
+
+ if (sym->attr.subref_array_pointer)
return true;
seen_array = false;
return seen_array;
}
- if (e->symtree->n.sym->ts.type == BT_CLASS
- && e->symtree->n.sym->attr.dummy
- && CLASS_DATA (e->symtree->n.sym)->attr.dimension
- && CLASS_DATA (e->symtree->n.sym)->attr.class_pointer)
+ if (sym->ts.type == BT_CLASS
+ && sym->attr.dummy
+ && CLASS_DATA (sym)->attr.dimension
+ && CLASS_DATA (sym)->attr.class_pointer)
return true;
return false;
bool gfc_extract_int (gfc_expr *, int *, int = 0);
bool gfc_extract_hwi (gfc_expr *, HOST_WIDE_INT *, int = 0);
+bool is_CFI_desc (gfc_symbol *, gfc_expr *);
bool is_subref_array (gfc_expr *);
bool gfc_is_simply_contiguous (gfc_expr *, bool, bool);
bool gfc_is_not_contiguous (gfc_expr *);
}
+/* If the symbol or expression reference a CFI descriptor, return the
+ pointer to the converted gfc descriptor. If an array reference is
+ present as the last argument, check that it is the one applied to
+ the CFI descriptor in the expression. Note that the CFI object is
+ always the symbol in the expression! */
+
+static bool
+get_CFI_desc (gfc_symbol *sym, gfc_expr *expr,
+ tree *desc, gfc_array_ref *ar)
+{
+ tree tmp;
+
+ if (!is_CFI_desc (sym, expr))
+ return false;
+
+ if (expr && ar)
+ {
+ if (!(expr->ref && expr->ref->type == REF_ARRAY)
+ || (&expr->ref->u.ar != ar))
+ return false;
+ }
+
+ if (sym == NULL)
+ tmp = expr->symtree->n.sym->backend_decl;
+ else
+ tmp = sym->backend_decl;
+
+ if (tmp && DECL_LANG_SPECIFIC (tmp))
+ tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp);
+
+ *desc = tmp;
+ return true;
+}
+
+
/* Return the span of an array. */
tree
{
tree tmp;
- if (is_pointer_array (desc))
- /* This will have the span field set. */
- tmp = gfc_conv_descriptor_span_get (desc);
+ if (is_pointer_array (desc) || get_CFI_desc (NULL, expr, &desc, NULL))
+ {
+ if (POINTER_TYPE_P (TREE_TYPE (desc)))
+ desc = build_fold_indirect_ref_loc (input_location, desc);
+
+ /* This will have the span field set. */
+ tmp = gfc_conv_descriptor_span_get (desc);
+ }
else if (TREE_CODE (desc) == COMPONENT_REF
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
&& GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (desc, 0))))
if (build_class_array_ref (se, base, index))
return;
+ if (get_CFI_desc (NULL, expr, &decl, ar))
+ {
+ decl = build_fold_indirect_ref_loc (input_location, decl);
+ goto done;
+ }
+
if (expr && ((is_subref_array (expr)
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (info->descriptor)))
|| (expr->ts.deferred && (expr->expr_type == EXPR_VARIABLE
/* A pointer array component can be detected from its field decl. Fix
the descriptor, mark the resulting variable decl and pass it to
build_array_ref. */
+ if (get_CFI_desc (sym, expr, &decl, ar))
+ decl = build_fold_indirect_ref_loc (input_location, decl);
if (!expr->ts.deferred && !sym->attr.codimension
&& is_pointer_array (se->expr))
{
}
+/* Convert CFI descriptor dummies into gfc types and back again. */
+static void
+convert_CFI_desc (gfc_wrapped_block * block, gfc_symbol *sym)
+{
+ tree gfc_desc;
+ tree gfc_desc_ptr;
+ tree CFI_desc;
+ tree CFI_desc_ptr;
+ tree dummy_ptr;
+ tree tmp;
+ tree incoming;
+ tree outgoing;
+ stmtblock_t tmpblock;
+
+ /* dummy_ptr will be the pointer to the passed array descriptor,
+ while CFI_desc is the descriptor itself. */
+ if (DECL_LANG_SPECIFIC (sym->backend_decl))
+ CFI_desc = GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl);
+ else
+ CFI_desc = NULL;
+
+ dummy_ptr = CFI_desc;
+
+ if (CFI_desc)
+ {
+ CFI_desc = build_fold_indirect_ref_loc (input_location, CFI_desc);
+
+ /* The compiler will have given CFI_desc the correct gfortran
+ type. Use this new variable to store the converted
+ descriptor. */
+ gfc_desc = gfc_create_var (TREE_TYPE (CFI_desc), "gfc_desc");
+ tmp = build_pointer_type (TREE_TYPE (gfc_desc));
+ gfc_desc_ptr = gfc_create_var (tmp, "gfc_desc_ptr");
+ CFI_desc_ptr = gfc_create_var (pvoid_type_node, "CFI_desc_ptr");
+
+ gfc_init_block (&tmpblock);
+ /* Pointer to the gfc descriptor. */
+ gfc_add_modify (&tmpblock, gfc_desc_ptr,
+ gfc_build_addr_expr (NULL, gfc_desc));
+ /* Store the pointer to the CFI descriptor. */
+ gfc_add_modify (&tmpblock, CFI_desc_ptr,
+ fold_convert (pvoid_type_node, dummy_ptr));
+ tmp = gfc_build_addr_expr (ppvoid_type_node, CFI_desc_ptr);
+ /* Convert the CFI descriptor. */
+ incoming = build_call_expr_loc (input_location,
+ gfor_fndecl_cfi_to_gfc, 2, gfc_desc_ptr, tmp);
+ gfc_add_expr_to_block (&tmpblock, incoming);
+ /* Set the dummy pointer to point to the gfc_descriptor. */
+ gfc_add_modify (&tmpblock, dummy_ptr,
+ fold_convert (TREE_TYPE (dummy_ptr), gfc_desc_ptr));
+ incoming = gfc_finish_block (&tmpblock);
+
+ gfc_init_block (&tmpblock);
+ /* Convert the gfc descriptor back to the CFI type before going
+ out of scope. */
+ tmp = gfc_build_addr_expr (ppvoid_type_node, CFI_desc_ptr);
+ outgoing = build_call_expr_loc (input_location,
+ gfor_fndecl_gfc_to_cfi, 2, tmp, gfc_desc_ptr);
+ gfc_add_expr_to_block (&tmpblock, outgoing);
+ outgoing = gfc_finish_block (&tmpblock);
+
+ /* Add the lot to the procedure init and finally blocks. */
+ gfc_add_init_cleanup (block, incoming, outgoing);
+ }
+}
+
/* Get the result expression for a procedure. */
static tree
}
else if (!(UNLIMITED_POLY(sym)) && !is_pdt_type)
gcc_unreachable ();
+
+ /* Assumed shape and assumed rank arrays are passed to BIND(C) procedures
+ as ISO Fortran Interop descriptors. These have to be converted to
+ gfortran descriptors and back again. This has to be done here so that
+ the conversion occurs at the start of the init block. */
+ if (is_CFI_desc (sym, NULL))
+ convert_CFI_desc (block, sym);
}
gfc_init_block (&tmpblock);
tree tmp;
tree cfi_desc_ptr;
tree gfc_desc_ptr;
- tree ptr = NULL_TREE;
- tree size;
tree type;
+ tree cond;
int attribute;
symbol_attribute attr = gfc_expr_attr (e);
+ stmtblock_t block;
/* If this is a full array or a scalar, the allocatable and pointer
attributes can be passed. Otherwise it is 'CFI_attribute_other'*/
tmp = fold_convert (gfc_array_index_type, tmp);
gfc_conv_descriptor_span_set (&parmse->pre, parmse->expr, tmp);
}
-
- /* INTENT(IN) requires a temporary for the data. Assumed types do not
- work with the standard temporary generation schemes. */
- if (e->expr_type == EXPR_VARIABLE && fsym->attr.intent == INTENT_IN)
- {
- /* Fix the descriptor and determine the size of the data. */
- parmse->expr = gfc_evaluate_now (parmse->expr, &parmse->pre);
- size = build_call_expr_loc (input_location,
- gfor_fndecl_size0, 1,
- gfc_build_addr_expr (NULL, parmse->expr));
- size = fold_convert (size_type_node, size);
- tmp = gfc_conv_descriptor_span_get (parmse->expr);
- tmp = fold_convert (size_type_node, tmp);
- size = fold_build2_loc (input_location, MULT_EXPR,
- size_type_node, size, tmp);
- /* Fix the size and allocate. */
- size = gfc_evaluate_now (size, &parmse->pre);
- tmp = builtin_decl_explicit (BUILT_IN_MALLOC);
- ptr = build_call_expr_loc (input_location, tmp, 1, size);
- ptr = gfc_evaluate_now (ptr, &parmse->pre);
- /* Copy the data to the temporary descriptor. */
- tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
- tmp = build_call_expr_loc (input_location, tmp, 3, ptr,
- gfc_conv_descriptor_data_get (parmse->expr),
- size);
- gfc_add_expr_to_block (&parmse->pre, tmp);
-
- /* The temporary 'ptr' is freed below. */
- gfc_conv_descriptor_data_set (&parmse->pre, parmse->expr, ptr);
- }
-
}
else
{
parmse->expr = build_fold_indirect_ref_loc (input_location,
parmse->expr);
- /* Copy the scalar for INTENT(IN). */
- if (e->expr_type == EXPR_VARIABLE && fsym->attr.intent == INTENT_IN)
- {
- if (e->ts.type != BT_CHARACTER)
- parmse->expr = gfc_evaluate_now (parmse->expr, &parmse->pre);
- else
- {
- /* The temporary string 'ptr' is freed below. */
- tmp = build_pointer_type (TREE_TYPE (parmse->expr));
- ptr = gfc_create_var (tmp, "str");
- tmp = build_call_expr_loc (input_location,
- builtin_decl_explicit (BUILT_IN_MALLOC),
- 1, parmse->string_length);
- tmp = fold_convert (TREE_TYPE (ptr), tmp);
- gfc_add_modify (&parmse->pre, ptr, tmp);
- tmp = gfc_build_memcpy_call (ptr, parmse->expr,
- parmse->string_length);
- gfc_add_expr_to_block (&parmse->pre, tmp);
- parmse->expr = ptr;
- }
- }
-
parmse->expr = gfc_conv_scalar_to_descriptor (parmse,
parmse->expr, attr);
}
/* Variables to point to the gfc and CFI descriptors. */
gfc_desc_ptr = parmse->expr;
cfi_desc_ptr = gfc_create_var (pvoid_type_node, "cfi");
+ gfc_add_modify (&parmse->pre, cfi_desc_ptr,
+ build_int_cst (pvoid_type_node, 0));
/* Allocate the CFI descriptor and fill the fields. */
tmp = gfc_build_addr_expr (NULL_TREE, cfi_desc_ptr);
/* The CFI descriptor is passed to the bind_C procedure. */
parmse->expr = cfi_desc_ptr;
- if (ptr)
- {
- /* Free both the temporary data and the CFI descriptor for
- INTENT(IN) arrays. */
- tmp = gfc_call_free (ptr);
- gfc_prepend_expr_to_block (&parmse->post, tmp);
- tmp = gfc_call_free (cfi_desc_ptr);
- gfc_prepend_expr_to_block (&parmse->post, tmp);
- return;
- }
+ /* Free the CFI descriptor. */
+ gfc_init_block (&block);
+ cond = fold_build2_loc (input_location, NE_EXPR,
+ logical_type_node, cfi_desc_ptr,
+ build_int_cst (TREE_TYPE (cfi_desc_ptr), 0));
+ tmp = gfc_call_free (cfi_desc_ptr);
+ gfc_add_expr_to_block (&block, tmp);
+ tmp = build3_v (COND_EXPR, cond,
+ gfc_finish_block (&block),
+ build_empty_stmt (input_location));
+ gfc_prepend_expr_to_block (&parmse->post, tmp);
- /* Transfer values back to gfc descriptor and free the CFI descriptor. */
+ /* Transfer values back to gfc 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);
}
else if (sym->attr.is_bind_c && e
- && ((fsym && fsym->attr.dimension
- && (fsym->attr.pointer
- || fsym->attr.allocatable
- || fsym->as->type == AS_ASSUMED_RANK
- || fsym->as->type == AS_ASSUMED_SHAPE))
+ && (is_CFI_desc (fsym, NULL)
|| non_unity_length_string))
/* Implement F2018, C.12.6.1: paragraph (2). */
gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
}
if (sym->attr.is_bind_c && e
- && fsym && fsym->attr.dimension
- && (fsym->attr.pointer
- || fsym->attr.allocatable
- || fsym->as->type == AS_ASSUMED_RANK
- || fsym->as->type == AS_ASSUMED_SHAPE
- || non_unity_length_string))
+ && (is_CFI_desc (fsym, NULL) || non_unity_length_string))
/* Implement F2018, C.12.6.1: paragraph (2). */
gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
else
span = NULL_TREE;
}
+ else if (TREE_CODE (decl) == INDIRECT_REF
+ && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
+ span = gfc_conv_descriptor_span_get (decl);
else
span = NULL_TREE;
+2019-04-14 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/89843
+ * gfortran.dg/ISO_Fortran_binding_4.f90: Modify the value of x
+ in ctg. Test the conversion of the descriptor types in the main
+ program.
+ * gfortran.dg/ISO_Fortran_binding_10.f90: New test.
+ * gfortran.dg/ISO_Fortran_binding_10.c: Called by it.
+
+ PR fortran/89846
+ * gfortran.dg/ISO_Fortran_binding_11.f90: New test.
+ * gfortran.dg/ISO_Fortran_binding_11.c: Called by it.
+
+ PR fortran/90022
+ * gfortran.dg/ISO_Fortran_binding_1.c: Correct the indexing for
+ the computation of 'ans'. Also, change the expected results for
+ CFI_is_contiguous to comply with standard.
+ * gfortran.dg/ISO_Fortran_binding_1.f90: Correct the expected
+ results for CFI_is_contiguous to comply with standard.
+ * gfortran.dg/ISO_Fortran_binding_9.f90: New test.
+ * gfortran.dg/ISO_Fortran_binding_9.c: Called by it.
+
2019-04-13 Jakub Jelinek <jakub@redhat.com>
PR target/89093
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;
+ int ind;
float *ret_addr;
float ans = 0.0;
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]++)
+ for (idx[0] = 0; idx[0] < section.dim[0].extent; idx[0]++)
ans += *(float*)CFI_address ((CFI_cdesc_t*)§ion, idx);
return ans;
}
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]++)
+ for (idx[0] = 0; idx[0] < section.dim[0].extent; idx[0]++)
ans += *(float*)CFI_address ((CFI_cdesc_t*)§ion, idx);
return ans;
}
int assumed_size_c(CFI_cdesc_t * desc)
{
- int ierr;
+ int res;
- ierr = CFI_is_contiguous(desc);
- if (ierr)
+ res = CFI_is_contiguous(desc);
+ if (!res)
return 1;
if (desc->rank)
- ierr = 2 * (desc->dim[desc->rank-1].extent
+ res = 2 * (desc->dim[desc->rank-1].extent
!= (CFI_index_t)(long long)(-1));
else
- ierr = 3;
- return ierr;
+ res = 3;
+ return res;
}
integer, dimension (2,*) :: arg
character(4), dimension(2) :: chr
! These are contiguous
- if (c_contiguous (arg) .ne. 0) stop 20
+ if (c_contiguous (arg) .ne. 1) stop 20
if (.not.allocated (x)) allocate (x(2, 2))
- if (c_contiguous (x) .ne. 0) stop 22
+ if (c_contiguous (x) .ne. 1) stop 22
deallocate (x)
- if (c_contiguous (chr) .ne. 0) stop 23
+ if (c_contiguous (chr) .ne. 1) 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
+ if (c_contiguous (der%i) .eq. 1) stop 24
+ if (c_contiguous (arg(1:1,1:2)) .eq. 1) stop 25
+ if (c_contiguous (d(4:2:-2, 1:3:2)) .eq. 1) stop 26
+ if (c_contiguous (chr(:)(2:3)) .eq. 1) stop 27
end subroutine test_CFI_contiguous
subroutine test_CFI_section (arg)
--- /dev/null
+/* Test the fix of PR89843. */
+
+/* Contributed by Reinhold Bader <Bader@lrz.de> */
+
+#include "../../../libgfortran/ISO_Fortran_binding.h"
+#include <stdlib.h>
+#include <stdio.h>
+#include <stdbool.h>
+
+void sa(CFI_cdesc_t *, int, int *);
+
+void si(CFI_cdesc_t *this, int flag, int *status)
+{
+ int value, sum;
+ bool err;
+ CFI_CDESC_T(1) that;
+ CFI_index_t lb[] = { 0, 0 };
+ CFI_index_t ub[] = { 4, 1 };
+ CFI_index_t st[] = { 2, 0 };
+ int chksum[] = { 9, 36, 38 };
+
+ if (flag == 1)
+ {
+ lb[0] = 0; lb[1] = 2;
+ ub[0] = 2; ub[1] = 2;
+ st[0] = 1; st[1] = 0;
+ }
+ else if (flag == 2)
+ {
+ lb[0] = 1; lb[1] = 0;
+ ub[0] = 1; ub[1] = 3;
+ st[0] = 0; st[1] = 1;
+ }
+
+ CFI_establish((CFI_cdesc_t *) &that, NULL, CFI_attribute_other,
+ CFI_type_float, 0, 1, NULL);
+
+ *status = CFI_section((CFI_cdesc_t *) &that, this, lb, ub, st);
+
+ if (*status != CFI_SUCCESS)
+ {
+ printf("FAIL C: status is %i\n",status);
+ return;
+ }
+
+ value = CFI_is_contiguous((CFI_cdesc_t *) &that);
+ err = ((flag == 0 && value != 0)
+ || (flag == 1 && value != 1)
+ || (flag == 2 && value != 0));
+
+ if (err)
+ {
+ printf("FAIL C: contiguity for flag value %i - is %i\n",flag, value);
+ *status = 10;
+ return;
+ }
+
+ sum = 0;
+ for (int i = 0; i < that.dim[0].extent; i++)
+ {
+ CFI_index_t idx[] = {i};
+ sum += (int)(*(float *)CFI_address ((CFI_cdesc_t *)&that, idx));
+ }
+
+ if (sum != chksum[flag])
+ {
+ printf ("FAIL C: check sum = %d(%d)\n", sum, chksum[flag]);
+ *status = 11;
+ return;
+ }
+
+ sa((CFI_cdesc_t *) &that, flag, status);
+}
--- /dev/null
+! { dg-do run { target c99_runtime } }
+! { dg-additional-sources ISO_Fortran_binding_10.c }
+!
+! Test the fix of PR89843.
+!
+! Contributed by Reinhold Bader <Bader@lrz.de>
+!
+module mod_section_01
+ use, intrinsic :: iso_c_binding
+ implicit none
+ interface
+ subroutine si(this, flag, status) bind(c)
+ import :: c_float, c_int
+ real(c_float) :: this(:,:)
+ integer(c_int), value :: flag
+ integer(c_int) :: status
+ end subroutine si
+ end interface
+contains
+ subroutine sa(this, flag, status) bind(c)
+ real(c_float) :: this(:)
+ integer(c_int), value :: flag
+ integer(c_int) :: status
+
+ status = 0
+
+ select case (flag)
+ case (0)
+ if (is_contiguous(this)) then
+ write(*,*) 'FAIL 1:'
+ status = status + 1
+ end if
+ if (size(this,1) /= 3) then
+ write(*,*) 'FAIL 2:',size(this)
+ status = status + 1
+ goto 10
+ end if
+ if (maxval(abs(this - [ 1.0, 3.0, 5.0 ])) > 1.0e-6) then
+ write(*,*) 'FAIL 3:',abs(this)
+ status = status + 1
+ end if
+ 10 continue
+ case (1)
+ if (size(this,1) /= 3) then
+ write(*,*) 'FAIL 4:',size(this)
+ status = status + 1
+ goto 20
+ end if
+ if (maxval(abs(this - [ 11.0, 12.0, 13.0 ])) > 1.0e-6) then
+ write(*,*) 'FAIL 5:',this
+ status = status + 1
+ end if
+ 20 continue
+ case (2)
+ if (size(this,1) /= 4) then
+ write(*,*) 'FAIL 6:',size(this)
+ status = status + 1
+ goto 30
+ end if
+ if (maxval(abs(this - [ 2.0, 7.0, 12.0, 17.0 ])) > 1.0e-6) then
+ write(*,*) 'FAIL 7:',this
+ status = status + 1
+ end if
+ 30 continue
+ end select
+
+! if (status == 0) then
+! write(*,*) 'OK'
+! end if
+ end subroutine sa
+end module mod_section_01
+
+program section_01
+ use mod_section_01
+ implicit none
+ real(c_float) :: v(5,4)
+ integer :: i
+ integer :: status
+
+ v = reshape( [ (real(i), i = 1, 20) ], [ 5, 4 ] )
+ call si(v, 0, status)
+ if (status .ne. 0) stop 1
+
+ call sa(v(1:5:2, 1), 0, status)
+ if (status .ne. 0) stop 2
+
+ call si(v, 1, status)
+ if (status .ne. 0) stop 3
+
+ call sa(v(1:3, 3), 1, status)
+ if (status .ne. 0) stop 4
+
+ call si(v, 2, status)
+ if (status .ne. 0) stop 5
+
+ call sa(v(2,1:4), 2, status)
+ if (status .ne. 0) stop 6
+
+end program section_01
--- /dev/null
+/* Test the fix of PR89846.
+
+Contributed by Reinhold Bader <Bader@lrz.de>#include <stdio.h> */
+
+#include <stdlib.h>
+#include <stddef.h>
+#include <stdio.h>
+#include "../../../libgfortran/ISO_Fortran_binding.h"
+
+typedef struct
+{
+ char n;
+ float r[2];
+} t1;
+
+typedef struct
+{
+ long int i;
+ t1 t1;
+} t2;
+
+
+
+void ta0(CFI_cdesc_t *);
+void ta1(CFI_cdesc_t *);
+
+void ti(CFI_cdesc_t *this, int flag)
+{
+ int status;
+ size_t dis;
+ CFI_CDESC_T(1) that;
+ t1 *ans;
+
+ switch (flag)
+ {
+ case 0:
+ dis = offsetof(t2, t1);
+ status = CFI_establish((CFI_cdesc_t *) &that, NULL, CFI_attribute_other,
+ CFI_type_struct, sizeof(t1), 1, NULL);
+ if (status != CFI_SUCCESS)
+ {
+ printf("FAIL 1 establish: nonzero status %i\n",status);
+ exit(1);
+ }
+ status = CFI_select_part((CFI_cdesc_t *) &that, this, dis, 0);
+ if (status != CFI_SUCCESS)
+ {
+ printf("FAIL C1: nonzero status %i\n",status);
+ exit(1);
+ }
+ break;
+
+ case 1:
+ dis = offsetof(t2, i);
+ status = CFI_establish((CFI_cdesc_t *) &that, NULL, CFI_attribute_other,
+ CFI_type_long, 0, 1, NULL);
+ if (status != CFI_SUCCESS)
+ {
+ printf("FAIL 2 establish: nonzero status %i\n",status);
+ exit(1);
+ }
+ status = CFI_select_part((CFI_cdesc_t *) &that, this, dis, 0);
+ if (status != CFI_SUCCESS)
+ {
+ printf("FAIL C2: nonzero status %i\n",status);
+ exit(1);
+ }
+ }
+
+ if (CFI_is_contiguous((CFI_cdesc_t *) &that))
+ {
+ printf("FAIL C: contiguity for flag value %i - is %i\n",flag,
+ CFI_is_contiguous((CFI_cdesc_t *) &that));
+ }
+
+ if (flag == 0) ta0((CFI_cdesc_t *) &that);
+ if (flag == 1) ta1((CFI_cdesc_t *) &that);
+}
--- /dev/null
+! { dg-do run { target c99_runtime } }
+! { dg-additional-sources ISO_Fortran_binding_11.c }
+!
+! Test the fix of PR89846.
+!
+! Contributed by Reinhold Bader <Bader@lrz.de>
+!
+module mod_subobj_01
+ use, intrinsic :: iso_c_binding
+ implicit none
+ integer, parameter :: nelem = 5
+ type, bind(c) :: t1
+ character(c_char) :: n
+ real(c_float) :: r(2)
+ end type t1
+ type, bind(c) :: t2
+ integer(c_long) :: i
+ type(t1) :: t1
+ end type t2
+ interface
+ subroutine ti(this, flag) bind(c)
+ import :: t2, c_int
+ type(t2) :: this(:)
+ integer(c_int), value :: flag
+ end subroutine ti
+ end interface
+contains
+ subroutine ta0(this) bind(c)
+ type(t1) :: this(:)
+ integer :: i, iw, status
+ status = 0
+ if (size(this) /= nelem) then
+ write(*,*) 'FAIL 1: ',size(this)
+ status = status + 1
+ end if
+ iw = 0
+ do i=1, nelem
+ if (this(i)%n /= char(i,c_char) .or. this(i)%r(1) /= real(i,c_float) .or. &
+ this(i)%r(2) /= real(i+1,c_float)) then
+ iw = iw + 1
+ end if
+ end do
+ if (iw > 0) then
+ write(*,*) 'FAIL 2: ' ,this
+ status = status + 1
+ end if
+ if (status /= 0) stop 1
+ end subroutine ta0
+ subroutine ta1(this) bind(c)
+ integer(c_long) :: this(:)
+ integer :: i, status
+ status = 0
+ if (size(this) /= nelem) then
+ write(*,*) 'FAIL 3: ',size(this)
+ status = status + 1
+ end if
+ if (maxval(abs(this - [ (int(i,c_long),i=1,nelem) ])) > 0) then
+ write(*,*) 'FAIL 4: ' ,this
+ status = status + 1
+ end if
+ if (status /= 0) stop 2
+ end subroutine ta1
+end module mod_subobj_01
+program subobj_01
+ use mod_subobj_01
+ implicit none
+ integer :: i
+
+ type(t2), allocatable :: o_t2(:)
+
+ allocate(o_t2(nelem))
+ do i=1, nelem
+ o_t2(i)%t1 = t1( char(i,c_char), [ real(i,c_float), real(i+1,c_float) ] )
+ o_t2(i)%i = int(i,c_long)
+ end do
+
+ call ti(o_t2,0)
+ call ti(o_t2,1)
+
+end program subobj_01
+
integer, dimension(2,2) :: src = reshape ([1,2,3,4], [2,2])
allocate (actual, source = src)
- ier = test1 (actual)
- if (ier .ne. 0) stop 1
-! C call is INTENT(IN). 'c_test' increments elements of 'src'.
- if (any (actual .ne. src)) stop 2
- ier = test2 (actual)
+ ier = test1 (actual)
if (ier .ne. 0) stop 1
-! C call is INTENT(INOUT) 'c_test' increments elements of 'src'.
if (any (actual .ne. src + 1)) stop 2
contains
function test1 (arg) RESULT(err)
- USE, INTRINSIC :: ISO_C_BINDING
- INTEGER(C_INT) :: err
- type(*), dimension(..), intent(inOUT) :: arg
- interface
- function test_c (a) BIND(C, NAME="c_test") RESULT(err)
- USE, INTRINSIC :: ISO_C_BINDING
- type(*), dimension(..), intent(in) :: a
- INTEGER(C_INT) :: err
- end function
- end interface
-
- err = test_c (arg) ! This used to ICE
-
- end function test1
-
- function test2 (arg) RESULT(err)
USE, INTRINSIC :: ISO_C_BINDING
INTEGER(C_INT) :: err
type(*), dimension(..), intent(inout) :: arg
err = test_c (arg) ! This used to ICE
- end function test2
+ end function test1
end
if (any(abs(x - [2.,4.,6.]) > 1.e-6)) then
write(*,*) 'FAIL'
+ stop 1
else
write(*,*) 'OK'
end if
+ x = [2.,4.,6.]*10.0
end subroutine
end module
program p
x = [ (real(i), i=1, size(x)) ]
call ctg(x(2::2))
-
+ if (any (abs (x - [1.,20.,3.,40.,5.,60.]) > 1.e-6)) stop 2
end program
--- /dev/null
+/* Test fix of a problem with CFI_is_contiguous. */
+
+/* Contributed by Gilles Gouaillardet <gilles@rist.or.jp> */
+
+#include "../../../libgfortran/ISO_Fortran_binding.h"
+#include <stdlib.h>
+
+int cdesc_c(CFI_cdesc_t* x, long *expected)
+{
+ int res;
+ res = CFI_is_contiguous (x);
+ if (x->base_addr != (void *)*expected) res = 0;
+ return res;
+}
\ No newline at end of file
--- /dev/null
+! { dg-do run { target c99_runtime } }
+! { dg-additional-sources ISO_Fortran_binding_9.c }
+!
+! Fix a problem with CFI_is_contiguous
+!
+! Contributed by Gilles Gouaillardet <gilles@rist.or.jp>
+!
+module cdesc
+ interface
+ function cdesc_f08(buf, expected) result (res) BIND(C, name="cdesc_c")
+ USE, INTRINSIC :: ISO_C_BINDING
+ implicit none
+ INTEGER(C_INT) :: res
+ type(*), dimension(..), INTENT(IN) :: buf
+ integer(kind=kind(loc(res))),INTENT(IN) :: expected
+ end function cdesc_f08
+ end interface
+end module
+
+program cdesc_test
+ use cdesc
+ implicit none
+ integer :: a0, a1(10), a2(10,10), a3(10,10,10)
+ if (cdesc_f08(a0, LOC(a0)) .ne. 1) stop 1
+ if (cdesc_f08(a1, LOC(a1(1))) .ne. 1) stop 2
+ if (cdesc_f08(a2, LOC(a2(1,1))) .ne. 1) stop 3
+ if (cdesc_f08(a3, LOC(a3(1,1,1))) .ne. 1) stop 4
+end program
+2019-04-14 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/89843
+ * runtime/ISO_Fortran_binding.c (cfi_desc_to_gfc_desc): Only
+ return immediately if the source pointer is null. Bring
+ forward the extraction of the gfc type. Extract the kind so
+ that the element size can be correctly computed for sections
+ and components of derived type arrays. Remove the free of the
+ CFI descriptor since this is now done in trans-expr.c.
+ (gfc_desc_to_cfi_desc): Only allocate the CFI descriptor if it
+ is not null.
+ (CFI_section): Normalise the difference between the upper and
+ lower bounds by the stride to correctly calculate the extents
+ of the section.
+
+ PR fortran/89846
+ * runtime/ISO_Fortran_binding.c (cfi_desc_to_gfc_desc): Use
+ the stride measure for the gfc span if it is not a multiple
+ of the element length. Otherwise use the element length.
+
+ PR fortran/90022
+ * runtime/ISO_Fortran_binding.c (CFI_is_contiguous) : Return
+ 1 for true and 0 otherwise to comply with the standard. Correct
+ the contiguity check for rank 3 and greater by using the stride
+ measure of the lower dimension rather than the element length.
+
2019-03-25 John David Anglin <danglin@gcc.gnu.org>
PR libgfortran/79540
cfi_desc_to_gfc_desc (gfc_array_void *d, CFI_cdesc_t **s_ptr)
{
int n;
+ index_type kind;
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;
+ if (!s)
+ return;
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);
+ kind = (index_type)((s->type - (s->type & CFI_type_mask)) >> CFI_type_kind_shift);
/* Correct the unfortunate difference in order with types. */
if (GFC_DESCRIPTOR_TYPE (d) == BT_CHARACTER)
else if (GFC_DESCRIPTOR_TYPE (d) == BT_DERIVED)
GFC_DESCRIPTOR_TYPE (d) = BT_CHARACTER;
+ if (!s->rank || s->dim[0].sm == (CFI_index_t)s->elem_len)
+ GFC_DESCRIPTOR_SIZE (d) = s->elem_len;
+ else if (GFC_DESCRIPTOR_TYPE (d) != BT_DERIVED)
+ GFC_DESCRIPTOR_SIZE (d) = kind;
+ else
+ GFC_DESCRIPTOR_SIZE (d) = s->elem_len;
+
+ d->dtype.version = s->version;
+ GFC_DESCRIPTOR_RANK (d) = (signed char)s->rank;
+
d->dtype.attribute = (signed short)s->attribute;
if (s->rank)
- d->span = (index_type)s->dim[0].sm;
+ {
+ if ((size_t)s->dim[0].sm % s->elem_len)
+ d->span = (index_type)s->dim[0].sm;
+ else
+ d->span = (index_type)s->elem_len;
+ }
- /* On the other hand, CFI_establish can change the bounds. */
d->offset = 0;
for (n = 0; n < GFC_DESCRIPTOR_RANK (d); n++)
{
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 *);
/* 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)
+ if (*d_ptr == NULL)
+ d = malloc (sizeof (CFI_cdesc_t)
+ (CFI_type_t)(CFI_MAX_RANK * sizeof (CFI_dim_t)));
+ else
+ d = *d_ptr;
d->base_addr = GFC_DESCRIPTOR_DATA (s);
d->elem_len = GFC_DESCRIPTOR_SIZE (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. */
+ /* Full pointer or allocatable arrays retain their lower_bounds. */
for (n = 0; n < GFC_DESCRIPTOR_RANK (s); n++)
{
if (d->attribute != CFI_attribute_other)
d->dim[n].sm = (CFI_index_t)(GFC_DESCRIPTOR_STRIDE(s, n) * s->span);
}
- *d_ptr = d;
+ if (*d_ptr == NULL)
+ *d_ptr = d;
}
void *CFI_address (const CFI_cdesc_t *dv, const CFI_index_t subscripts[])
if (dv == NULL)
{
fprintf (stderr, "CFI_is_contiguous: C descriptor is NULL.\n");
- return CFI_INVALID_DESCRIPTOR;
+ return 0;
}
/* Base address must not be NULL. */
{
fprintf (stderr, "CFI_is_contiguous: Base address of C Descriptor "
"is already NULL.\n");
- return CFI_ERROR_BASE_ADDR_NULL;
+ return 0;
}
/* Must be an array. */
{
fprintf (stderr, "CFI_is_contiguous: C Descriptor must describe an "
"array (0 < dv->rank = %d).\n", dv->rank);
- return CFI_INVALID_RANK;
+ return 0;
}
}
/* Assumed size arrays are always contiguous. */
if (dv->rank > 0 && dv->dim[dv->rank - 1].extent == -1)
- return CFI_SUCCESS;
+ return 1;
/* If an array is not contiguous the memory stride is different to the element
* length. */
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].sm == (CFI_index_t)(dv->dim[i - 1].sm
* dv->dim[i - 1].extent))
continue;
- return CFI_FAILURE;
+ return 0;
}
/* Array sections are guaranteed to be contiguous by the previous test. */
- return CFI_SUCCESS;
+ return 1;
}
}
int idx = i - aux;
result->dim[idx].lower_bound = lower[i];
- result->dim[idx].extent = upper[i] - lower[i] + 1;
+ result->dim[idx].extent = 1 + (upper[i] - lower[i])/stride[i];
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;
projects / thirdparty / gcc.git / commitdiff
