This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
fortran/patch to PR15364: support printing of array fields in derivedtypes
- From: Victor Leikehman <lei at haifasphere dot co dot il>
- To: fortran at gcc dot gnu dot org, gcc-patches at gcc dot gnu dot org
- Date: Mon, 13 Sep 2004 16:17:14 +0300
- Subject: fortran/patch to PR15364: support printing of array fields in derivedtypes
- Organization: IBM Research Lab in Haifa, Israel
Tested for regressions on linux/ia32.
2004-09-13 Victor Leikehman <lei@il.ibm.com>
Fix to PR/15364: support printing of array fields in derived types.
* trans-io.c: (transfer_array_component) New function.
(transfer_expr) For array fields, call transfer_array_component.
--
Victor Leikehman
IBM Research Labs in Haifa, Israel
Index: trans-io.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/trans-io.c,v
retrieving revision 1.18
diff -c -p -r1.18 trans-io.c
*** trans-io.c 8 Sep 2004 14:33:03 -0000 1.18
--- trans-io.c 13 Sep 2004 12:59:42 -0000
*************** gfc_trans_dt_end (gfc_code * code)
*** 1140,1145 ****
--- 1140,1222 ----
return gfc_finish_block (&block);
}
+ static void
+ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr);
+
+ static tree
+ transfer_array_component (tree expr, gfc_component * cm)
+ {
+ tree tmp;
+ stmtblock_t body;
+ stmtblock_t block;
+ gfc_loopinfo loop;
+ int n,i;
+ gfc_ss *ss;
+ gfc_se se;
+ gfc_array_ref ar;
+
+ gfc_start_block (&block);
+ gfc_init_se (&se, NULL);
+
+ ss = gfc_get_ss ();
+ ss->type = GFC_SS_COMPONENT;
+ ss->expr = NULL;
+ ss->shape = gfc_get_shape (cm->as->rank);
+ ss->next = gfc_ss_terminator;
+ ss->data.info.dimen = cm->as->rank;
+ ss->data.info.descriptor = expr;
+ ss->data.info.data = gfc_conv_array_data (expr);
+ ss->data.info.offset = gfc_conv_array_offset (expr);
+ for (n = 0; n < cm->as->rank; n++)
+ {
+ ss->data.info.dim[n] = n;
+ ss->data.info.start[n] = gfc_conv_array_lbound (expr, n);
+ ss->data.info.stride[n] = gfc_index_one_node;
+
+ mpz_init (ss->shape[n]);
+ mpz_sub (ss->shape[n], cm->as->upper[n]->value.integer,
+ cm->as->lower[n]->value.integer);
+ mpz_add_ui (ss->shape[n], ss->shape[n], 1);
+ }
+
+ gfc_init_loopinfo (&loop);
+ gfc_add_ss_to_loop (&loop, ss);
+ gfc_conv_ss_startstride (&loop);
+ gfc_conv_loop_setup (&loop);
+ gfc_mark_ss_chain_used (ss, 1);
+ gfc_start_scalarized_body (&loop, &body);
+
+ gfc_copy_loopinfo_to_se (&se, &loop);
+ se.ss = ss;
+ se.expr = expr;
+
+ ar.type = AR_FULL;
+ ar.as = cm->as;
+ ar.dimen = cm->as->rank;
+ for (i = 0; i < cm->as->rank; i++)
+ {
+ ar.dimen_type[i] = DIMEN_RANGE;
+ ar.start[i] = ar.end[i] = ar.stride[i] = NULL;
+ }
+ gfc_conv_array_ref (&se, &ar);
+ tmp = gfc_build_addr_expr (NULL, se.expr);
+ transfer_expr (&se, &cm->ts, tmp);
+ gfc_add_block_to_block (&body, &se.pre);
+ gfc_add_block_to_block (&body, &se.post);
+
+ gfc_trans_scalarizing_loops (&loop, &body);
+
+ gfc_add_block_to_block (&block, &loop.pre);
+ gfc_add_block_to_block (&block, &loop.post);
+
+ gfc_cleanup_loop (&loop);
+
+ for (n = 0; n < cm->as->rank; n++)
+ mpz_clear (ss->shape[n]);
+ gfc_free (ss->shape);
+
+ return gfc_finish_block (&block);
+ }
/* Generate the call for a scalar transfer node. */
*************** transfer_expr (gfc_se * se, gfc_typespec
*** 1177,1183 ****
break;
case BT_CHARACTER:
! arg2 = se->string_length;
function = iocall_x_character;
break;
--- 1254,1267 ----
break;
case BT_CHARACTER:
! if (se->string_length)
! arg2 = se->string_length;
! else
! {
! tmp = gfc_build_indirect_ref (addr_expr);
! gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
! arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
! }
function = iocall_x_character;
break;
*************** transfer_expr (gfc_se * se, gfc_typespec
*** 1193,1209 ****
tmp = build3 (COMPONENT_REF, TREE_TYPE (field), expr, field,
NULL_TREE);
! if (c->ts.type == BT_CHARACTER)
! {
! gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
! se->string_length =
! TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
! }
! if (c->dimension)
! gfc_todo_error ("IO of arrays in derived types");
! if (!c->pointer)
! tmp = gfc_build_addr_expr (NULL, tmp);
! transfer_expr (se, &c->ts, tmp);
}
return;
--- 1277,1293 ----
tmp = build3 (COMPONENT_REF, TREE_TYPE (field), expr, field,
NULL_TREE);
! if (c->dimension)
! {
! tmp = transfer_array_component (tmp, c);
! gfc_add_expr_to_block (&se->pre, tmp);
! }
! else
! {
! if (!c->pointer)
! tmp = gfc_build_addr_expr (NULL, tmp);
! transfer_expr (se, &c->ts, tmp);
! }
}
return;
*************** gfc_trans_transfer (gfc_code * code)
*** 1281,1287 ****
gfc_add_expr_to_block (&block, tmp);
! return gfc_finish_block (&block);;
}
#include "gt-fortran-trans-io.h"
--- 1365,1371 ----
gfc_add_expr_to_block (&block, tmp);
! return gfc_finish_block (&block);
}
#include "gt-fortran-trans-io.h"
program main
character* 10000 :: buf1, buf2
type xyz
integer :: x, y(3), z
end type xyz
type (xyz) :: foo(4)
do i=1,ubound(foo,1)
foo(i)%x = 100*i
do j=1,3
foo(i)%y(j) = 100*i + 10*j
enddo
foo(i)%z = 100*i+40
enddo
print (buf1, '(20i4)'), foo
print (buf2, '(20i4)'), (foo(i)%x, (foo(i)%y(j), j=1,3), foo(i)%z, i=1,4)
if (buf1.ne.buf2) call abort
end program main
program main
character*1000 buf1, buf2
type :: foo_type
character(12), dimension(13) :: name = "hello world "
end type foo_type
type (foo_type) :: foo
! foo = foo_type("hello world ")
print (buf1,*), foo
print (buf2,*), (foo%name(i), i=1,13)
if (buf1.ne.buf2) call abort
end program main
program main
character *1000 buf1, buf2
type :: foo_type
integer x(3)
integer y(4)
integer z(5)
character*11 a(3)
end type foo_type
type (foo_type) :: foo(2)
foo(1)%x = 3
foo(1)%y = 4
foo(1)%z = 5
foo(1)%a = "hello world"
foo(2)%x = 30
foo(2)%y = 40
foo(2)%z = 50
foo(2)%a = "HELLO WORLD"
print (buf1,*), foo
print (buf2,*), ((foo(i)%x(j),j=1,3), (foo(i)%y(j),j=1,4), (foo(i)%z(j),j=1,5), (foo(i)%a(j),j=1,3), i=1,2)
if (buf1.ne.buf2) call abort
end program main