* Re: [Patch, fortran] ISO_Fortran_binding PRs 90093, 90352 & 90355
2019-05-06 18:57 [Patch, fortran] ISO_Fortran_binding PRs 90093, 90352 & 90355 Paul Richard Thomas
@ 2019-05-06 18:59 ` Paul Richard Thomas
2019-05-08 18:41 ` Paul Richard Thomas
0 siblings, 1 reply; 7+ messages in thread
From: Paul Richard Thomas @ 2019-05-06 18:59 UTC (permalink / raw)
To: fortran, gcc-patches
[-- Attachment #1: Type: text/plain, Size: 2690 bytes --]
It helps to attach the patch!
On Mon, 6 May 2019 at 19:57, Paul Richard Thomas
<paul.richard.thomas@gmail.com> wrote:
>
> Unfortunately, this patch was still in the making at the release of
> 9.1. It is more or less self explanatory with the ChangeLogs.
>
> It should be noted that gfc_conv_expr_present could not be used in the
> fix for PR90093 because the passed descriptor is a CFI type. Instead,
> the test is for a null pointer passed.
>
> The changes to trans-array.c(gfc_trans_create_temp_array) have an eye
> on the future, as well as PR90355. I am progressing towards the point
> where all descriptors have 'span' set correctly so that
> trans.c(get_array_span) can be eliminated and much of the code in the
> callers can be simplified.
>
> Bootstrapped and regtested on FC29/x86_64 - OK for trunk and 9-branch?
>
> Paul
>
> 2019-05-06 Paul Thomas <pault@gcc.gnu.org>
>
> PR fortran/90093
> * trans-decl.c (convert_CFI_desc): Test that the dummy is
> present before doing any of the conversions.
>
> PR fortran/90352
> * decl.c (gfc_verify_c_interop_param): Restore the error for
> charlen > 1 actual arguments passed to bind(C) procs.
> Clean up trailing white space.
>
> PR fortran/90355
> * trans-array.c (gfc_trans_create_temp_array): Set the 'span'
> field to the element length for all types.
> (gfc_conv_expr_descriptor): The force_no_tmp flag is used to
> prevent temporary creation, especially for substrings.
> * trans-decl.c (gfc_trans_deferred_vars): Rather than assert
> that the backend decl for the string length is non-null, use it
> as a condition before calling gfc_trans_vla_type_sizes.
> * trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): 'force_no_tmp'
> is set before calling gfc_conv_expr_descriptor.
> * trans.c (get_array_span): Move the code for extracting 'span'
> from gfc_build_array_ref to this function. This is specific to
> descriptors that are component and indirect references.
> * trans.h : Add the force_no_tmp flag bitfield to gfc_se.
>
> 2019-05-06 Paul Thomas <pault@gcc.gnu.org>
>
> PR fortran/90093
> * gfortran.dg/ISO_Fortran_binding_12.f90: New test.
> * gfortran.dg/ISO_Fortran_binding_12.c: Supplementary code.
>
> PR fortran/90352
> * gfortran.dg/iso_c_binding_char_1.f90: New test.
>
> PR fortran/90355
> * gfortran.dg/ISO_Fortran_binding_4.f90: Add 'substr' to test
> the direct passing of substrings as descriptors to bind(C).
> * gfortran.dg/assign_10.f90: Increase the tree_dump count of
> 'atmp' to account for the setting of the 'span' field.
> * gfortran.dg/transpose_optimization_2.f90: Ditto.
[-- Attachment #2: submit.diff --]
[-- Type: text/x-patch, Size: 22155 bytes --]
Index: gcc/fortran/decl.c
===================================================================
*** gcc/fortran/decl.c (revision 270622)
--- gcc/fortran/decl.c (working copy)
*************** match_data_constant (gfc_expr **result)
*** 406,412 ****
contains the right constant expression. Check here. */
if ((*result)->symtree == NULL
&& (*result)->expr_type == EXPR_CONSTANT
! && ((*result)->ts.type == BT_INTEGER
|| (*result)->ts.type == BT_REAL))
return m;
--- 406,412 ----
contains the right constant expression. Check here. */
if ((*result)->symtree == NULL
&& (*result)->expr_type == EXPR_CONSTANT
! && ((*result)->ts.type == BT_INTEGER
|| (*result)->ts.type == BT_REAL))
return m;
*************** gfc_verify_c_interop_param (gfc_symbol *
*** 1493,1511 ****
/* Character strings are only C interoperable if they have a
length of 1. */
! if (sym->ts.type == BT_CHARACTER)
{
gfc_charlen *cl = sym->ts.u.cl;
if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT
|| mpz_cmp_si (cl->length->value.integer, 1) != 0)
{
! if (!gfc_notify_std (GFC_STD_F2018,
! "Character argument %qs at %L "
! "must be length 1 because "
! "procedure %qs is BIND(C)",
! sym->name, &sym->declared_at,
! sym->ns->proc_name->name))
! retval = false;
}
}
--- 1493,1510 ----
/* Character strings are only C interoperable if they have a
length of 1. */
! if (sym->ts.type == BT_CHARACTER && !sym->attr.dimension)
{
gfc_charlen *cl = sym->ts.u.cl;
if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT
|| mpz_cmp_si (cl->length->value.integer, 1) != 0)
{
! gfc_error ("Character argument %qs at %L "
! "must be length 1 because "
! "procedure %qs is BIND(C)",
! sym->name, &sym->declared_at,
! sym->ns->proc_name->name);
! retval = false;
}
}
*************** static bool
*** 6074,6080 ****
in_module_or_interface(void)
{
if (gfc_current_state () == COMP_MODULE
! || gfc_current_state () == COMP_SUBMODULE
|| gfc_current_state () == COMP_INTERFACE)
return true;
--- 6073,6079 ----
in_module_or_interface(void)
{
if (gfc_current_state () == COMP_MODULE
! || gfc_current_state () == COMP_SUBMODULE
|| gfc_current_state () == COMP_INTERFACE)
return true;
*************** in_module_or_interface(void)
*** 6085,6091 ****
gfc_state_data *p;
for (p = gfc_state_stack->previous; p ; p = p->previous)
{
! if (p->state == COMP_MODULE || p->state == COMP_SUBMODULE
|| p->state == COMP_INTERFACE)
return true;
}
--- 6084,6090 ----
gfc_state_data *p;
for (p = gfc_state_stack->previous; p ; p = p->previous)
{
! if (p->state == COMP_MODULE || p->state == COMP_SUBMODULE
|| p->state == COMP_INTERFACE)
return true;
}
*************** gfc_match_formal_arglist (gfc_symbol *pr
*** 6304,6310 ****
}
if (gfc_match_char (')') == MATCH_YES)
! {
if (typeparam)
{
gfc_error_now ("A type parameter list is required at %C");
--- 6303,6309 ----
}
if (gfc_match_char (')') == MATCH_YES)
! {
if (typeparam)
{
gfc_error_now ("A type parameter list is required at %C");
*************** gfc_match_entry (void)
*** 7489,7495 ****
if (!gfc_add_is_bind_c (&(entry->attr), entry->name,
&(entry->declared_at), 1))
return MATCH_ERROR;
!
}
if (!gfc_current_ns->parent
--- 7488,7494 ----
if (!gfc_add_is_bind_c (&(entry->attr), entry->name,
&(entry->declared_at), 1))
return MATCH_ERROR;
!
}
if (!gfc_current_ns->parent
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c (revision 270622)
--- gcc/fortran/trans-array.c (working copy)
*************** gfc_trans_create_temp_array (stmtblock_t
*** 1239,1244 ****
--- 1239,1245 ----
tree nelem;
tree cond;
tree or_expr;
+ tree elemsize;
tree class_expr = NULL_TREE;
int n, dim, tmp_dim;
int total_dim = 0;
*************** gfc_trans_create_temp_array (stmtblock_t
*** 1333,1347 ****
tmp = gfc_conv_descriptor_dtype (desc);
gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
- /* Also set the span for derived types, since they can be used in
- component references to arrays of this type. */
- if (TREE_CODE (eltype) == RECORD_TYPE)
- {
- tmp = TYPE_SIZE_UNIT (eltype);
- tmp = fold_convert (gfc_array_index_type, tmp);
- gfc_conv_descriptor_span_set (pre, desc, tmp);
- }
-
/*
Fill in the bounds and stride. This is a packed array, so:
--- 1334,1339 ----
*************** gfc_trans_create_temp_array (stmtblock_t
*** 1413,1434 ****
}
}
/* Get the size of the array. */
if (size && !callee_alloc)
{
- tree elemsize;
/* If or_expr is true, then the extent in at least one
dimension is zero and the size is set to zero. */
size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
or_expr, gfc_index_zero_node, size);
nelem = size;
- if (class_expr == NULL_TREE)
- elemsize = fold_convert (gfc_array_index_type,
- TYPE_SIZE_UNIT (gfc_get_element_type (type)));
- else
- elemsize = gfc_class_vtab_size_get (class_expr);
-
size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
size, elemsize);
}
--- 1405,1425 ----
}
}
+ if (class_expr == NULL_TREE)
+ elemsize = fold_convert (gfc_array_index_type,
+ TYPE_SIZE_UNIT (gfc_get_element_type (type)));
+ else
+ elemsize = gfc_class_vtab_size_get (class_expr);
+
/* Get the size of the array. */
if (size && !callee_alloc)
{
/* If or_expr is true, then the extent in at least one
dimension is zero and the size is set to zero. */
size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
or_expr, gfc_index_zero_node, size);
nelem = size;
size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
size, elemsize);
}
*************** gfc_trans_create_temp_array (stmtblock_t
*** 1438,1443 ****
--- 1429,1438 ----
size = NULL_TREE;
}
+ /* Set the span. */
+ tmp = fold_convert (gfc_array_index_type, elemsize);
+ gfc_conv_descriptor_span_set (pre, desc, tmp);
+
gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial,
dynamic, dealloc);
*************** gfc_conv_expr_descriptor (gfc_se *se, gf
*** 7248,7253 ****
--- 7243,7250 ----
if (se->force_tmp)
need_tmp = 1;
+ else if (se->force_no_tmp)
+ need_tmp = 0;
if (need_tmp)
full = 0;
Index: gcc/fortran/trans-decl.c
===================================================================
*** gcc/fortran/trans-decl.c (revision 270622)
--- gcc/fortran/trans-decl.c (working copy)
*************** convert_CFI_desc (gfc_wrapped_block * bl
*** 4278,4285 ****
--- 4278,4287 ----
tree CFI_desc_ptr;
tree dummy_ptr;
tree tmp;
+ tree present;
tree incoming;
tree outgoing;
+ stmtblock_t outer_block;
stmtblock_t tmpblock;
/* dummy_ptr will be the pointer to the passed array descriptor,
*************** convert_CFI_desc (gfc_wrapped_block * bl
*** 4303,4308 ****
--- 4305,4316 ----
gfc_desc_ptr = gfc_create_var (tmp, "gfc_desc_ptr");
CFI_desc_ptr = gfc_create_var (pvoid_type_node, "CFI_desc_ptr");
+ /* Fix the condition for the presence of the argument. */
+ gfc_init_block (&outer_block);
+ present = fold_build2_loc (input_location, NE_EXPR,
+ logical_type_node, dummy_ptr,
+ build_int_cst (TREE_TYPE (dummy_ptr), 0));
+
gfc_init_block (&tmpblock);
/* Pointer to the gfc descriptor. */
gfc_add_modify (&tmpblock, gfc_desc_ptr,
*************** convert_CFI_desc (gfc_wrapped_block * bl
*** 4318,4333 ****
/* 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);
--- 4326,4368 ----
/* 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));
! /* The hidden string length is not passed to bind(C) procedures so set
! it from the descriptor element length. */
! if (sym->ts.type == BT_CHARACTER
! && sym->ts.u.cl->backend_decl
! && VAR_P (sym->ts.u.cl->backend_decl))
! {
! tmp = build_fold_indirect_ref_loc (input_location, dummy_ptr);
! tmp = gfc_conv_descriptor_elem_len (tmp);
! gfc_add_modify (&tmpblock, sym->ts.u.cl->backend_decl,
! fold_convert (TREE_TYPE (sym->ts.u.cl->backend_decl),
! tmp));
! }
!
! /* Check that the argument is present before executing the above. */
! incoming = build3_v (COND_EXPR, present,
! gfc_finish_block (&tmpblock),
! build_empty_stmt (input_location));
! gfc_add_expr_to_block (&outer_block, incoming);
! incoming = gfc_finish_block (&outer_block);
!
!
/* Convert the gfc descriptor back to the CFI type before going
! out of scope, if the CFI type was present at entry. */
! gfc_init_block (&outer_block);
! gfc_init_block (&tmpblock);
!
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 = build3_v (COND_EXPR, present,
! gfc_finish_block (&tmpblock),
! build_empty_stmt (input_location));
! gfc_add_expr_to_block (&outer_block, outgoing);
! outgoing = gfc_finish_block (&outer_block);
/* Add the lot to the procedure init and finally blocks. */
gfc_add_init_cleanup (block, incoming, outgoing);
*************** gfc_trans_deferred_vars (gfc_symbol * pr
*** 4923,4931 ****
for (f = gfc_sym_get_dummy_args (proc_sym); f; f = f->next)
{
! if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
{
- gcc_assert (f->sym->ts.u.cl->backend_decl != NULL);
if (TREE_CODE (f->sym->ts.u.cl->backend_decl) == PARM_DECL)
gfc_trans_vla_type_sizes (f->sym, &tmpblock);
}
--- 4958,4966 ----
for (f = gfc_sym_get_dummy_args (proc_sym); f; f = f->next)
{
! if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER
! && f->sym->ts.u.cl->backend_decl)
{
if (TREE_CODE (f->sym->ts.u.cl->backend_decl) == PARM_DECL)
gfc_trans_vla_type_sizes (f->sym, &tmpblock);
}
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c (revision 270622)
--- gcc/fortran/trans-expr.c (working copy)
*************** gfc_conv_gfc_desc_to_cfi_desc (gfc_se *p
*** 5006,5011 ****
--- 5006,5012 ----
if (e->rank != 0)
{
+ parmse->force_no_tmp = 1;
if (fsym->attr.contiguous
&& !gfc_is_simply_contiguous (e, false, true))
gfc_conv_subref_array_arg (parmse, e, false, fsym->attr.intent,
Index: gcc/fortran/trans.c
===================================================================
*** gcc/fortran/trans.c (revision 270622)
--- gcc/fortran/trans.c (working copy)
*************** get_array_span (tree type, tree decl)
*** 290,297 ****
{
tree span;
/* Return the span for deferred character length array references. */
! if (type && TREE_CODE (type) == ARRAY_TYPE
&& TYPE_MAX_VALUE (TYPE_DOMAIN (type)) != NULL_TREE
&& (VAR_P (TYPE_MAX_VALUE (TYPE_DOMAIN (type)))
|| TREE_CODE (TYPE_MAX_VALUE (TYPE_DOMAIN (type))) == INDIRECT_REF)
--- 290,305 ----
{
tree span;
+ if (TREE_CODE (decl) == COMPONENT_REF
+ && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
+ return gfc_conv_descriptor_span_get (decl);
+ else if (TREE_CODE (decl) == INDIRECT_REF
+ && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
+ return gfc_conv_descriptor_span_get (decl);
+
/* Return the span for deferred character length array references. */
! if (TREE_CODE (decl) != INDIRECT_REF
! && type && TREE_CODE (type) == ARRAY_TYPE
&& TYPE_MAX_VALUE (TYPE_DOMAIN (type)) != NULL_TREE
&& (VAR_P (TYPE_MAX_VALUE (TYPE_DOMAIN (type)))
|| TREE_CODE (TYPE_MAX_VALUE (TYPE_DOMAIN (type))) == INDIRECT_REF)
*************** get_array_span (tree type, tree decl)
*** 307,313 ****
TYPE_SIZE_UNIT (TREE_TYPE (type))),
span);
}
! else if (type && TREE_CODE (type) == ARRAY_TYPE
&& TYPE_MAX_VALUE (TYPE_DOMAIN (type)) != NULL_TREE
&& integer_zerop (TYPE_MAX_VALUE (TYPE_DOMAIN (type))))
{
--- 315,322 ----
TYPE_SIZE_UNIT (TREE_TYPE (type))),
span);
}
! else if (TREE_CODE (decl) != INDIRECT_REF
! && type && TREE_CODE (type) == ARRAY_TYPE
&& TYPE_MAX_VALUE (TYPE_DOMAIN (type)) != NULL_TREE
&& integer_zerop (TYPE_MAX_VALUE (TYPE_DOMAIN (type))))
{
*************** gfc_build_array_ref (tree base, tree off
*** 399,410 ****
if (vptr)
span = gfc_vptr_size_get (vptr);
else if (decl)
! {
! if (TREE_CODE (decl) == COMPONENT_REF)
! span = gfc_conv_descriptor_span_get (decl);
! else
! span = get_array_span (type, decl);
! }
/* If a non-null span has been generated reference the element with
pointer arithmetic. */
--- 408,414 ----
if (vptr)
span = gfc_vptr_size_get (vptr);
else if (decl)
! span = get_array_span (type, decl);
/* If a non-null span has been generated reference the element with
pointer arithmetic. */
Index: gcc/fortran/trans.h
===================================================================
*** gcc/fortran/trans.h (revision 270622)
--- gcc/fortran/trans.h (working copy)
*************** typedef struct gfc_se
*** 91,96 ****
--- 91,99 ----
args alias. */
unsigned force_tmp:1;
+ /* If set, will pass subref descriptors without a temporary. */
+ unsigned force_no_tmp:1;
+
/* Unconditionally calculate offset for array segments and constant
arrays in gfc_conv_expr_descriptor. */
unsigned use_offset:1;
Index: gcc/testsuite/gfortran.dg/ISO_Fortran_binding_12.c
===================================================================
*** gcc/testsuite/gfortran.dg/ISO_Fortran_binding_12.c (nonexistent)
--- gcc/testsuite/gfortran.dg/ISO_Fortran_binding_12.c (working copy)
***************
*** 0 ****
--- 1,29 ----
+ /* Test the fix for PR90093. */
+
+ #include <stdio.h>
+ #include <math.h>
+ #include "../../../libgfortran/ISO_Fortran_binding.h"
+
+ /* Contributed by Reinhold Bader <Bader@lrz.de> */
+
+ void foo_opt(CFI_cdesc_t *, float *, int *, int);
+ void write_res();
+
+ float x[34];
+
+ int main() {
+ CFI_CDESC_T(1) xd;
+ CFI_index_t ext[] = {34};
+ int sz;
+
+ CFI_establish((CFI_cdesc_t *) &xd, &x, CFI_attribute_other,
+ CFI_type_float, 0, 1, ext);
+
+ foo_opt((CFI_cdesc_t *) &xd, NULL, NULL, 0);
+ sz = 12;
+ foo_opt(NULL, &x[11], &sz, 1);
+
+ write_res();
+
+ return 0;
+ }
Index: gcc/testsuite/gfortran.dg/ISO_Fortran_binding_12.f90
===================================================================
*** gcc/testsuite/gfortran.dg/ISO_Fortran_binding_12.f90 (nonexistent)
--- gcc/testsuite/gfortran.dg/ISO_Fortran_binding_12.f90 (working copy)
***************
*** 0 ****
--- 1,53 ----
+ ! { dg-do run { target c99_runtime } }
+ ! { dg-additional-sources ISO_Fortran_binding_12.c }
+ !
+ ! Test the fix for PR90093. The additional source is the main program.
+ !
+ ! Contributed by Reinhold Bader <Bader@lrz.de>
+ !
+ module mod_optional
+ use, intrinsic :: iso_c_binding
+ implicit none
+ integer :: status = 0
+
+ contains
+
+ subroutine foo_opt(this, that, sz, flag) bind(c)
+ real(c_float), optional :: this(:)
+ real(c_float), optional :: that(*)
+ integer(c_int), optional :: sz
+ integer(c_int), value :: flag
+ if (flag == 0) then
+ if (.not. present(this) .or. present(that) .or. present(sz)) then
+ write(*,*) 'FAIL 1', present(this), present(that), present(sz)
+ status = status + 1
+ end if
+ else if (flag == 1) then
+ if (present(this) .or. .not. present(that) .or. .not. present(sz)) then
+ write(*,*) 'FAIL 2', present(this), present(that), present(sz)
+ status = status + 1
+ end if
+ if (sz /= 12) then
+ write(*,*) 'FAIL 3'
+ status = status + 1
+ end if
+ else if (flag == 2) then
+ if (present(this) .or. present(that) .or. present(sz)) then
+ write(*,*) 'FAIL 4', present(this), present(that), present(sz)
+ status = status + 1
+ end if
+ end if
+ end subroutine foo_opt
+
+ subroutine write_res() BIND(C)
+ ! Add a check that the fortran missing optional is accepted by the
+ ! bind(C) procedure.
+ call foo_opt (flag = 2)
+ if (status == 0) then
+ write(*,*) 'OK'
+ else
+ stop 1
+ end if
+ end subroutine
+
+ end module mod_optional
Index: gcc/testsuite/gfortran.dg/ISO_Fortran_binding_4.f90
===================================================================
*** gcc/testsuite/gfortran.dg/ISO_Fortran_binding_4.f90 (revision 270622)
--- gcc/testsuite/gfortran.dg/ISO_Fortran_binding_4.f90 (working copy)
***************
*** 1,29 ****
! { dg-do run }
! PR fortran/89384 - this used to give a wrong results
! with contiguous.
! Test case by Reinhold Bader.
module mod_ctg
implicit none
contains
subroutine ctg(x) BIND(C)
real, contiguous :: x(:)
!
! 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
use mod_ctg
implicit none
real :: x(6)
integer :: i
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
--- 1,41 ----
! { dg-do run }
! PR fortran/89384 - this used to give a wrong results
! with contiguous.
+ ! The subroutine substr is a test to check a problem found while
+ ! debugging PR90355.
+ !
! Test case by Reinhold Bader.
+ !
module mod_ctg
implicit none
+
contains
+
subroutine ctg(x) BIND(C)
real, contiguous :: x(:)
! if (any(abs(x - [2.,4.,6.]) > 1.e-6)) stop 1
x = [2.,4.,6.]*10.0
end subroutine
+
+ subroutine substr(str) BIND(C)
+ character(*) :: str(:)
+ if (str(2) .ne. "ghi") stop 2
+ str = ['uvw','xyz']
+ end subroutine
+
end module
+
program p
use mod_ctg
implicit none
real :: x(6)
+ character(5) :: str(2) = ['abcde','fghij']
integer :: i
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 3
!
! call substr(str(:)(2:4))
! if (any (str .ne. ['auvwe','fxyzj'])) stop 4
end program
Index: gcc/testsuite/gfortran.dg/assign_10.f90
===================================================================
*** gcc/testsuite/gfortran.dg/assign_10.f90 (revision 270622)
--- gcc/testsuite/gfortran.dg/assign_10.f90 (working copy)
*************** end
*** 24,27 ****
! Note that it is the kind conversion that generates the temp.
!
! { dg-final { scan-tree-dump-times "parm" 20 "original" } }
! ! { dg-final { scan-tree-dump-times "atmp" 18 "original" } }
--- 24,27 ----
! Note that it is the kind conversion that generates the temp.
!
! { dg-final { scan-tree-dump-times "parm" 20 "original" } }
! ! { dg-final { scan-tree-dump-times "atmp" 20 "original" } }
Index: gcc/testsuite/gfortran.dg/iso_c_binding_char_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/iso_c_binding_char_1.f90 (nonexistent)
--- gcc/testsuite/gfortran.dg/iso_c_binding_char_1.f90 (working copy)
***************
*** 0 ****
--- 1,10 ----
+ ! { dg-do compile }
+ !
+ ! Test the fix for PR90352.
+ !
+ ! Contributed by Thomas Koenig <tkoenig@gcc.gnu.org>
+ !
+ subroutine bar(c,d) BIND(C)
+ character (len=*) c ! { dg-error "must be length 1" }
+ character (len=2) d ! { dg-error "must be length 1" }
+ end
Index: gcc/testsuite/gfortran.dg/transpose_optimization_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/transpose_optimization_2.f90 (revision 270622)
--- gcc/testsuite/gfortran.dg/transpose_optimization_2.f90 (working copy)
*************** end
*** 61,64 ****
! The check below for temporaries gave 14 and 33 for "parm" and "atmp".
!
! { dg-final { scan-tree-dump-times "parm" 72 "original" } }
! ! { dg-final { scan-tree-dump-times "atmp" 12 "original" } }
--- 61,64 ----
! The check below for temporaries gave 14 and 33 for "parm" and "atmp".
!
! { dg-final { scan-tree-dump-times "parm" 72 "original" } }
! ! { dg-final { scan-tree-dump-times "atmp" 13 "original" } }
^ permalink raw reply [flat|nested] 7+ messages in thread