From a470bfccf1432454c6922014716f3e797d480026 Mon Sep 17 00:00:00 2001 From: Bernhard Reutner-Fischer Date: Sun, 24 Oct 2021 21:57:43 +0200 Subject: Fortran: make some trans-array functions static gcc/fortran/ChangeLog: * trans-array.c (gfc_trans_scalarized_loop_end): Make static. * trans-array.h (gfc_trans_scalarized_loop_end, gfc_conv_tmp_ref, gfc_conv_array_transpose): Delete declaration. --- gcc/fortran/trans-array.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gcc/fortran/trans-array.c') diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index bceb8b2..5ceb261 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -4161,7 +4161,7 @@ gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody) /* Generates the actual loop code for a scalarization loop. */ -void +static void gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n, stmtblock_t * pbody) { -- cgit v1.1 From 68d62cb20637b2faf2c2cc1716a0786b07a6a76f Mon Sep 17 00:00:00 2001 From: Mikael Morin Date: Sun, 7 Nov 2021 14:39:18 +0100 Subject: fortran: Ignore unused args in scalarization [PR97896] MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The KIND argument of the INDEX intrinsic is a compile time constant that is used at compile time only to resolve to a kind-specific library function. That argument is otherwise completely ignored at runtime, and there is no code generated for it as the library procedure has no kind argument. This confuses the scalarizer which expects to see every argument of elemental functions used when calling a procedure. This change removes the argument from the scalarization lists at the beginning of the scalarization process, so that the argument is completely ignored. This also reverts the existing workaround (commit d09847357b965a2c2cda063827ce362d4c9c86f2 except for its testcase). PR fortran/97896 gcc/fortran/ChangeLog: * intrinsic.c (add_sym_4ind): Remove. (add_functions): Use add_sym4 instead of add_sym4ind. Don’t special case the index intrinsic. * iresolve.c (gfc_resolve_index_func): Use the individual arguments directly instead of the full argument list. * intrinsic.h (gfc_resolve_index_func): Update the declaration accordingly. * trans-decl.c (gfc_get_extern_function_decl): Don’t modify the list of arguments in the case of the index intrinsic. * trans-array.h (gfc_get_intrinsic_for_expr, gfc_get_proc_ifc_for_expr): New. * trans-array.c (gfc_get_intrinsic_for_expr, arg_evaluated_for_scalarization): New. (gfc_walk_elemental_function_args): Add intrinsic procedure as argument. Count arguments. Check arg_evaluated_for_scalarization. * trans-intrinsic.c (gfc_walk_intrinsic_function): Update call. * trans-stmt.c (get_intrinsic_for_code): New. (gfc_trans_call): Update call. gcc/testsuite/ChangeLog: * gfortran.dg/index_5.f90: New. --- gcc/fortran/trans-array.c | 61 ++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 60 insertions(+), 1 deletion(-) (limited to 'gcc/fortran/trans-array.c') diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 5ceb261..7932185 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -11460,6 +11460,59 @@ gfc_get_proc_ifc_for_expr (gfc_expr *procedure_ref) } +/* Given an expression referring to an intrinsic function call, + return the intrinsic symbol. */ + +gfc_intrinsic_sym * +gfc_get_intrinsic_for_expr (gfc_expr *call) +{ + if (call == NULL) + return NULL; + + /* Normal procedure case. */ + if (call->expr_type == EXPR_FUNCTION) + return call->value.function.isym; + else + return NULL; +} + + +/* Indicates whether an argument to an intrinsic function should be used in + scalarization. It is usually the case, except for some intrinsics + requiring the value to be constant, and using the value at compile time only. + As the value is not used at runtime in those cases, we don’t produce code + for it, and it should not be visible to the scalarizer. + FUNCTION is the intrinsic function being called, ACTUAL_ARG is the actual + argument being examined in that call, and ARG_NUM the index number + of ACTUAL_ARG in the list of arguments. + The intrinsic procedure’s dummy argument associated with ACTUAL_ARG is + identified using the name in ACTUAL_ARG if it is present (that is: if it’s + a keyword argument), otherwise using ARG_NUM. */ + +static bool +arg_evaluated_for_scalarization (gfc_intrinsic_sym *function, + gfc_actual_arglist &actual_arg, int arg_num) +{ + if (function != NULL) + { + switch (function->id) + { + case GFC_ISYM_INDEX: + if ((actual_arg.name == NULL && arg_num == 3) + || (actual_arg.name != NULL + && strcmp ("kind", actual_arg.name) == 0)) + return false; + /* Fallthrough. */ + + default: + break; + } + } + + return true; +} + + /* Walk the arguments of an elemental function. PROC_EXPR is used to check whether an argument is permitted to be absent. If it is NULL, we don't do the check and the argument is assumed to be present. @@ -11467,6 +11520,7 @@ gfc_get_proc_ifc_for_expr (gfc_expr *procedure_ref) gfc_ss * gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg, + gfc_intrinsic_sym *intrinsic_sym, gfc_symbol *proc_ifc, gfc_ss_type type) { gfc_formal_arglist *dummy_arg; @@ -11483,10 +11537,13 @@ gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg, else dummy_arg = NULL; + int arg_num = 0; scalar = 1; for (; arg; arg = arg->next) { - if (!arg->expr || arg->expr->expr_type == EXPR_NULL) + if (!arg->expr + || arg->expr->expr_type == EXPR_NULL + || !arg_evaluated_for_scalarization (intrinsic_sym, *arg, arg_num)) goto loop_continue; newss = gfc_walk_subexpr (head, arg->expr); @@ -11519,6 +11576,7 @@ gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg, } loop_continue: + arg_num++; if (dummy_arg != NULL) dummy_arg = dummy_arg->next; } @@ -11579,6 +11637,7 @@ gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr) ss = gfc_walk_elemental_function_args (old_ss, expr->value.function.actual, + gfc_get_intrinsic_for_expr (expr), gfc_get_proc_ifc_for_expr (expr), GFC_SS_REFERENCE); if (ss != old_ss -- cgit v1.1 From 5d9d16db96f2fcb47a00a7ce7e2d0e51400b47ab Mon Sep 17 00:00:00 2001 From: Mikael Morin Date: Sun, 7 Nov 2021 14:40:11 +0100 Subject: fortran: simplify elemental arguments walking This adds two functions working with the wrapper struct gfc_dummy_arg and makes usage of them to simplify a bit the walking of elemental procedure arguments for scalarization. As information about dummy arguments can be obtained from the actual argument through the just-introduced associated_dummy field, there is no need to carry around the procedure interface and walk dummy arguments manually together with actual arguments. gcc/fortran/ChangeLog: * interface.c (gfc_dummy_arg_get_typespec, gfc_dummy_arg_is_optional): New functions. * gfortran.h (gfc_dummy_arg_get_typespec, gfc_dummy_arg_is_optional): Declare them. * trans.h (gfc_ss_info::dummy_arg): Use the wrapper type as declaration type. * trans-array.c (gfc_scalar_elemental_arg_saved_as_reference): use gfc_dummy_arg_get_typespec function to get the type. (gfc_walk_elemental_function_args): Remove proc_ifc argument. Get info about the dummy arg using the associated_dummy field. * trans-array.h (gfc_walk_elemental_function_args): Update declaration. * trans-intrinsic.c (gfc_walk_intrinsic_function): Update call to gfc_walk_elemental_function_args. * trans-stmt.c (gfc_trans_call): Ditto. (get_proc_ifc_for_call): Remove. --- gcc/fortran/trans-array.c | 19 ++++++------------- 1 file changed, 6 insertions(+), 13 deletions(-) (limited to 'gcc/fortran/trans-array.c') diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 7932185..d37c1e7 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -3010,7 +3010,8 @@ gfc_scalar_elemental_arg_saved_as_reference (gfc_ss_info * ss_info) /* If the expression is of polymorphic type, it's actual size is not known, so we avoid copying it anywhere. */ if (ss_info->data.scalar.dummy_arg - && ss_info->data.scalar.dummy_arg->ts.type == BT_CLASS + && gfc_dummy_arg_get_typespec (*ss_info->data.scalar.dummy_arg).type + == BT_CLASS && ss_info->expr->ts.type == BT_CLASS) return true; @@ -11521,9 +11522,8 @@ arg_evaluated_for_scalarization (gfc_intrinsic_sym *function, gfc_ss * gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg, gfc_intrinsic_sym *intrinsic_sym, - gfc_symbol *proc_ifc, gfc_ss_type type) + gfc_ss_type type) { - gfc_formal_arglist *dummy_arg; int scalar; gfc_ss *head; gfc_ss *tail; @@ -11532,15 +11532,11 @@ gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg, head = gfc_ss_terminator; tail = NULL; - if (proc_ifc) - dummy_arg = gfc_sym_get_dummy_args (proc_ifc); - else - dummy_arg = NULL; - int arg_num = 0; scalar = 1; for (; arg; arg = arg->next) { + gfc_dummy_arg * const dummy_arg = arg->associated_dummy; if (!arg->expr || arg->expr->expr_type == EXPR_NULL || !arg_evaluated_for_scalarization (intrinsic_sym, *arg, arg_num)) @@ -11554,13 +11550,13 @@ gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg, newss = gfc_get_scalar_ss (head, arg->expr); newss->info->type = type; if (dummy_arg) - newss->info->data.scalar.dummy_arg = dummy_arg->sym; + newss->info->data.scalar.dummy_arg = dummy_arg; } else scalar = 0; if (dummy_arg != NULL - && dummy_arg->sym->attr.optional + && gfc_dummy_arg_is_optional (*dummy_arg) && arg->expr->expr_type == EXPR_VARIABLE && (gfc_expr_attr (arg->expr).optional || gfc_expr_attr (arg->expr).allocatable @@ -11577,8 +11573,6 @@ gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg, loop_continue: arg_num++; - if (dummy_arg != NULL) - dummy_arg = dummy_arg->next; } if (scalar) @@ -11638,7 +11632,6 @@ gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr) ss = gfc_walk_elemental_function_args (old_ss, expr->value.function.actual, gfc_get_intrinsic_for_expr (expr), - gfc_get_proc_ifc_for_expr (expr), GFC_SS_REFERENCE); if (ss != old_ss && (comp -- cgit v1.1 From 48a8c5be5b98240d664672a2b7b7d26f3c36cf84 Mon Sep 17 00:00:00 2001 From: Mikael Morin Date: Sun, 7 Nov 2021 14:40:36 +0100 Subject: fortran: Identify arguments by their names MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This provides a new function to get the name of a dummy argument, so that identifying an argument can be made using just its name instead of a mix of name matching (for keyword actual arguments) and argument counting (for other actual arguments). gcc/fortran/ChangeLog: * interface.c (gfc_dummy_arg_get_name): New function. * gfortran.h (gfc_dummy_arg_get_name): Declare it. * trans-array.c (arg_evaluated_for_scalarization): Pass a dummy argument wrapper as argument instead of an actual argument and an index number. Check it’s non-NULL. Use its name to identify it. (gfc_walk_elemental_function_args): Update call to arg_evaluated for scalarization. Remove argument counting. --- gcc/fortran/trans-array.c | 16 +++++----------- 1 file changed, 5 insertions(+), 11 deletions(-) (limited to 'gcc/fortran/trans-array.c') diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index d37c1e7..2090adf 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -11492,16 +11492,14 @@ gfc_get_intrinsic_for_expr (gfc_expr *call) static bool arg_evaluated_for_scalarization (gfc_intrinsic_sym *function, - gfc_actual_arglist &actual_arg, int arg_num) + gfc_dummy_arg *dummy_arg) { - if (function != NULL) + if (function != NULL && dummy_arg != NULL) { switch (function->id) { case GFC_ISYM_INDEX: - if ((actual_arg.name == NULL && arg_num == 3) - || (actual_arg.name != NULL - && strcmp ("kind", actual_arg.name) == 0)) + if (strcmp ("kind", gfc_dummy_arg_get_name (*dummy_arg)) == 0) return false; /* Fallthrough. */ @@ -11532,15 +11530,14 @@ gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg, head = gfc_ss_terminator; tail = NULL; - int arg_num = 0; scalar = 1; for (; arg; arg = arg->next) { gfc_dummy_arg * const dummy_arg = arg->associated_dummy; if (!arg->expr || arg->expr->expr_type == EXPR_NULL - || !arg_evaluated_for_scalarization (intrinsic_sym, *arg, arg_num)) - goto loop_continue; + || !arg_evaluated_for_scalarization (intrinsic_sym, dummy_arg)) + continue; newss = gfc_walk_subexpr (head, arg->expr); if (newss == head) @@ -11570,9 +11567,6 @@ gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg, while (tail->next != gfc_ss_terminator) tail = tail->next; } - -loop_continue: - arg_num++; } if (scalar) -- cgit v1.1 From 721d8b9e26bf8205c1f2125c2626919a408cdbe4 Mon Sep 17 00:00:00 2001 From: Harald Anlauf Date: Tue, 23 Nov 2021 17:51:38 +0100 Subject: Fortran: fix scalarization for intrinsic LEN_TRIM with present KIND argument gcc/fortran/ChangeLog: PR fortran/87711 PR fortran/87851 * trans-array.c (arg_evaluated_for_scalarization): Add LEN_TRIM to list of intrinsics for which an optional KIND argument needs to be removed before scalarization. gcc/testsuite/ChangeLog: PR fortran/87711 PR fortran/87851 * gfortran.dg/len_trim.f90: New test. --- gcc/fortran/trans-array.c | 1 + 1 file changed, 1 insertion(+) (limited to 'gcc/fortran/trans-array.c') diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 2090adf..238b1b7 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -11499,6 +11499,7 @@ arg_evaluated_for_scalarization (gfc_intrinsic_sym *function, switch (function->id) { case GFC_ISYM_INDEX: + case GFC_ISYM_LEN_TRIM: if (strcmp ("kind", gfc_dummy_arg_get_name (*dummy_arg)) == 0) return false; /* Fallthrough. */ -- cgit v1.1 From 7adcbafe45f8001b698967defe682687b52c0007 Mon Sep 17 00:00:00 2001 From: Jakub Jelinek Date: Mon, 3 Jan 2022 10:42:10 +0100 Subject: Update copyright years. --- gcc/fortran/trans-array.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gcc/fortran/trans-array.c') diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 238b1b7..29d0873 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -1,5 +1,5 @@ /* Array translation routines - Copyright (C) 2002-2021 Free Software Foundation, Inc. + Copyright (C) 2002-2022 Free Software Foundation, Inc. Contributed by Paul Brook and Steven Bosscher -- cgit v1.1 From c1c17a43e172ebc28f2cd247f6e83c5fdbc6219f Mon Sep 17 00:00:00 2001 From: Mikael Morin Date: Fri, 7 Jan 2022 22:34:59 +0100 Subject: Fortran: Ignore KIND argument of a few more intrinsics. [PR103789] After PR97896 for which some code was added to ignore the KIND argument of the INDEX intrinsics, and PR87711 for which that was extended to LEN_TRIM as well, this propagates it further to MASKL, MASKR, SCAN and VERIFY. PR fortran/103789 gcc/fortran/ChangeLog: * trans-array.c (arg_evaluated_for_scalarization): Add MASKL, MASKR, SCAN and VERIFY to the list of intrinsics whose KIND argument is to be ignored. gcc/testsuite/ChangeLog: * gfortran.dg/maskl_1.f90: New test. * gfortran.dg/maskr_1.f90: New test. * gfortran.dg/scan_3.f90: New test. * gfortran.dg/verify_3.f90: New test. --- gcc/fortran/trans-array.c | 4 ++++ 1 file changed, 4 insertions(+) (limited to 'gcc/fortran/trans-array.c') diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 29d0873..a77f331 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -11500,6 +11500,10 @@ arg_evaluated_for_scalarization (gfc_intrinsic_sym *function, { case GFC_ISYM_INDEX: case GFC_ISYM_LEN_TRIM: + case GFC_ISYM_MASKL: + case GFC_ISYM_MASKR: + case GFC_ISYM_SCAN: + case GFC_ISYM_VERIFY: if (strcmp ("kind", gfc_dummy_arg_get_name (*dummy_arg)) == 0) return false; /* Fallthrough. */ -- cgit v1.1 From 5c69acb32329d49e58c26fa41ae74229a52b9106 Mon Sep 17 00:00:00 2001 From: Martin Liska Date: Fri, 14 Jan 2022 16:56:44 +0100 Subject: Rename .c files to .cc files. gcc/ada/ChangeLog: * adadecode.c: Moved to... * adadecode.cc: ...here. * affinity.c: Moved to... * affinity.cc: ...here. * argv-lynxos178-raven-cert.c: Moved to... * argv-lynxos178-raven-cert.cc: ...here. * argv.c: Moved to... * argv.cc: ...here. * aux-io.c: Moved to... * aux-io.cc: ...here. * cio.c: Moved to... * cio.cc: ...here. * cstreams.c: Moved to... * cstreams.cc: ...here. * env.c: Moved to... * env.cc: ...here. * exit.c: Moved to... * exit.cc: ...here. * expect.c: Moved to... * expect.cc: ...here. * final.c: Moved to... * final.cc: ...here. * gcc-interface/cuintp.c: Moved to... * gcc-interface/cuintp.cc: ...here. * gcc-interface/decl.c: Moved to... * gcc-interface/decl.cc: ...here. * gcc-interface/misc.c: Moved to... * gcc-interface/misc.cc: ...here. * gcc-interface/targtyps.c: Moved to... * gcc-interface/targtyps.cc: ...here. * gcc-interface/trans.c: Moved to... * gcc-interface/trans.cc: ...here. * gcc-interface/utils.c: Moved to... * gcc-interface/utils.cc: ...here. * gcc-interface/utils2.c: Moved to... * gcc-interface/utils2.cc: ...here. * init.c: Moved to... * init.cc: ...here. * initialize.c: Moved to... * initialize.cc: ...here. * libgnarl/thread.c: Moved to... * libgnarl/thread.cc: ...here. * link.c: Moved to... * link.cc: ...here. * locales.c: Moved to... * locales.cc: ...here. * mkdir.c: Moved to... * mkdir.cc: ...here. * raise.c: Moved to... * raise.cc: ...here. * rtfinal.c: Moved to... * rtfinal.cc: ...here. * rtinit.c: Moved to... * rtinit.cc: ...here. * seh_init.c: Moved to... * seh_init.cc: ...here. * sigtramp-armdroid.c: Moved to... * sigtramp-armdroid.cc: ...here. * sigtramp-ios.c: Moved to... * sigtramp-ios.cc: ...here. * sigtramp-qnx.c: Moved to... * sigtramp-qnx.cc: ...here. * sigtramp-vxworks.c: Moved to... * sigtramp-vxworks.cc: ...here. * socket.c: Moved to... * socket.cc: ...here. * tracebak.c: Moved to... * tracebak.cc: ...here. * version.c: Moved to... * version.cc: ...here. * vx_stack_info.c: Moved to... * vx_stack_info.cc: ...here. gcc/ChangeLog: * adjust-alignment.c: Moved to... * adjust-alignment.cc: ...here. * alias.c: Moved to... * alias.cc: ...here. * alloc-pool.c: Moved to... * alloc-pool.cc: ...here. * asan.c: Moved to... * asan.cc: ...here. * attribs.c: Moved to... * attribs.cc: ...here. * auto-inc-dec.c: Moved to... * auto-inc-dec.cc: ...here. * auto-profile.c: Moved to... * auto-profile.cc: ...here. * bb-reorder.c: Moved to... * bb-reorder.cc: ...here. * bitmap.c: Moved to... * bitmap.cc: ...here. * btfout.c: Moved to... * btfout.cc: ...here. * builtins.c: Moved to... * builtins.cc: ...here. * caller-save.c: Moved to... * caller-save.cc: ...here. * calls.c: Moved to... * calls.cc: ...here. * ccmp.c: Moved to... * ccmp.cc: ...here. * cfg.c: Moved to... * cfg.cc: ...here. * cfganal.c: Moved to... * cfganal.cc: ...here. * cfgbuild.c: Moved to... * cfgbuild.cc: ...here. * cfgcleanup.c: Moved to... * cfgcleanup.cc: ...here. * cfgexpand.c: Moved to... * cfgexpand.cc: ...here. * cfghooks.c: Moved to... * cfghooks.cc: ...here. * cfgloop.c: Moved to... * cfgloop.cc: ...here. * cfgloopanal.c: Moved to... * cfgloopanal.cc: ...here. * cfgloopmanip.c: Moved to... * cfgloopmanip.cc: ...here. * cfgrtl.c: Moved to... * cfgrtl.cc: ...here. * cgraph.c: Moved to... * cgraph.cc: ...here. * cgraphbuild.c: Moved to... * cgraphbuild.cc: ...here. * cgraphclones.c: Moved to... * cgraphclones.cc: ...here. * cgraphunit.c: Moved to... * cgraphunit.cc: ...here. * collect-utils.c: Moved to... * collect-utils.cc: ...here. * collect2-aix.c: Moved to... * collect2-aix.cc: ...here. * collect2.c: Moved to... * collect2.cc: ...here. * combine-stack-adj.c: Moved to... * combine-stack-adj.cc: ...here. * combine.c: Moved to... * combine.cc: ...here. * common/common-targhooks.c: Moved to... * common/common-targhooks.cc: ...here. * common/config/aarch64/aarch64-common.c: Moved to... * common/config/aarch64/aarch64-common.cc: ...here. * common/config/alpha/alpha-common.c: Moved to... * common/config/alpha/alpha-common.cc: ...here. * common/config/arc/arc-common.c: Moved to... * common/config/arc/arc-common.cc: ...here. * common/config/arm/arm-common.c: Moved to... * common/config/arm/arm-common.cc: ...here. * common/config/avr/avr-common.c: Moved to... * common/config/avr/avr-common.cc: ...here. * common/config/bfin/bfin-common.c: Moved to... * common/config/bfin/bfin-common.cc: ...here. * common/config/bpf/bpf-common.c: Moved to... * common/config/bpf/bpf-common.cc: ...here. * common/config/c6x/c6x-common.c: Moved to... * common/config/c6x/c6x-common.cc: ...here. * common/config/cr16/cr16-common.c: Moved to... * common/config/cr16/cr16-common.cc: ...here. * common/config/cris/cris-common.c: Moved to... * common/config/cris/cris-common.cc: ...here. * common/config/csky/csky-common.c: Moved to... * common/config/csky/csky-common.cc: ...here. * common/config/default-common.c: Moved to... * common/config/default-common.cc: ...here. * common/config/epiphany/epiphany-common.c: Moved to... * common/config/epiphany/epiphany-common.cc: ...here. * common/config/fr30/fr30-common.c: Moved to... * common/config/fr30/fr30-common.cc: ...here. * common/config/frv/frv-common.c: Moved to... * common/config/frv/frv-common.cc: ...here. * common/config/gcn/gcn-common.c: Moved to... * common/config/gcn/gcn-common.cc: ...here. * common/config/h8300/h8300-common.c: Moved to... * common/config/h8300/h8300-common.cc: ...here. * common/config/i386/i386-common.c: Moved to... * common/config/i386/i386-common.cc: ...here. * common/config/ia64/ia64-common.c: Moved to... * common/config/ia64/ia64-common.cc: ...here. * common/config/iq2000/iq2000-common.c: Moved to... * common/config/iq2000/iq2000-common.cc: ...here. * common/config/lm32/lm32-common.c: Moved to... * common/config/lm32/lm32-common.cc: ...here. * common/config/m32r/m32r-common.c: Moved to... * common/config/m32r/m32r-common.cc: ...here. * common/config/m68k/m68k-common.c: Moved to... * common/config/m68k/m68k-common.cc: ...here. * common/config/mcore/mcore-common.c: Moved to... * common/config/mcore/mcore-common.cc: ...here. * common/config/microblaze/microblaze-common.c: Moved to... * common/config/microblaze/microblaze-common.cc: ...here. * common/config/mips/mips-common.c: Moved to... * common/config/mips/mips-common.cc: ...here. * common/config/mmix/mmix-common.c: Moved to... * common/config/mmix/mmix-common.cc: ...here. * common/config/mn10300/mn10300-common.c: Moved to... * common/config/mn10300/mn10300-common.cc: ...here. * common/config/msp430/msp430-common.c: Moved to... * common/config/msp430/msp430-common.cc: ...here. * common/config/nds32/nds32-common.c: Moved to... * common/config/nds32/nds32-common.cc: ...here. * common/config/nios2/nios2-common.c: Moved to... * common/config/nios2/nios2-common.cc: ...here. * common/config/nvptx/nvptx-common.c: Moved to... * common/config/nvptx/nvptx-common.cc: ...here. * common/config/or1k/or1k-common.c: Moved to... * common/config/or1k/or1k-common.cc: ...here. * common/config/pa/pa-common.c: Moved to... * common/config/pa/pa-common.cc: ...here. * common/config/pdp11/pdp11-common.c: Moved to... * common/config/pdp11/pdp11-common.cc: ...here. * common/config/pru/pru-common.c: Moved to... * common/config/pru/pru-common.cc: ...here. * common/config/riscv/riscv-common.c: Moved to... * common/config/riscv/riscv-common.cc: ...here. * common/config/rs6000/rs6000-common.c: Moved to... * common/config/rs6000/rs6000-common.cc: ...here. * common/config/rx/rx-common.c: Moved to... * common/config/rx/rx-common.cc: ...here. * common/config/s390/s390-common.c: Moved to... * common/config/s390/s390-common.cc: ...here. * common/config/sh/sh-common.c: Moved to... * common/config/sh/sh-common.cc: ...here. * common/config/sparc/sparc-common.c: Moved to... * common/config/sparc/sparc-common.cc: ...here. * common/config/tilegx/tilegx-common.c: Moved to... * common/config/tilegx/tilegx-common.cc: ...here. * common/config/tilepro/tilepro-common.c: Moved to... * common/config/tilepro/tilepro-common.cc: ...here. * common/config/v850/v850-common.c: Moved to... * common/config/v850/v850-common.cc: ...here. * common/config/vax/vax-common.c: Moved to... * common/config/vax/vax-common.cc: ...here. * common/config/visium/visium-common.c: Moved to... * common/config/visium/visium-common.cc: ...here. * common/config/xstormy16/xstormy16-common.c: Moved to... * common/config/xstormy16/xstormy16-common.cc: ...here. * common/config/xtensa/xtensa-common.c: Moved to... * common/config/xtensa/xtensa-common.cc: ...here. * compare-elim.c: Moved to... * compare-elim.cc: ...here. * config/aarch64/aarch64-bti-insert.c: Moved to... * config/aarch64/aarch64-bti-insert.cc: ...here. * config/aarch64/aarch64-builtins.c: Moved to... * config/aarch64/aarch64-builtins.cc: ...here. * config/aarch64/aarch64-c.c: Moved to... * config/aarch64/aarch64-c.cc: ...here. * config/aarch64/aarch64-d.c: Moved to... * config/aarch64/aarch64-d.cc: ...here. * config/aarch64/aarch64.c: Moved to... * config/aarch64/aarch64.cc: ...here. * config/aarch64/cortex-a57-fma-steering.c: Moved to... * config/aarch64/cortex-a57-fma-steering.cc: ...here. * config/aarch64/driver-aarch64.c: Moved to... * config/aarch64/driver-aarch64.cc: ...here. * config/aarch64/falkor-tag-collision-avoidance.c: Moved to... * config/aarch64/falkor-tag-collision-avoidance.cc: ...here. * config/aarch64/host-aarch64-darwin.c: Moved to... * config/aarch64/host-aarch64-darwin.cc: ...here. * config/alpha/alpha.c: Moved to... * config/alpha/alpha.cc: ...here. * config/alpha/driver-alpha.c: Moved to... * config/alpha/driver-alpha.cc: ...here. * config/arc/arc-c.c: Moved to... * config/arc/arc-c.cc: ...here. * config/arc/arc.c: Moved to... * config/arc/arc.cc: ...here. * config/arc/driver-arc.c: Moved to... * config/arc/driver-arc.cc: ...here. * config/arm/aarch-common.c: Moved to... * config/arm/aarch-common.cc: ...here. * config/arm/arm-builtins.c: Moved to... * config/arm/arm-builtins.cc: ...here. * config/arm/arm-c.c: Moved to... * config/arm/arm-c.cc: ...here. * config/arm/arm-d.c: Moved to... * config/arm/arm-d.cc: ...here. * config/arm/arm.c: Moved to... * config/arm/arm.cc: ...here. * config/arm/driver-arm.c: Moved to... * config/arm/driver-arm.cc: ...here. * config/avr/avr-c.c: Moved to... * config/avr/avr-c.cc: ...here. * config/avr/avr-devices.c: Moved to... * config/avr/avr-devices.cc: ...here. * config/avr/avr-log.c: Moved to... * config/avr/avr-log.cc: ...here. * config/avr/avr.c: Moved to... * config/avr/avr.cc: ...here. * config/avr/driver-avr.c: Moved to... * config/avr/driver-avr.cc: ...here. * config/avr/gen-avr-mmcu-specs.c: Moved to... * config/avr/gen-avr-mmcu-specs.cc: ...here. * config/avr/gen-avr-mmcu-texi.c: Moved to... * config/avr/gen-avr-mmcu-texi.cc: ...here. * config/bfin/bfin.c: Moved to... * config/bfin/bfin.cc: ...here. * config/bpf/bpf.c: Moved to... * config/bpf/bpf.cc: ...here. * config/bpf/coreout.c: Moved to... * config/bpf/coreout.cc: ...here. * config/c6x/c6x.c: Moved to... * config/c6x/c6x.cc: ...here. * config/cr16/cr16.c: Moved to... * config/cr16/cr16.cc: ...here. * config/cris/cris.c: Moved to... * config/cris/cris.cc: ...here. * config/csky/csky.c: Moved to... * config/csky/csky.cc: ...here. * config/darwin-c.c: Moved to... * config/darwin-c.cc: ...here. * config/darwin-d.c: Moved to... * config/darwin-d.cc: ...here. * config/darwin-driver.c: Moved to... * config/darwin-driver.cc: ...here. * config/darwin-f.c: Moved to... * config/darwin-f.cc: ...here. * config/darwin.c: Moved to... * config/darwin.cc: ...here. * config/default-c.c: Moved to... * config/default-c.cc: ...here. * config/default-d.c: Moved to... * config/default-d.cc: ...here. * config/dragonfly-d.c: Moved to... * config/dragonfly-d.cc: ...here. * config/epiphany/epiphany.c: Moved to... * config/epiphany/epiphany.cc: ...here. * config/epiphany/mode-switch-use.c: Moved to... * config/epiphany/mode-switch-use.cc: ...here. * config/epiphany/resolve-sw-modes.c: Moved to... * config/epiphany/resolve-sw-modes.cc: ...here. * config/fr30/fr30.c: Moved to... * config/fr30/fr30.cc: ...here. * config/freebsd-d.c: Moved to... * config/freebsd-d.cc: ...here. * config/frv/frv.c: Moved to... * config/frv/frv.cc: ...here. * config/ft32/ft32.c: Moved to... * config/ft32/ft32.cc: ...here. * config/gcn/driver-gcn.c: Moved to... * config/gcn/driver-gcn.cc: ...here. * config/gcn/gcn-run.c: Moved to... * config/gcn/gcn-run.cc: ...here. * config/gcn/gcn-tree.c: Moved to... * config/gcn/gcn-tree.cc: ...here. * config/gcn/gcn.c: Moved to... * config/gcn/gcn.cc: ...here. * config/gcn/mkoffload.c: Moved to... * config/gcn/mkoffload.cc: ...here. * config/glibc-c.c: Moved to... * config/glibc-c.cc: ...here. * config/glibc-d.c: Moved to... * config/glibc-d.cc: ...here. * config/h8300/h8300.c: Moved to... * config/h8300/h8300.cc: ...here. * config/host-darwin.c: Moved to... * config/host-darwin.cc: ...here. * config/host-hpux.c: Moved to... * config/host-hpux.cc: ...here. * config/host-linux.c: Moved to... * config/host-linux.cc: ...here. * config/host-netbsd.c: Moved to... * config/host-netbsd.cc: ...here. * config/host-openbsd.c: Moved to... * config/host-openbsd.cc: ...here. * config/host-solaris.c: Moved to... * config/host-solaris.cc: ...here. * config/i386/djgpp.c: Moved to... * config/i386/djgpp.cc: ...here. * config/i386/driver-i386.c: Moved to... * config/i386/driver-i386.cc: ...here. * config/i386/driver-mingw32.c: Moved to... * config/i386/driver-mingw32.cc: ...here. * config/i386/gnu-property.c: Moved to... * config/i386/gnu-property.cc: ...here. * config/i386/host-cygwin.c: Moved to... * config/i386/host-cygwin.cc: ...here. * config/i386/host-i386-darwin.c: Moved to... * config/i386/host-i386-darwin.cc: ...here. * config/i386/host-mingw32.c: Moved to... * config/i386/host-mingw32.cc: ...here. * config/i386/i386-builtins.c: Moved to... * config/i386/i386-builtins.cc: ...here. * config/i386/i386-c.c: Moved to... * config/i386/i386-c.cc: ...here. * config/i386/i386-d.c: Moved to... * config/i386/i386-d.cc: ...here. * config/i386/i386-expand.c: Moved to... * config/i386/i386-expand.cc: ...here. * config/i386/i386-features.c: Moved to... * config/i386/i386-features.cc: ...here. * config/i386/i386-options.c: Moved to... * config/i386/i386-options.cc: ...here. * config/i386/i386.c: Moved to... * config/i386/i386.cc: ...here. * config/i386/intelmic-mkoffload.c: Moved to... * config/i386/intelmic-mkoffload.cc: ...here. * config/i386/msformat-c.c: Moved to... * config/i386/msformat-c.cc: ...here. * config/i386/winnt-cxx.c: Moved to... * config/i386/winnt-cxx.cc: ...here. * config/i386/winnt-d.c: Moved to... * config/i386/winnt-d.cc: ...here. * config/i386/winnt-stubs.c: Moved to... * config/i386/winnt-stubs.cc: ...here. * config/i386/winnt.c: Moved to... * config/i386/winnt.cc: ...here. * config/i386/x86-tune-sched-atom.c: Moved to... * config/i386/x86-tune-sched-atom.cc: ...here. * config/i386/x86-tune-sched-bd.c: Moved to... * config/i386/x86-tune-sched-bd.cc: ...here. * config/i386/x86-tune-sched-core.c: Moved to... * config/i386/x86-tune-sched-core.cc: ...here. * config/i386/x86-tune-sched.c: Moved to... * config/i386/x86-tune-sched.cc: ...here. * config/ia64/ia64-c.c: Moved to... * config/ia64/ia64-c.cc: ...here. * config/ia64/ia64.c: Moved to... * config/ia64/ia64.cc: ...here. * config/iq2000/iq2000.c: Moved to... * config/iq2000/iq2000.cc: ...here. * config/linux.c: Moved to... * config/linux.cc: ...here. * config/lm32/lm32.c: Moved to... * config/lm32/lm32.cc: ...here. * config/m32c/m32c-pragma.c: Moved to... * config/m32c/m32c-pragma.cc: ...here. * config/m32c/m32c.c: Moved to... * config/m32c/m32c.cc: ...here. * config/m32r/m32r.c: Moved to... * config/m32r/m32r.cc: ...here. * config/m68k/m68k.c: Moved to... * config/m68k/m68k.cc: ...here. * config/mcore/mcore.c: Moved to... * config/mcore/mcore.cc: ...here. * config/microblaze/microblaze-c.c: Moved to... * config/microblaze/microblaze-c.cc: ...here. * config/microblaze/microblaze.c: Moved to... * config/microblaze/microblaze.cc: ...here. * config/mips/driver-native.c: Moved to... * config/mips/driver-native.cc: ...here. * config/mips/frame-header-opt.c: Moved to... * config/mips/frame-header-opt.cc: ...here. * config/mips/mips-d.c: Moved to... * config/mips/mips-d.cc: ...here. * config/mips/mips.c: Moved to... * config/mips/mips.cc: ...here. * config/mmix/mmix.c: Moved to... * config/mmix/mmix.cc: ...here. * config/mn10300/mn10300.c: Moved to... * config/mn10300/mn10300.cc: ...here. * config/moxie/moxie.c: Moved to... * config/moxie/moxie.cc: ...here. * config/msp430/driver-msp430.c: Moved to... * config/msp430/driver-msp430.cc: ...here. * config/msp430/msp430-c.c: Moved to... * config/msp430/msp430-c.cc: ...here. * config/msp430/msp430-devices.c: Moved to... * config/msp430/msp430-devices.cc: ...here. * config/msp430/msp430.c: Moved to... * config/msp430/msp430.cc: ...here. * config/nds32/nds32-cost.c: Moved to... * config/nds32/nds32-cost.cc: ...here. * config/nds32/nds32-fp-as-gp.c: Moved to... * config/nds32/nds32-fp-as-gp.cc: ...here. * config/nds32/nds32-intrinsic.c: Moved to... * config/nds32/nds32-intrinsic.cc: ...here. * config/nds32/nds32-isr.c: Moved to... * config/nds32/nds32-isr.cc: ...here. * config/nds32/nds32-md-auxiliary.c: Moved to... * config/nds32/nds32-md-auxiliary.cc: ...here. * config/nds32/nds32-memory-manipulation.c: Moved to... * config/nds32/nds32-memory-manipulation.cc: ...here. * config/nds32/nds32-pipelines-auxiliary.c: Moved to... * config/nds32/nds32-pipelines-auxiliary.cc: ...here. * config/nds32/nds32-predicates.c: Moved to... * config/nds32/nds32-predicates.cc: ...here. * config/nds32/nds32-relax-opt.c: Moved to... * config/nds32/nds32-relax-opt.cc: ...here. * config/nds32/nds32-utils.c: Moved to... * config/nds32/nds32-utils.cc: ...here. * config/nds32/nds32.c: Moved to... * config/nds32/nds32.cc: ...here. * config/netbsd-d.c: Moved to... * config/netbsd-d.cc: ...here. * config/netbsd.c: Moved to... * config/netbsd.cc: ...here. * config/nios2/nios2.c: Moved to... * config/nios2/nios2.cc: ...here. * config/nvptx/mkoffload.c: Moved to... * config/nvptx/mkoffload.cc: ...here. * config/nvptx/nvptx-c.c: Moved to... * config/nvptx/nvptx-c.cc: ...here. * config/nvptx/nvptx.c: Moved to... * config/nvptx/nvptx.cc: ...here. * config/openbsd-d.c: Moved to... * config/openbsd-d.cc: ...here. * config/or1k/or1k.c: Moved to... * config/or1k/or1k.cc: ...here. * config/pa/pa-d.c: Moved to... * config/pa/pa-d.cc: ...here. * config/pa/pa.c: Moved to... * config/pa/pa.cc: ...here. * config/pdp11/pdp11.c: Moved to... * config/pdp11/pdp11.cc: ...here. * config/pru/pru-passes.c: Moved to... * config/pru/pru-passes.cc: ...here. * config/pru/pru-pragma.c: Moved to... * config/pru/pru-pragma.cc: ...here. * config/pru/pru.c: Moved to... * config/pru/pru.cc: ...here. * config/riscv/riscv-builtins.c: Moved to... * config/riscv/riscv-builtins.cc: ...here. * config/riscv/riscv-c.c: Moved to... * config/riscv/riscv-c.cc: ...here. * config/riscv/riscv-d.c: Moved to... * config/riscv/riscv-d.cc: ...here. * config/riscv/riscv-shorten-memrefs.c: Moved to... * config/riscv/riscv-shorten-memrefs.cc: ...here. * config/riscv/riscv-sr.c: Moved to... * config/riscv/riscv-sr.cc: ...here. * config/riscv/riscv.c: Moved to... * config/riscv/riscv.cc: ...here. * config/rl78/rl78-c.c: Moved to... * config/rl78/rl78-c.cc: ...here. * config/rl78/rl78.c: Moved to... * config/rl78/rl78.cc: ...here. * config/rs6000/driver-rs6000.c: Moved to... * config/rs6000/driver-rs6000.cc: ...here. * config/rs6000/host-darwin.c: Moved to... * config/rs6000/host-darwin.cc: ...here. * config/rs6000/host-ppc64-darwin.c: Moved to... * config/rs6000/host-ppc64-darwin.cc: ...here. * config/rs6000/rbtree.c: Moved to... * config/rs6000/rbtree.cc: ...here. * config/rs6000/rs6000-c.c: Moved to... * config/rs6000/rs6000-c.cc: ...here. * config/rs6000/rs6000-call.c: Moved to... * config/rs6000/rs6000-call.cc: ...here. * config/rs6000/rs6000-d.c: Moved to... * config/rs6000/rs6000-d.cc: ...here. * config/rs6000/rs6000-gen-builtins.c: Moved to... * config/rs6000/rs6000-gen-builtins.cc: ...here. * config/rs6000/rs6000-linux.c: Moved to... * config/rs6000/rs6000-linux.cc: ...here. * config/rs6000/rs6000-logue.c: Moved to... * config/rs6000/rs6000-logue.cc: ...here. * config/rs6000/rs6000-p8swap.c: Moved to... * config/rs6000/rs6000-p8swap.cc: ...here. * config/rs6000/rs6000-pcrel-opt.c: Moved to... * config/rs6000/rs6000-pcrel-opt.cc: ...here. * config/rs6000/rs6000-string.c: Moved to... * config/rs6000/rs6000-string.cc: ...here. * config/rs6000/rs6000.c: Moved to... * config/rs6000/rs6000.cc: ...here. * config/rx/rx.c: Moved to... * config/rx/rx.cc: ...here. * config/s390/driver-native.c: Moved to... * config/s390/driver-native.cc: ...here. * config/s390/s390-c.c: Moved to... * config/s390/s390-c.cc: ...here. * config/s390/s390-d.c: Moved to... * config/s390/s390-d.cc: ...here. * config/s390/s390.c: Moved to... * config/s390/s390.cc: ...here. * config/sh/divtab-sh4-300.c: Moved to... * config/sh/divtab-sh4-300.cc: ...here. * config/sh/divtab-sh4.c: Moved to... * config/sh/divtab-sh4.cc: ...here. * config/sh/divtab.c: Moved to... * config/sh/divtab.cc: ...here. * config/sh/sh-c.c: Moved to... * config/sh/sh-c.cc: ...here. * config/sh/sh.c: Moved to... * config/sh/sh.cc: ...here. * config/sol2-c.c: Moved to... * config/sol2-c.cc: ...here. * config/sol2-cxx.c: Moved to... * config/sol2-cxx.cc: ...here. * config/sol2-d.c: Moved to... * config/sol2-d.cc: ...here. * config/sol2-stubs.c: Moved to... * config/sol2-stubs.cc: ...here. * config/sol2.c: Moved to... * config/sol2.cc: ...here. * config/sparc/driver-sparc.c: Moved to... * config/sparc/driver-sparc.cc: ...here. * config/sparc/sparc-c.c: Moved to... * config/sparc/sparc-c.cc: ...here. * config/sparc/sparc-d.c: Moved to... * config/sparc/sparc-d.cc: ...here. * config/sparc/sparc.c: Moved to... * config/sparc/sparc.cc: ...here. * config/stormy16/stormy16.c: Moved to... * config/stormy16/stormy16.cc: ...here. * config/tilegx/mul-tables.c: Moved to... * config/tilegx/mul-tables.cc: ...here. * config/tilegx/tilegx-c.c: Moved to... * config/tilegx/tilegx-c.cc: ...here. * config/tilegx/tilegx.c: Moved to... * config/tilegx/tilegx.cc: ...here. * config/tilepro/mul-tables.c: Moved to... * config/tilepro/mul-tables.cc: ...here. * config/tilepro/tilepro-c.c: Moved to... * config/tilepro/tilepro-c.cc: ...here. * config/tilepro/tilepro.c: Moved to... * config/tilepro/tilepro.cc: ...here. * config/v850/v850-c.c: Moved to... * config/v850/v850-c.cc: ...here. * config/v850/v850.c: Moved to... * config/v850/v850.cc: ...here. * config/vax/vax.c: Moved to... * config/vax/vax.cc: ...here. * config/visium/visium.c: Moved to... * config/visium/visium.cc: ...here. * config/vms/vms-c.c: Moved to... * config/vms/vms-c.cc: ...here. * config/vms/vms-f.c: Moved to... * config/vms/vms-f.cc: ...here. * config/vms/vms.c: Moved to... * config/vms/vms.cc: ...here. * config/vxworks-c.c: Moved to... * config/vxworks-c.cc: ...here. * config/vxworks.c: Moved to... * config/vxworks.cc: ...here. * config/winnt-c.c: Moved to... * config/winnt-c.cc: ...here. * config/xtensa/xtensa.c: Moved to... * config/xtensa/xtensa.cc: ...here. * context.c: Moved to... * context.cc: ...here. * convert.c: Moved to... * convert.cc: ...here. * coverage.c: Moved to... * coverage.cc: ...here. * cppbuiltin.c: Moved to... * cppbuiltin.cc: ...here. * cppdefault.c: Moved to... * cppdefault.cc: ...here. * cprop.c: Moved to... * cprop.cc: ...here. * cse.c: Moved to... * cse.cc: ...here. * cselib.c: Moved to... * cselib.cc: ...here. * ctfc.c: Moved to... * ctfc.cc: ...here. * ctfout.c: Moved to... * ctfout.cc: ...here. * data-streamer-in.c: Moved to... * data-streamer-in.cc: ...here. * data-streamer-out.c: Moved to... * data-streamer-out.cc: ...here. * data-streamer.c: Moved to... * data-streamer.cc: ...here. * dbgcnt.c: Moved to... * dbgcnt.cc: ...here. * dbxout.c: Moved to... * dbxout.cc: ...here. * dce.c: Moved to... * dce.cc: ...here. * ddg.c: Moved to... * ddg.cc: ...here. * debug.c: Moved to... * debug.cc: ...here. * df-core.c: Moved to... * df-core.cc: ...here. * df-problems.c: Moved to... * df-problems.cc: ...here. * df-scan.c: Moved to... * df-scan.cc: ...here. * dfp.c: Moved to... * dfp.cc: ...here. * diagnostic-color.c: Moved to... * diagnostic-color.cc: ...here. * diagnostic-show-locus.c: Moved to... * diagnostic-show-locus.cc: ...here. * diagnostic-spec.c: Moved to... * diagnostic-spec.cc: ...here. * diagnostic.c: Moved to... * diagnostic.cc: ...here. * dojump.c: Moved to... * dojump.cc: ...here. * dominance.c: Moved to... * dominance.cc: ...here. * domwalk.c: Moved to... * domwalk.cc: ...here. * double-int.c: Moved to... * double-int.cc: ...here. * dse.c: Moved to... * dse.cc: ...here. * dumpfile.c: Moved to... * dumpfile.cc: ...here. * dwarf2asm.c: Moved to... * dwarf2asm.cc: ...here. * dwarf2cfi.c: Moved to... * dwarf2cfi.cc: ...here. * dwarf2ctf.c: Moved to... * dwarf2ctf.cc: ...here. * dwarf2out.c: Moved to... * dwarf2out.cc: ...here. * early-remat.c: Moved to... * early-remat.cc: ...here. * edit-context.c: Moved to... * edit-context.cc: ...here. * emit-rtl.c: Moved to... * emit-rtl.cc: ...here. * errors.c: Moved to... * errors.cc: ...here. * et-forest.c: Moved to... * et-forest.cc: ...here. * except.c: Moved to... * except.cc: ...here. * explow.c: Moved to... * explow.cc: ...here. * expmed.c: Moved to... * expmed.cc: ...here. * expr.c: Moved to... * expr.cc: ...here. * fibonacci_heap.c: Moved to... * fibonacci_heap.cc: ...here. * file-find.c: Moved to... * file-find.cc: ...here. * file-prefix-map.c: Moved to... * file-prefix-map.cc: ...here. * final.c: Moved to... * final.cc: ...here. * fixed-value.c: Moved to... * fixed-value.cc: ...here. * fold-const-call.c: Moved to... * fold-const-call.cc: ...here. * fold-const.c: Moved to... * fold-const.cc: ...here. * fp-test.c: Moved to... * fp-test.cc: ...here. * function-tests.c: Moved to... * function-tests.cc: ...here. * function.c: Moved to... * function.cc: ...here. * fwprop.c: Moved to... * fwprop.cc: ...here. * gcc-ar.c: Moved to... * gcc-ar.cc: ...here. * gcc-main.c: Moved to... * gcc-main.cc: ...here. * gcc-rich-location.c: Moved to... * gcc-rich-location.cc: ...here. * gcc.c: Moved to... * gcc.cc: ...here. * gcov-dump.c: Moved to... * gcov-dump.cc: ...here. * gcov-io.c: Moved to... * gcov-io.cc: ...here. * gcov-tool.c: Moved to... * gcov-tool.cc: ...here. * gcov.c: Moved to... * gcov.cc: ...here. * gcse-common.c: Moved to... * gcse-common.cc: ...here. * gcse.c: Moved to... * gcse.cc: ...here. * genattr-common.c: Moved to... * genattr-common.cc: ...here. * genattr.c: Moved to... * genattr.cc: ...here. * genattrtab.c: Moved to... * genattrtab.cc: ...here. * genautomata.c: Moved to... * genautomata.cc: ...here. * gencfn-macros.c: Moved to... * gencfn-macros.cc: ...here. * gencheck.c: Moved to... * gencheck.cc: ...here. * genchecksum.c: Moved to... * genchecksum.cc: ...here. * gencodes.c: Moved to... * gencodes.cc: ...here. * genconditions.c: Moved to... * genconditions.cc: ...here. * genconfig.c: Moved to... * genconfig.cc: ...here. * genconstants.c: Moved to... * genconstants.cc: ...here. * genemit.c: Moved to... * genemit.cc: ...here. * genenums.c: Moved to... * genenums.cc: ...here. * generic-match-head.c: Moved to... * generic-match-head.cc: ...here. * genextract.c: Moved to... * genextract.cc: ...here. * genflags.c: Moved to... * genflags.cc: ...here. * gengenrtl.c: Moved to... * gengenrtl.cc: ...here. * gengtype-parse.c: Moved to... * gengtype-parse.cc: ...here. * gengtype-state.c: Moved to... * gengtype-state.cc: ...here. * gengtype.c: Moved to... * gengtype.cc: ...here. * genhooks.c: Moved to... * genhooks.cc: ...here. * genmatch.c: Moved to... * genmatch.cc: ...here. * genmddeps.c: Moved to... * genmddeps.cc: ...here. * genmddump.c: Moved to... * genmddump.cc: ...here. * genmodes.c: Moved to... * genmodes.cc: ...here. * genopinit.c: Moved to... * genopinit.cc: ...here. * genoutput.c: Moved to... * genoutput.cc: ...here. * genpeep.c: Moved to... * genpeep.cc: ...here. * genpreds.c: Moved to... * genpreds.cc: ...here. * genrecog.c: Moved to... * genrecog.cc: ...here. * gensupport.c: Moved to... * gensupport.cc: ...here. * gentarget-def.c: Moved to... * gentarget-def.cc: ...here. * genversion.c: Moved to... * genversion.cc: ...here. * ggc-common.c: Moved to... * ggc-common.cc: ...here. * ggc-none.c: Moved to... * ggc-none.cc: ...here. * ggc-page.c: Moved to... * ggc-page.cc: ...here. * ggc-tests.c: Moved to... * ggc-tests.cc: ...here. * gimple-builder.c: Moved to... * gimple-builder.cc: ...here. * gimple-expr.c: Moved to... * gimple-expr.cc: ...here. * gimple-fold.c: Moved to... * gimple-fold.cc: ...here. * gimple-iterator.c: Moved to... * gimple-iterator.cc: ...here. * gimple-laddress.c: Moved to... * gimple-laddress.cc: ...here. * gimple-loop-jam.c: Moved to... * gimple-loop-jam.cc: ...here. * gimple-low.c: Moved to... * gimple-low.cc: ...here. * gimple-match-head.c: Moved to... * gimple-match-head.cc: ...here. * gimple-pretty-print.c: Moved to... * gimple-pretty-print.cc: ...here. * gimple-ssa-backprop.c: Moved to... * gimple-ssa-backprop.cc: ...here. * gimple-ssa-evrp-analyze.c: Moved to... * gimple-ssa-evrp-analyze.cc: ...here. * gimple-ssa-evrp.c: Moved to... * gimple-ssa-evrp.cc: ...here. * gimple-ssa-isolate-paths.c: Moved to... * gimple-ssa-isolate-paths.cc: ...here. * gimple-ssa-nonnull-compare.c: Moved to... * gimple-ssa-nonnull-compare.cc: ...here. * gimple-ssa-split-paths.c: Moved to... * gimple-ssa-split-paths.cc: ...here. * gimple-ssa-sprintf.c: Moved to... * gimple-ssa-sprintf.cc: ...here. * gimple-ssa-store-merging.c: Moved to... * gimple-ssa-store-merging.cc: ...here. * gimple-ssa-strength-reduction.c: Moved to... * gimple-ssa-strength-reduction.cc: ...here. * gimple-ssa-warn-alloca.c: Moved to... * gimple-ssa-warn-alloca.cc: ...here. * gimple-ssa-warn-restrict.c: Moved to... * gimple-ssa-warn-restrict.cc: ...here. * gimple-streamer-in.c: Moved to... * gimple-streamer-in.cc: ...here. * gimple-streamer-out.c: Moved to... * gimple-streamer-out.cc: ...here. * gimple-walk.c: Moved to... * gimple-walk.cc: ...here. * gimple-warn-recursion.c: Moved to... * gimple-warn-recursion.cc: ...here. * gimple.c: Moved to... * gimple.cc: ...here. * gimplify-me.c: Moved to... * gimplify-me.cc: ...here. * gimplify.c: Moved to... * gimplify.cc: ...here. * godump.c: Moved to... * godump.cc: ...here. * graph.c: Moved to... * graph.cc: ...here. * graphds.c: Moved to... * graphds.cc: ...here. * graphite-dependences.c: Moved to... * graphite-dependences.cc: ...here. * graphite-isl-ast-to-gimple.c: Moved to... * graphite-isl-ast-to-gimple.cc: ...here. * graphite-optimize-isl.c: Moved to... * graphite-optimize-isl.cc: ...here. * graphite-poly.c: Moved to... * graphite-poly.cc: ...here. * graphite-scop-detection.c: Moved to... * graphite-scop-detection.cc: ...here. * graphite-sese-to-poly.c: Moved to... * graphite-sese-to-poly.cc: ...here. * graphite.c: Moved to... * graphite.cc: ...here. * haifa-sched.c: Moved to... * haifa-sched.cc: ...here. * hash-map-tests.c: Moved to... * hash-map-tests.cc: ...here. * hash-set-tests.c: Moved to... * hash-set-tests.cc: ...here. * hash-table.c: Moved to... * hash-table.cc: ...here. * hooks.c: Moved to... * hooks.cc: ...here. * host-default.c: Moved to... * host-default.cc: ...here. * hw-doloop.c: Moved to... * hw-doloop.cc: ...here. * hwint.c: Moved to... * hwint.cc: ...here. * ifcvt.c: Moved to... * ifcvt.cc: ...here. * inchash.c: Moved to... * inchash.cc: ...here. * incpath.c: Moved to... * incpath.cc: ...here. * init-regs.c: Moved to... * init-regs.cc: ...here. * input.c: Moved to... * input.cc: ...here. * internal-fn.c: Moved to... * internal-fn.cc: ...here. * intl.c: Moved to... * intl.cc: ...here. * ipa-comdats.c: Moved to... * ipa-comdats.cc: ...here. * ipa-cp.c: Moved to... * ipa-cp.cc: ...here. * ipa-devirt.c: Moved to... * ipa-devirt.cc: ...here. * ipa-fnsummary.c: Moved to... * ipa-fnsummary.cc: ...here. * ipa-icf-gimple.c: Moved to... * ipa-icf-gimple.cc: ...here. * ipa-icf.c: Moved to... * ipa-icf.cc: ...here. * ipa-inline-analysis.c: Moved to... * ipa-inline-analysis.cc: ...here. * ipa-inline-transform.c: Moved to... * ipa-inline-transform.cc: ...here. * ipa-inline.c: Moved to... * ipa-inline.cc: ...here. * ipa-modref-tree.c: Moved to... * ipa-modref-tree.cc: ...here. * ipa-modref.c: Moved to... * ipa-modref.cc: ...here. * ipa-param-manipulation.c: Moved to... * ipa-param-manipulation.cc: ...here. * ipa-polymorphic-call.c: Moved to... * ipa-polymorphic-call.cc: ...here. * ipa-predicate.c: Moved to... * ipa-predicate.cc: ...here. * ipa-profile.c: Moved to... * ipa-profile.cc: ...here. * ipa-prop.c: Moved to... * ipa-prop.cc: ...here. * ipa-pure-const.c: Moved to... * ipa-pure-const.cc: ...here. * ipa-ref.c: Moved to... * ipa-ref.cc: ...here. * ipa-reference.c: Moved to... * ipa-reference.cc: ...here. * ipa-split.c: Moved to... * ipa-split.cc: ...here. * ipa-sra.c: Moved to... * ipa-sra.cc: ...here. * ipa-utils.c: Moved to... * ipa-utils.cc: ...here. * ipa-visibility.c: Moved to... * ipa-visibility.cc: ...here. * ipa.c: Moved to... * ipa.cc: ...here. * ira-build.c: Moved to... * ira-build.cc: ...here. * ira-color.c: Moved to... * ira-color.cc: ...here. * ira-conflicts.c: Moved to... * ira-conflicts.cc: ...here. * ira-costs.c: Moved to... * ira-costs.cc: ...here. * ira-emit.c: Moved to... * ira-emit.cc: ...here. * ira-lives.c: Moved to... * ira-lives.cc: ...here. * ira.c: Moved to... * ira.cc: ...here. * jump.c: Moved to... * jump.cc: ...here. * langhooks.c: Moved to... * langhooks.cc: ...here. * lcm.c: Moved to... * lcm.cc: ...here. * lists.c: Moved to... * lists.cc: ...here. * loop-doloop.c: Moved to... * loop-doloop.cc: ...here. * loop-init.c: Moved to... * loop-init.cc: ...here. * loop-invariant.c: Moved to... * loop-invariant.cc: ...here. * loop-iv.c: Moved to... * loop-iv.cc: ...here. * loop-unroll.c: Moved to... * loop-unroll.cc: ...here. * lower-subreg.c: Moved to... * lower-subreg.cc: ...here. * lra-assigns.c: Moved to... * lra-assigns.cc: ...here. * lra-coalesce.c: Moved to... * lra-coalesce.cc: ...here. * lra-constraints.c: Moved to... * lra-constraints.cc: ...here. * lra-eliminations.c: Moved to... * lra-eliminations.cc: ...here. * lra-lives.c: Moved to... * lra-lives.cc: ...here. * lra-remat.c: Moved to... * lra-remat.cc: ...here. * lra-spills.c: Moved to... * lra-spills.cc: ...here. * lra.c: Moved to... * lra.cc: ...here. * lto-cgraph.c: Moved to... * lto-cgraph.cc: ...here. * lto-compress.c: Moved to... * lto-compress.cc: ...here. * lto-opts.c: Moved to... * lto-opts.cc: ...here. * lto-section-in.c: Moved to... * lto-section-in.cc: ...here. * lto-section-out.c: Moved to... * lto-section-out.cc: ...here. * lto-streamer-in.c: Moved to... * lto-streamer-in.cc: ...here. * lto-streamer-out.c: Moved to... * lto-streamer-out.cc: ...here. * lto-streamer.c: Moved to... * lto-streamer.cc: ...here. * lto-wrapper.c: Moved to... * lto-wrapper.cc: ...here. * main.c: Moved to... * main.cc: ...here. * mcf.c: Moved to... * mcf.cc: ...here. * mode-switching.c: Moved to... * mode-switching.cc: ...here. * modulo-sched.c: Moved to... * modulo-sched.cc: ...here. * multiple_target.c: Moved to... * multiple_target.cc: ...here. * omp-expand.c: Moved to... * omp-expand.cc: ...here. * omp-general.c: Moved to... * omp-general.cc: ...here. * omp-low.c: Moved to... * omp-low.cc: ...here. * omp-offload.c: Moved to... * omp-offload.cc: ...here. * omp-simd-clone.c: Moved to... * omp-simd-clone.cc: ...here. * opt-suggestions.c: Moved to... * opt-suggestions.cc: ...here. * optabs-libfuncs.c: Moved to... * optabs-libfuncs.cc: ...here. * optabs-query.c: Moved to... * optabs-query.cc: ...here. * optabs-tree.c: Moved to... * optabs-tree.cc: ...here. * optabs.c: Moved to... * optabs.cc: ...here. * opts-common.c: Moved to... * opts-common.cc: ...here. * opts-global.c: Moved to... * opts-global.cc: ...here. * opts.c: Moved to... * opts.cc: ...here. * passes.c: Moved to... * passes.cc: ...here. * plugin.c: Moved to... * plugin.cc: ...here. * postreload-gcse.c: Moved to... * postreload-gcse.cc: ...here. * postreload.c: Moved to... * postreload.cc: ...here. * predict.c: Moved to... * predict.cc: ...here. * prefix.c: Moved to... * prefix.cc: ...here. * pretty-print.c: Moved to... * pretty-print.cc: ...here. * print-rtl-function.c: Moved to... * print-rtl-function.cc: ...here. * print-rtl.c: Moved to... * print-rtl.cc: ...here. * print-tree.c: Moved to... * print-tree.cc: ...here. * profile-count.c: Moved to... * profile-count.cc: ...here. * profile.c: Moved to... * profile.cc: ...here. * read-md.c: Moved to... * read-md.cc: ...here. * read-rtl-function.c: Moved to... * read-rtl-function.cc: ...here. * read-rtl.c: Moved to... * read-rtl.cc: ...here. * real.c: Moved to... * real.cc: ...here. * realmpfr.c: Moved to... * realmpfr.cc: ...here. * recog.c: Moved to... * recog.cc: ...here. * ree.c: Moved to... * ree.cc: ...here. * reg-stack.c: Moved to... * reg-stack.cc: ...here. * regcprop.c: Moved to... * regcprop.cc: ...here. * reginfo.c: Moved to... * reginfo.cc: ...here. * regrename.c: Moved to... * regrename.cc: ...here. * regstat.c: Moved to... * regstat.cc: ...here. * reload.c: Moved to... * reload.cc: ...here. * reload1.c: Moved to... * reload1.cc: ...here. * reorg.c: Moved to... * reorg.cc: ...here. * resource.c: Moved to... * resource.cc: ...here. * rtl-error.c: Moved to... * rtl-error.cc: ...here. * rtl-tests.c: Moved to... * rtl-tests.cc: ...here. * rtl.c: Moved to... * rtl.cc: ...here. * rtlanal.c: Moved to... * rtlanal.cc: ...here. * rtlhash.c: Moved to... * rtlhash.cc: ...here. * rtlhooks.c: Moved to... * rtlhooks.cc: ...here. * rtx-vector-builder.c: Moved to... * rtx-vector-builder.cc: ...here. * run-rtl-passes.c: Moved to... * run-rtl-passes.cc: ...here. * sancov.c: Moved to... * sancov.cc: ...here. * sanopt.c: Moved to... * sanopt.cc: ...here. * sbitmap.c: Moved to... * sbitmap.cc: ...here. * sched-deps.c: Moved to... * sched-deps.cc: ...here. * sched-ebb.c: Moved to... * sched-ebb.cc: ...here. * sched-rgn.c: Moved to... * sched-rgn.cc: ...here. * sel-sched-dump.c: Moved to... * sel-sched-dump.cc: ...here. * sel-sched-ir.c: Moved to... * sel-sched-ir.cc: ...here. * sel-sched.c: Moved to... * sel-sched.cc: ...here. * selftest-diagnostic.c: Moved to... * selftest-diagnostic.cc: ...here. * selftest-rtl.c: Moved to... * selftest-rtl.cc: ...here. * selftest-run-tests.c: Moved to... * selftest-run-tests.cc: ...here. * selftest.c: Moved to... * selftest.cc: ...here. * sese.c: Moved to... * sese.cc: ...here. * shrink-wrap.c: Moved to... * shrink-wrap.cc: ...here. * simplify-rtx.c: Moved to... * simplify-rtx.cc: ...here. * sparseset.c: Moved to... * sparseset.cc: ...here. * spellcheck-tree.c: Moved to... * spellcheck-tree.cc: ...here. * spellcheck.c: Moved to... * spellcheck.cc: ...here. * sreal.c: Moved to... * sreal.cc: ...here. * stack-ptr-mod.c: Moved to... * stack-ptr-mod.cc: ...here. * statistics.c: Moved to... * statistics.cc: ...here. * stmt.c: Moved to... * stmt.cc: ...here. * stor-layout.c: Moved to... * stor-layout.cc: ...here. * store-motion.c: Moved to... * store-motion.cc: ...here. * streamer-hooks.c: Moved to... * streamer-hooks.cc: ...here. * stringpool.c: Moved to... * stringpool.cc: ...here. * substring-locations.c: Moved to... * substring-locations.cc: ...here. * symtab.c: Moved to... * symtab.cc: ...here. * target-globals.c: Moved to... * target-globals.cc: ...here. * targhooks.c: Moved to... * targhooks.cc: ...here. * timevar.c: Moved to... * timevar.cc: ...here. * toplev.c: Moved to... * toplev.cc: ...here. * tracer.c: Moved to... * tracer.cc: ...here. * trans-mem.c: Moved to... * trans-mem.cc: ...here. * tree-affine.c: Moved to... * tree-affine.cc: ...here. * tree-call-cdce.c: Moved to... * tree-call-cdce.cc: ...here. * tree-cfg.c: Moved to... * tree-cfg.cc: ...here. * tree-cfgcleanup.c: Moved to... * tree-cfgcleanup.cc: ...here. * tree-chrec.c: Moved to... * tree-chrec.cc: ...here. * tree-complex.c: Moved to... * tree-complex.cc: ...here. * tree-data-ref.c: Moved to... * tree-data-ref.cc: ...here. * tree-dfa.c: Moved to... * tree-dfa.cc: ...here. * tree-diagnostic.c: Moved to... * tree-diagnostic.cc: ...here. * tree-dump.c: Moved to... * tree-dump.cc: ...here. * tree-eh.c: Moved to... * tree-eh.cc: ...here. * tree-emutls.c: Moved to... * tree-emutls.cc: ...here. * tree-if-conv.c: Moved to... * tree-if-conv.cc: ...here. * tree-inline.c: Moved to... * tree-inline.cc: ...here. * tree-into-ssa.c: Moved to... * tree-into-ssa.cc: ...here. * tree-iterator.c: Moved to... * tree-iterator.cc: ...here. * tree-loop-distribution.c: Moved to... * tree-loop-distribution.cc: ...here. * tree-nested.c: Moved to... * tree-nested.cc: ...here. * tree-nrv.c: Moved to... * tree-nrv.cc: ...here. * tree-object-size.c: Moved to... * tree-object-size.cc: ...here. * tree-outof-ssa.c: Moved to... * tree-outof-ssa.cc: ...here. * tree-parloops.c: Moved to... * tree-parloops.cc: ...here. * tree-phinodes.c: Moved to... * tree-phinodes.cc: ...here. * tree-predcom.c: Moved to... * tree-predcom.cc: ...here. * tree-pretty-print.c: Moved to... * tree-pretty-print.cc: ...here. * tree-profile.c: Moved to... * tree-profile.cc: ...here. * tree-scalar-evolution.c: Moved to... * tree-scalar-evolution.cc: ...here. * tree-sra.c: Moved to... * tree-sra.cc: ...here. * tree-ssa-address.c: Moved to... * tree-ssa-address.cc: ...here. * tree-ssa-alias.c: Moved to... * tree-ssa-alias.cc: ...here. * tree-ssa-ccp.c: Moved to... * tree-ssa-ccp.cc: ...here. * tree-ssa-coalesce.c: Moved to... * tree-ssa-coalesce.cc: ...here. * tree-ssa-copy.c: Moved to... * tree-ssa-copy.cc: ...here. * tree-ssa-dce.c: Moved to... * tree-ssa-dce.cc: ...here. * tree-ssa-dom.c: Moved to... * tree-ssa-dom.cc: ...here. * tree-ssa-dse.c: Moved to... * tree-ssa-dse.cc: ...here. * tree-ssa-forwprop.c: Moved to... * tree-ssa-forwprop.cc: ...here. * tree-ssa-ifcombine.c: Moved to... * tree-ssa-ifcombine.cc: ...here. * tree-ssa-live.c: Moved to... * tree-ssa-live.cc: ...here. * tree-ssa-loop-ch.c: Moved to... * tree-ssa-loop-ch.cc: ...here. * tree-ssa-loop-im.c: Moved to... * tree-ssa-loop-im.cc: ...here. * tree-ssa-loop-ivcanon.c: Moved to... * tree-ssa-loop-ivcanon.cc: ...here. * tree-ssa-loop-ivopts.c: Moved to... * tree-ssa-loop-ivopts.cc: ...here. * tree-ssa-loop-manip.c: Moved to... * tree-ssa-loop-manip.cc: ...here. * tree-ssa-loop-niter.c: Moved to... * tree-ssa-loop-niter.cc: ...here. * tree-ssa-loop-prefetch.c: Moved to... * tree-ssa-loop-prefetch.cc: ...here. * tree-ssa-loop-split.c: Moved to... * tree-ssa-loop-split.cc: ...here. * tree-ssa-loop-unswitch.c: Moved to... * tree-ssa-loop-unswitch.cc: ...here. * tree-ssa-loop.c: Moved to... * tree-ssa-loop.cc: ...here. * tree-ssa-math-opts.c: Moved to... * tree-ssa-math-opts.cc: ...here. * tree-ssa-operands.c: Moved to... * tree-ssa-operands.cc: ...here. * tree-ssa-phiopt.c: Moved to... * tree-ssa-phiopt.cc: ...here. * tree-ssa-phiprop.c: Moved to... * tree-ssa-phiprop.cc: ...here. * tree-ssa-pre.c: Moved to... * tree-ssa-pre.cc: ...here. * tree-ssa-propagate.c: Moved to... * tree-ssa-propagate.cc: ...here. * tree-ssa-reassoc.c: Moved to... * tree-ssa-reassoc.cc: ...here. * tree-ssa-sccvn.c: Moved to... * tree-ssa-sccvn.cc: ...here. * tree-ssa-scopedtables.c: Moved to... * tree-ssa-scopedtables.cc: ...here. * tree-ssa-sink.c: Moved to... * tree-ssa-sink.cc: ...here. * tree-ssa-strlen.c: Moved to... * tree-ssa-strlen.cc: ...here. * tree-ssa-structalias.c: Moved to... * tree-ssa-structalias.cc: ...here. * tree-ssa-tail-merge.c: Moved to... * tree-ssa-tail-merge.cc: ...here. * tree-ssa-ter.c: Moved to... * tree-ssa-ter.cc: ...here. * tree-ssa-threadbackward.c: Moved to... * tree-ssa-threadbackward.cc: ...here. * tree-ssa-threadedge.c: Moved to... * tree-ssa-threadedge.cc: ...here. * tree-ssa-threadupdate.c: Moved to... * tree-ssa-threadupdate.cc: ...here. * tree-ssa-uncprop.c: Moved to... * tree-ssa-uncprop.cc: ...here. * tree-ssa-uninit.c: Moved to... * tree-ssa-uninit.cc: ...here. * tree-ssa.c: Moved to... * tree-ssa.cc: ...here. * tree-ssanames.c: Moved to... * tree-ssanames.cc: ...here. * tree-stdarg.c: Moved to... * tree-stdarg.cc: ...here. * tree-streamer-in.c: Moved to... * tree-streamer-in.cc: ...here. * tree-streamer-out.c: Moved to... * tree-streamer-out.cc: ...here. * tree-streamer.c: Moved to... * tree-streamer.cc: ...here. * tree-switch-conversion.c: Moved to... * tree-switch-conversion.cc: ...here. * tree-tailcall.c: Moved to... * tree-tailcall.cc: ...here. * tree-vect-data-refs.c: Moved to... * tree-vect-data-refs.cc: ...here. * tree-vect-generic.c: Moved to... * tree-vect-generic.cc: ...here. * tree-vect-loop-manip.c: Moved to... * tree-vect-loop-manip.cc: ...here. * tree-vect-loop.c: Moved to... * tree-vect-loop.cc: ...here. * tree-vect-patterns.c: Moved to... * tree-vect-patterns.cc: ...here. * tree-vect-slp-patterns.c: Moved to... * tree-vect-slp-patterns.cc: ...here. * tree-vect-slp.c: Moved to... * tree-vect-slp.cc: ...here. * tree-vect-stmts.c: Moved to... * tree-vect-stmts.cc: ...here. * tree-vector-builder.c: Moved to... * tree-vector-builder.cc: ...here. * tree-vectorizer.c: Moved to... * tree-vectorizer.cc: ...here. * tree-vrp.c: Moved to... * tree-vrp.cc: ...here. * tree.c: Moved to... * tree.cc: ...here. * tsan.c: Moved to... * tsan.cc: ...here. * typed-splay-tree.c: Moved to... * typed-splay-tree.cc: ...here. * ubsan.c: Moved to... * ubsan.cc: ...here. * valtrack.c: Moved to... * valtrack.cc: ...here. * value-prof.c: Moved to... * value-prof.cc: ...here. * var-tracking.c: Moved to... * var-tracking.cc: ...here. * varasm.c: Moved to... * varasm.cc: ...here. * varpool.c: Moved to... * varpool.cc: ...here. * vec-perm-indices.c: Moved to... * vec-perm-indices.cc: ...here. * vec.c: Moved to... * vec.cc: ...here. * vmsdbgout.c: Moved to... * vmsdbgout.cc: ...here. * vr-values.c: Moved to... * vr-values.cc: ...here. * vtable-verify.c: Moved to... * vtable-verify.cc: ...here. * web.c: Moved to... * web.cc: ...here. * xcoffout.c: Moved to... * xcoffout.cc: ...here. gcc/c-family/ChangeLog: * c-ada-spec.c: Moved to... * c-ada-spec.cc: ...here. * c-attribs.c: Moved to... * c-attribs.cc: ...here. * c-common.c: Moved to... * c-common.cc: ...here. * c-cppbuiltin.c: Moved to... * c-cppbuiltin.cc: ...here. * c-dump.c: Moved to... * c-dump.cc: ...here. * c-format.c: Moved to... * c-format.cc: ...here. * c-gimplify.c: Moved to... * c-gimplify.cc: ...here. * c-indentation.c: Moved to... * c-indentation.cc: ...here. * c-lex.c: Moved to... * c-lex.cc: ...here. * c-omp.c: Moved to... * c-omp.cc: ...here. * c-opts.c: Moved to... * c-opts.cc: ...here. * c-pch.c: Moved to... * c-pch.cc: ...here. * c-ppoutput.c: Moved to... * c-ppoutput.cc: ...here. * c-pragma.c: Moved to... * c-pragma.cc: ...here. * c-pretty-print.c: Moved to... * c-pretty-print.cc: ...here. * c-semantics.c: Moved to... * c-semantics.cc: ...here. * c-ubsan.c: Moved to... * c-ubsan.cc: ...here. * c-warn.c: Moved to... * c-warn.cc: ...here. * cppspec.c: Moved to... * cppspec.cc: ...here. * stub-objc.c: Moved to... * stub-objc.cc: ...here. gcc/c/ChangeLog: * c-aux-info.c: Moved to... * c-aux-info.cc: ...here. * c-convert.c: Moved to... * c-convert.cc: ...here. * c-decl.c: Moved to... * c-decl.cc: ...here. * c-errors.c: Moved to... * c-errors.cc: ...here. * c-fold.c: Moved to... * c-fold.cc: ...here. * c-lang.c: Moved to... * c-lang.cc: ...here. * c-objc-common.c: Moved to... * c-objc-common.cc: ...here. * c-parser.c: Moved to... * c-parser.cc: ...here. * c-typeck.c: Moved to... * c-typeck.cc: ...here. * gccspec.c: Moved to... * gccspec.cc: ...here. * gimple-parser.c: Moved to... * gimple-parser.cc: ...here. gcc/cp/ChangeLog: * call.c: Moved to... * call.cc: ...here. * class.c: Moved to... * class.cc: ...here. * constexpr.c: Moved to... * constexpr.cc: ...here. * cp-gimplify.c: Moved to... * cp-gimplify.cc: ...here. * cp-lang.c: Moved to... * cp-lang.cc: ...here. * cp-objcp-common.c: Moved to... * cp-objcp-common.cc: ...here. * cp-ubsan.c: Moved to... * cp-ubsan.cc: ...here. * cvt.c: Moved to... * cvt.cc: ...here. * cxx-pretty-print.c: Moved to... * cxx-pretty-print.cc: ...here. * decl.c: Moved to... * decl.cc: ...here. * decl2.c: Moved to... * decl2.cc: ...here. * dump.c: Moved to... * dump.cc: ...here. * error.c: Moved to... * error.cc: ...here. * except.c: Moved to... * except.cc: ...here. * expr.c: Moved to... * expr.cc: ...here. * friend.c: Moved to... * friend.cc: ...here. * g++spec.c: Moved to... * g++spec.cc: ...here. * init.c: Moved to... * init.cc: ...here. * lambda.c: Moved to... * lambda.cc: ...here. * lex.c: Moved to... * lex.cc: ...here. * mangle.c: Moved to... * mangle.cc: ...here. * method.c: Moved to... * method.cc: ...here. * name-lookup.c: Moved to... * name-lookup.cc: ...here. * optimize.c: Moved to... * optimize.cc: ...here. * parser.c: Moved to... * parser.cc: ...here. * pt.c: Moved to... * pt.cc: ...here. * ptree.c: Moved to... * ptree.cc: ...here. * rtti.c: Moved to... * rtti.cc: ...here. * search.c: Moved to... * search.cc: ...here. * semantics.c: Moved to... * semantics.cc: ...here. * tree.c: Moved to... * tree.cc: ...here. * typeck.c: Moved to... * typeck.cc: ...here. * typeck2.c: Moved to... * typeck2.cc: ...here. * vtable-class-hierarchy.c: Moved to... * vtable-class-hierarchy.cc: ...here. gcc/fortran/ChangeLog: * arith.c: Moved to... * arith.cc: ...here. * array.c: Moved to... * array.cc: ...here. * bbt.c: Moved to... * bbt.cc: ...here. * check.c: Moved to... * check.cc: ...here. * class.c: Moved to... * class.cc: ...here. * constructor.c: Moved to... * constructor.cc: ...here. * convert.c: Moved to... * convert.cc: ...here. * cpp.c: Moved to... * cpp.cc: ...here. * data.c: Moved to... * data.cc: ...here. * decl.c: Moved to... * decl.cc: ...here. * dependency.c: Moved to... * dependency.cc: ...here. * dump-parse-tree.c: Moved to... * dump-parse-tree.cc: ...here. * error.c: Moved to... * error.cc: ...here. * expr.c: Moved to... * expr.cc: ...here. * f95-lang.c: Moved to... * f95-lang.cc: ...here. * frontend-passes.c: Moved to... * frontend-passes.cc: ...here. * gfortranspec.c: Moved to... * gfortranspec.cc: ...here. * interface.c: Moved to... * interface.cc: ...here. * intrinsic.c: Moved to... * intrinsic.cc: ...here. * io.c: Moved to... * io.cc: ...here. * iresolve.c: Moved to... * iresolve.cc: ...here. * match.c: Moved to... * match.cc: ...here. * matchexp.c: Moved to... * matchexp.cc: ...here. * misc.c: Moved to... * misc.cc: ...here. * module.c: Moved to... * module.cc: ...here. * openmp.c: Moved to... * openmp.cc: ...here. * options.c: Moved to... * options.cc: ...here. * parse.c: Moved to... * parse.cc: ...here. * primary.c: Moved to... * primary.cc: ...here. * resolve.c: Moved to... * resolve.cc: ...here. * scanner.c: Moved to... * scanner.cc: ...here. * simplify.c: Moved to... * simplify.cc: ...here. * st.c: Moved to... * st.cc: ...here. * symbol.c: Moved to... * symbol.cc: ...here. * target-memory.c: Moved to... * target-memory.cc: ...here. * trans-array.c: Moved to... * trans-array.cc: ...here. * trans-common.c: Moved to... * trans-common.cc: ...here. * trans-const.c: Moved to... * trans-const.cc: ...here. * trans-decl.c: Moved to... * trans-decl.cc: ...here. * trans-expr.c: Moved to... * trans-expr.cc: ...here. * trans-intrinsic.c: Moved to... * trans-intrinsic.cc: ...here. * trans-io.c: Moved to... * trans-io.cc: ...here. * trans-openmp.c: Moved to... * trans-openmp.cc: ...here. * trans-stmt.c: Moved to... * trans-stmt.cc: ...here. * trans-types.c: Moved to... * trans-types.cc: ...here. * trans.c: Moved to... * trans.cc: ...here. gcc/go/ChangeLog: * go-backend.c: Moved to... * go-backend.cc: ...here. * go-lang.c: Moved to... * go-lang.cc: ...here. * gospec.c: Moved to... * gospec.cc: ...here. gcc/jit/ChangeLog: * dummy-frontend.c: Moved to... * dummy-frontend.cc: ...here. * jit-builtins.c: Moved to... * jit-builtins.cc: ...here. * jit-logging.c: Moved to... * jit-logging.cc: ...here. * jit-playback.c: Moved to... * jit-playback.cc: ...here. * jit-recording.c: Moved to... * jit-recording.cc: ...here. * jit-result.c: Moved to... * jit-result.cc: ...here. * jit-spec.c: Moved to... * jit-spec.cc: ...here. * jit-tempdir.c: Moved to... * jit-tempdir.cc: ...here. * jit-w32.c: Moved to... * jit-w32.cc: ...here. * libgccjit.c: Moved to... * libgccjit.cc: ...here. gcc/lto/ChangeLog: * common.c: Moved to... * common.cc: ...here. * lto-common.c: Moved to... * lto-common.cc: ...here. * lto-dump.c: Moved to... * lto-dump.cc: ...here. * lto-lang.c: Moved to... * lto-lang.cc: ...here. * lto-object.c: Moved to... * lto-object.cc: ...here. * lto-partition.c: Moved to... * lto-partition.cc: ...here. * lto-symtab.c: Moved to... * lto-symtab.cc: ...here. * lto.c: Moved to... * lto.cc: ...here. gcc/objc/ChangeLog: * objc-act.c: Moved to... * objc-act.cc: ...here. * objc-encoding.c: Moved to... * objc-encoding.cc: ...here. * objc-gnu-runtime-abi-01.c: Moved to... * objc-gnu-runtime-abi-01.cc: ...here. * objc-lang.c: Moved to... * objc-lang.cc: ...here. * objc-map.c: Moved to... * objc-map.cc: ...here. * objc-next-runtime-abi-01.c: Moved to... * objc-next-runtime-abi-01.cc: ...here. * objc-next-runtime-abi-02.c: Moved to... * objc-next-runtime-abi-02.cc: ...here. * objc-runtime-shared-support.c: Moved to... * objc-runtime-shared-support.cc: ...here. gcc/objcp/ChangeLog: * objcp-decl.c: Moved to... * objcp-decl.cc: ...here. * objcp-lang.c: Moved to... * objcp-lang.cc: ...here. libcpp/ChangeLog: * charset.c: Moved to... * charset.cc: ...here. * directives.c: Moved to... * directives.cc: ...here. * errors.c: Moved to... * errors.cc: ...here. * expr.c: Moved to... * expr.cc: ...here. * files.c: Moved to... * files.cc: ...here. * identifiers.c: Moved to... * identifiers.cc: ...here. * init.c: Moved to... * init.cc: ...here. * lex.c: Moved to... * lex.cc: ...here. * line-map.c: Moved to... * line-map.cc: ...here. * macro.c: Moved to... * macro.cc: ...here. * makeucnid.c: Moved to... * makeucnid.cc: ...here. * mkdeps.c: Moved to... * mkdeps.cc: ...here. * pch.c: Moved to... * pch.cc: ...here. * symtab.c: Moved to... * symtab.cc: ...here. * traditional.c: Moved to... * traditional.cc: ...here. --- gcc/fortran/trans-array.c | 11714 -------------------------------------------- 1 file changed, 11714 deletions(-) delete mode 100644 gcc/fortran/trans-array.c (limited to 'gcc/fortran/trans-array.c') diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c deleted file mode 100644 index a77f331..0000000 --- a/gcc/fortran/trans-array.c +++ /dev/null @@ -1,11714 +0,0 @@ -/* Array translation routines - Copyright (C) 2002-2022 Free Software Foundation, Inc. - Contributed by Paul Brook - and Steven Bosscher - -This file is part of GCC. - -GCC 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. - -GCC 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. - -You should have received a copy of the GNU General Public License -along with GCC; see the file COPYING3. If not see -. */ - -/* trans-array.c-- Various array related code, including scalarization, - allocation, initialization and other support routines. */ - -/* How the scalarizer works. - In gfortran, array expressions use the same core routines as scalar - expressions. - First, a Scalarization State (SS) chain is built. This is done by walking - the expression tree, and building a linear list of the terms in the - expression. As the tree is walked, scalar subexpressions are translated. - - The scalarization parameters are stored in a gfc_loopinfo structure. - First the start and stride of each term is calculated by - gfc_conv_ss_startstride. During this process the expressions for the array - descriptors and data pointers are also translated. - - If the expression is an assignment, we must then resolve any dependencies. - In Fortran all the rhs values of an assignment must be evaluated before - any assignments take place. This can require a temporary array to store the - values. We also require a temporary when we are passing array expressions - or vector subscripts as procedure parameters. - - Array sections are passed without copying to a temporary. These use the - scalarizer to determine the shape of the section. The flag - loop->array_parameter tells the scalarizer that the actual values and loop - variables will not be required. - - The function gfc_conv_loop_setup generates the scalarization setup code. - It determines the range of the scalarizing loop variables. If a temporary - is required, this is created and initialized. Code for scalar expressions - taken outside the loop is also generated at this time. Next the offset and - scaling required to translate from loop variables to array indices for each - term is calculated. - - A call to gfc_start_scalarized_body marks the start of the scalarized - expression. This creates a scope and declares the loop variables. Before - calling this gfc_make_ss_chain_used must be used to indicate which terms - will be used inside this loop. - - The scalar gfc_conv_* functions are then used to build the main body of the - scalarization loop. Scalarization loop variables and precalculated scalar - values are automatically substituted. Note that gfc_advance_se_ss_chain - must be used, rather than changing the se->ss directly. - - For assignment expressions requiring a temporary two sub loops are - generated. The first stores the result of the expression in the temporary, - the second copies it to the result. A call to - gfc_trans_scalarized_loop_boundary marks the end of the main loop code and - the start of the copying loop. The temporary may be less than full rank. - - Finally gfc_trans_scalarizing_loops is called to generate the implicit do - loops. The loops are added to the pre chain of the loopinfo. The post - chain may still contain cleanup code. - - After the loop code has been added into its parent scope gfc_cleanup_loop - is called to free all the SS allocated by the scalarizer. */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "options.h" -#include "tree.h" -#include "gfortran.h" -#include "gimple-expr.h" -#include "trans.h" -#include "fold-const.h" -#include "constructor.h" -#include "trans-types.h" -#include "trans-array.h" -#include "trans-const.h" -#include "dependency.h" - -static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor_base); - -/* The contents of this structure aren't actually used, just the address. */ -static gfc_ss gfc_ss_terminator_var; -gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var; - - -static tree -gfc_array_dataptr_type (tree desc) -{ - return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc))); -} - -/* Build expressions to access members of the CFI descriptor. */ -#define CFI_FIELD_BASE_ADDR 0 -#define CFI_FIELD_ELEM_LEN 1 -#define CFI_FIELD_VERSION 2 -#define CFI_FIELD_RANK 3 -#define CFI_FIELD_ATTRIBUTE 4 -#define CFI_FIELD_TYPE 5 -#define CFI_FIELD_DIM 6 - -#define CFI_DIM_FIELD_LOWER_BOUND 0 -#define CFI_DIM_FIELD_EXTENT 1 -#define CFI_DIM_FIELD_SM 2 - -static tree -gfc_get_cfi_descriptor_field (tree desc, unsigned field_idx) -{ - tree type = TREE_TYPE (desc); - gcc_assert (TREE_CODE (type) == RECORD_TYPE - && TYPE_FIELDS (type) - && (strcmp ("base_addr", - IDENTIFIER_POINTER (DECL_NAME (TYPE_FIELDS (type)))) - == 0)); - tree field = gfc_advance_chain (TYPE_FIELDS (type), field_idx); - gcc_assert (field != NULL_TREE); - - return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), - desc, field, NULL_TREE); -} - -tree -gfc_get_cfi_desc_base_addr (tree desc) -{ - return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_BASE_ADDR); -} - -tree -gfc_get_cfi_desc_elem_len (tree desc) -{ - return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_ELEM_LEN); -} - -tree -gfc_get_cfi_desc_version (tree desc) -{ - return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_VERSION); -} - -tree -gfc_get_cfi_desc_rank (tree desc) -{ - return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_RANK); -} - -tree -gfc_get_cfi_desc_type (tree desc) -{ - return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_TYPE); -} - -tree -gfc_get_cfi_desc_attribute (tree desc) -{ - return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_ATTRIBUTE); -} - -static tree -gfc_get_cfi_dim_item (tree desc, tree idx, unsigned field_idx) -{ - tree tmp = gfc_get_cfi_descriptor_field (desc, CFI_FIELD_DIM); - tmp = gfc_build_array_ref (tmp, idx, NULL); - tree field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), field_idx); - gcc_assert (field != NULL_TREE); - return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), - tmp, field, NULL_TREE); -} - -tree -gfc_get_cfi_dim_lbound (tree desc, tree idx) -{ - return gfc_get_cfi_dim_item (desc, idx, CFI_DIM_FIELD_LOWER_BOUND); -} - -tree -gfc_get_cfi_dim_extent (tree desc, tree idx) -{ - return gfc_get_cfi_dim_item (desc, idx, CFI_DIM_FIELD_EXTENT); -} - -tree -gfc_get_cfi_dim_sm (tree desc, tree idx) -{ - return gfc_get_cfi_dim_item (desc, idx, CFI_DIM_FIELD_SM); -} - -#undef CFI_FIELD_BASE_ADDR -#undef CFI_FIELD_ELEM_LEN -#undef CFI_FIELD_VERSION -#undef CFI_FIELD_RANK -#undef CFI_FIELD_ATTRIBUTE -#undef CFI_FIELD_TYPE -#undef CFI_FIELD_DIM - -#undef CFI_DIM_FIELD_LOWER_BOUND -#undef CFI_DIM_FIELD_EXTENT -#undef CFI_DIM_FIELD_SM - -/* Build expressions to access the members of an array descriptor. - It's surprisingly easy to mess up here, so never access - an array descriptor by "brute force", always use these - functions. This also avoids problems if we change the format - of an array descriptor. - - To understand these magic numbers, look at the comments - before gfc_build_array_type() in trans-types.c. - - The code within these defines should be the only code which knows the format - of an array descriptor. - - Any code just needing to read obtain the bounds of an array should use - gfc_conv_array_* rather than the following functions as these will return - know constant values, and work with arrays which do not have descriptors. - - Don't forget to #undef these! */ - -#define DATA_FIELD 0 -#define OFFSET_FIELD 1 -#define DTYPE_FIELD 2 -#define SPAN_FIELD 3 -#define DIMENSION_FIELD 4 -#define CAF_TOKEN_FIELD 5 - -#define STRIDE_SUBFIELD 0 -#define LBOUND_SUBFIELD 1 -#define UBOUND_SUBFIELD 2 - -static tree -gfc_get_descriptor_field (tree desc, unsigned field_idx) -{ - tree type = TREE_TYPE (desc); - gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); - - tree field = gfc_advance_chain (TYPE_FIELDS (type), field_idx); - gcc_assert (field != NULL_TREE); - - return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), - desc, field, NULL_TREE); -} - -/* This provides READ-ONLY access to the data field. The field itself - doesn't have the proper type. */ - -tree -gfc_conv_descriptor_data_get (tree desc) -{ - tree type = TREE_TYPE (desc); - if (TREE_CODE (type) == REFERENCE_TYPE) - gcc_unreachable (); - - tree field = gfc_get_descriptor_field (desc, DATA_FIELD); - return fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), field); -} - -/* This provides WRITE access to the data field. - - TUPLES_P is true if we are generating tuples. - - This function gets called through the following macros: - gfc_conv_descriptor_data_set - gfc_conv_descriptor_data_set. */ - -void -gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value) -{ - tree field = gfc_get_descriptor_field (desc, DATA_FIELD); - gfc_add_modify (block, field, fold_convert (TREE_TYPE (field), value)); -} - - -/* This provides address access to the data field. This should only be - used by array allocation, passing this on to the runtime. */ - -tree -gfc_conv_descriptor_data_addr (tree desc) -{ - tree field = gfc_get_descriptor_field (desc, DATA_FIELD); - return gfc_build_addr_expr (NULL_TREE, field); -} - -static tree -gfc_conv_descriptor_offset (tree desc) -{ - tree field = gfc_get_descriptor_field (desc, OFFSET_FIELD); - gcc_assert (TREE_TYPE (field) == gfc_array_index_type); - return field; -} - -tree -gfc_conv_descriptor_offset_get (tree desc) -{ - return gfc_conv_descriptor_offset (desc); -} - -void -gfc_conv_descriptor_offset_set (stmtblock_t *block, tree desc, - tree value) -{ - tree t = gfc_conv_descriptor_offset (desc); - gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value)); -} - - -tree -gfc_conv_descriptor_dtype (tree desc) -{ - tree field = gfc_get_descriptor_field (desc, DTYPE_FIELD); - gcc_assert (TREE_TYPE (field) == get_dtype_type_node ()); - return field; -} - -static tree -gfc_conv_descriptor_span (tree desc) -{ - tree field = gfc_get_descriptor_field (desc, SPAN_FIELD); - gcc_assert (TREE_TYPE (field) == gfc_array_index_type); - return field; -} - -tree -gfc_conv_descriptor_span_get (tree desc) -{ - return gfc_conv_descriptor_span (desc); -} - -void -gfc_conv_descriptor_span_set (stmtblock_t *block, tree desc, - tree value) -{ - tree t = gfc_conv_descriptor_span (desc); - gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value)); -} - - -tree -gfc_conv_descriptor_rank (tree desc) -{ - tree tmp; - tree dtype; - - dtype = gfc_conv_descriptor_dtype (desc); - tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), GFC_DTYPE_RANK); - gcc_assert (tmp != NULL_TREE - && TREE_TYPE (tmp) == signed_char_type_node); - return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp), - dtype, tmp, NULL_TREE); -} - - -/* Return the element length from the descriptor dtype field. */ - -tree -gfc_conv_descriptor_elem_len (tree desc) -{ - tree tmp; - tree dtype; - - dtype = gfc_conv_descriptor_dtype (desc); - tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), - GFC_DTYPE_ELEM_LEN); - gcc_assert (tmp != NULL_TREE - && TREE_TYPE (tmp) == size_type_node); - return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp), - dtype, tmp, NULL_TREE); -} - - -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_conv_descriptor_type (tree desc) -{ - tree tmp; - tree dtype; - - dtype = gfc_conv_descriptor_dtype (desc); - tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), GFC_DTYPE_TYPE); - gcc_assert (tmp!= NULL_TREE - && TREE_TYPE (tmp) == signed_char_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 field = gfc_get_descriptor_field (desc, DIMENSION_FIELD); - gcc_assert (TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE - && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE); - return field; -} - - -static tree -gfc_conv_descriptor_dimension (tree desc, tree dim) -{ - tree tmp; - - tmp = gfc_get_descriptor_dimension (desc); - - return gfc_build_array_ref (tmp, dim, NULL); -} - - -tree -gfc_conv_descriptor_token (tree desc) -{ - gcc_assert (flag_coarray == GFC_FCOARRAY_LIB); - tree field = gfc_get_descriptor_field (desc, CAF_TOKEN_FIELD); - /* Should be a restricted pointer - except in the finalization wrapper. */ - gcc_assert (TREE_TYPE (field) == prvoid_type_node - || TREE_TYPE (field) == pvoid_type_node); - return field; -} - -static tree -gfc_conv_descriptor_subfield (tree desc, tree dim, unsigned field_idx) -{ - tree tmp = gfc_conv_descriptor_dimension (desc, dim); - tree field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), field_idx); - gcc_assert (field != NULL_TREE); - - return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), - tmp, field, NULL_TREE); -} - -static tree -gfc_conv_descriptor_stride (tree desc, tree dim) -{ - tree field = gfc_conv_descriptor_subfield (desc, dim, STRIDE_SUBFIELD); - gcc_assert (TREE_TYPE (field) == gfc_array_index_type); - return field; -} - -tree -gfc_conv_descriptor_stride_get (tree desc, tree dim) -{ - tree type = TREE_TYPE (desc); - gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); - if (integer_zerop (dim) - && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE - ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT - ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT - ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT)) - return gfc_index_one_node; - - return gfc_conv_descriptor_stride (desc, dim); -} - -void -gfc_conv_descriptor_stride_set (stmtblock_t *block, tree desc, - tree dim, tree value) -{ - tree t = gfc_conv_descriptor_stride (desc, dim); - gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value)); -} - -static tree -gfc_conv_descriptor_lbound (tree desc, tree dim) -{ - tree field = gfc_conv_descriptor_subfield (desc, dim, LBOUND_SUBFIELD); - gcc_assert (TREE_TYPE (field) == gfc_array_index_type); - return field; -} - -tree -gfc_conv_descriptor_lbound_get (tree desc, tree dim) -{ - return gfc_conv_descriptor_lbound (desc, dim); -} - -void -gfc_conv_descriptor_lbound_set (stmtblock_t *block, tree desc, - tree dim, tree value) -{ - tree t = gfc_conv_descriptor_lbound (desc, dim); - gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value)); -} - -static tree -gfc_conv_descriptor_ubound (tree desc, tree dim) -{ - tree field = gfc_conv_descriptor_subfield (desc, dim, UBOUND_SUBFIELD); - gcc_assert (TREE_TYPE (field) == gfc_array_index_type); - return field; -} - -tree -gfc_conv_descriptor_ubound_get (tree desc, tree dim) -{ - return gfc_conv_descriptor_ubound (desc, dim); -} - -void -gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree desc, - tree dim, tree value) -{ - tree t = gfc_conv_descriptor_ubound (desc, dim); - gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value)); -} - -/* Build a null array descriptor constructor. */ - -tree -gfc_build_null_descriptor (tree type) -{ - tree field; - tree tmp; - - gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); - gcc_assert (DATA_FIELD == 0); - field = TYPE_FIELDS (type); - - /* Set a NULL data pointer. */ - tmp = build_constructor_single (type, field, null_pointer_node); - TREE_CONSTANT (tmp) = 1; - /* All other fields are ignored. */ - - return tmp; -} - - -/* Modify a descriptor such that the lbound of a given dimension is the value - specified. This also updates ubound and offset accordingly. */ - -void -gfc_conv_shift_descriptor_lbound (stmtblock_t* block, tree desc, - int dim, tree new_lbound) -{ - tree offs, ubound, lbound, stride; - tree diff, offs_diff; - - new_lbound = fold_convert (gfc_array_index_type, new_lbound); - - offs = gfc_conv_descriptor_offset_get (desc); - lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]); - ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]); - stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[dim]); - - /* Get difference (new - old) by which to shift stuff. */ - diff = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, - new_lbound, lbound); - - /* Shift ubound and offset accordingly. This has to be done before - updating the lbound, as they depend on the lbound expression! */ - ubound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - ubound, diff); - gfc_conv_descriptor_ubound_set (block, desc, gfc_rank_cst[dim], ubound); - offs_diff = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - diff, stride); - offs = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, - offs, offs_diff); - gfc_conv_descriptor_offset_set (block, desc, offs); - - /* Finally set lbound to value we want. */ - gfc_conv_descriptor_lbound_set (block, desc, gfc_rank_cst[dim], new_lbound); -} - - -/* Obtain offsets for trans-types.c(gfc_get_array_descr_info). */ - -void -gfc_get_descriptor_offsets_for_info (const_tree desc_type, tree *data_off, - tree *dtype_off, tree *span_off, - tree *dim_off, tree *dim_size, - tree *stride_suboff, tree *lower_suboff, - tree *upper_suboff) -{ - tree field; - tree type; - - type = TYPE_MAIN_VARIANT (desc_type); - field = gfc_advance_chain (TYPE_FIELDS (type), DATA_FIELD); - *data_off = byte_position (field); - field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD); - *dtype_off = byte_position (field); - field = gfc_advance_chain (TYPE_FIELDS (type), SPAN_FIELD); - *span_off = byte_position (field); - field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD); - *dim_off = byte_position (field); - type = TREE_TYPE (TREE_TYPE (field)); - *dim_size = TYPE_SIZE_UNIT (type); - field = gfc_advance_chain (TYPE_FIELDS (type), STRIDE_SUBFIELD); - *stride_suboff = byte_position (field); - field = gfc_advance_chain (TYPE_FIELDS (type), LBOUND_SUBFIELD); - *lower_suboff = byte_position (field); - field = gfc_advance_chain (TYPE_FIELDS (type), UBOUND_SUBFIELD); - *upper_suboff = byte_position (field); -} - - -/* Cleanup those #defines. */ - -#undef DATA_FIELD -#undef OFFSET_FIELD -#undef DTYPE_FIELD -#undef SPAN_FIELD -#undef DIMENSION_FIELD -#undef CAF_TOKEN_FIELD -#undef STRIDE_SUBFIELD -#undef LBOUND_SUBFIELD -#undef UBOUND_SUBFIELD - - -/* Mark a SS chain as used. Flags specifies in which loops the SS is used. - flags & 1 = Main loop body. - flags & 2 = temp copy loop. */ - -void -gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags) -{ - for (; ss != gfc_ss_terminator; ss = ss->next) - ss->info->useflags = flags; -} - - -/* Free a gfc_ss chain. */ - -void -gfc_free_ss_chain (gfc_ss * ss) -{ - gfc_ss *next; - - while (ss != gfc_ss_terminator) - { - gcc_assert (ss != NULL); - next = ss->next; - gfc_free_ss (ss); - ss = next; - } -} - - -static void -free_ss_info (gfc_ss_info *ss_info) -{ - int n; - - ss_info->refcount--; - if (ss_info->refcount > 0) - return; - - gcc_assert (ss_info->refcount == 0); - - switch (ss_info->type) - { - case GFC_SS_SECTION: - for (n = 0; n < GFC_MAX_DIMENSIONS; n++) - if (ss_info->data.array.subscript[n]) - gfc_free_ss_chain (ss_info->data.array.subscript[n]); - break; - - default: - break; - } - - free (ss_info); -} - - -/* Free a SS. */ - -void -gfc_free_ss (gfc_ss * ss) -{ - free_ss_info (ss->info); - free (ss); -} - - -/* Creates and initializes an array type gfc_ss struct. */ - -gfc_ss * -gfc_get_array_ss (gfc_ss *next, gfc_expr *expr, int dimen, gfc_ss_type type) -{ - gfc_ss *ss; - gfc_ss_info *ss_info; - int i; - - ss_info = gfc_get_ss_info (); - ss_info->refcount++; - ss_info->type = type; - ss_info->expr = expr; - - ss = gfc_get_ss (); - ss->info = ss_info; - ss->next = next; - ss->dimen = dimen; - for (i = 0; i < ss->dimen; i++) - ss->dim[i] = i; - - return ss; -} - - -/* Creates and initializes a temporary type gfc_ss struct. */ - -gfc_ss * -gfc_get_temp_ss (tree type, tree string_length, int dimen) -{ - gfc_ss *ss; - gfc_ss_info *ss_info; - int i; - - ss_info = gfc_get_ss_info (); - ss_info->refcount++; - ss_info->type = GFC_SS_TEMP; - ss_info->string_length = string_length; - ss_info->data.temp.type = type; - - ss = gfc_get_ss (); - ss->info = ss_info; - ss->next = gfc_ss_terminator; - ss->dimen = dimen; - for (i = 0; i < ss->dimen; i++) - ss->dim[i] = i; - - return ss; -} - - -/* Creates and initializes a scalar type gfc_ss struct. */ - -gfc_ss * -gfc_get_scalar_ss (gfc_ss *next, gfc_expr *expr) -{ - gfc_ss *ss; - gfc_ss_info *ss_info; - - ss_info = gfc_get_ss_info (); - ss_info->refcount++; - ss_info->type = GFC_SS_SCALAR; - ss_info->expr = expr; - - ss = gfc_get_ss (); - ss->info = ss_info; - ss->next = next; - - return ss; -} - - -/* Free all the SS associated with a loop. */ - -void -gfc_cleanup_loop (gfc_loopinfo * loop) -{ - gfc_loopinfo *loop_next, **ploop; - gfc_ss *ss; - gfc_ss *next; - - ss = loop->ss; - while (ss != gfc_ss_terminator) - { - gcc_assert (ss != NULL); - next = ss->loop_chain; - gfc_free_ss (ss); - ss = next; - } - - /* Remove reference to self in the parent loop. */ - if (loop->parent) - for (ploop = &loop->parent->nested; *ploop; ploop = &(*ploop)->next) - if (*ploop == loop) - { - *ploop = loop->next; - break; - } - - /* Free non-freed nested loops. */ - for (loop = loop->nested; loop; loop = loop_next) - { - loop_next = loop->next; - gfc_cleanup_loop (loop); - free (loop); - } -} - - -static void -set_ss_loop (gfc_ss *ss, gfc_loopinfo *loop) -{ - int n; - - for (; ss != gfc_ss_terminator; ss = ss->next) - { - ss->loop = loop; - - if (ss->info->type == GFC_SS_SCALAR - || ss->info->type == GFC_SS_REFERENCE - || ss->info->type == GFC_SS_TEMP) - continue; - - for (n = 0; n < GFC_MAX_DIMENSIONS; n++) - if (ss->info->data.array.subscript[n] != NULL) - set_ss_loop (ss->info->data.array.subscript[n], loop); - } -} - - -/* Associate a SS chain with a loop. */ - -void -gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head) -{ - gfc_ss *ss; - gfc_loopinfo *nested_loop; - - if (head == gfc_ss_terminator) - return; - - set_ss_loop (head, loop); - - ss = head; - for (; ss && ss != gfc_ss_terminator; ss = ss->next) - { - if (ss->nested_ss) - { - nested_loop = ss->nested_ss->loop; - - /* More than one ss can belong to the same loop. Hence, we add the - loop to the chain only if it is different from the previously - added one, to avoid duplicate nested loops. */ - if (nested_loop != loop->nested) - { - gcc_assert (nested_loop->parent == NULL); - nested_loop->parent = loop; - - gcc_assert (nested_loop->next == NULL); - nested_loop->next = loop->nested; - loop->nested = nested_loop; - } - else - gcc_assert (nested_loop->parent == loop); - } - - if (ss->next == gfc_ss_terminator) - ss->loop_chain = loop->ss; - else - ss->loop_chain = ss->next; - } - gcc_assert (ss == gfc_ss_terminator); - loop->ss = head; -} - - -/* Returns true if the expression is an array pointer. */ - -static bool -is_pointer_array (tree expr) -{ - if (expr == NULL_TREE - || !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr)) - || GFC_CLASS_TYPE_P (TREE_TYPE (expr))) - return false; - - if (TREE_CODE (expr) == VAR_DECL - && GFC_DECL_PTR_ARRAY_P (expr)) - return true; - - if (TREE_CODE (expr) == PARM_DECL - && GFC_DECL_PTR_ARRAY_P (expr)) - return true; - - if (TREE_CODE (expr) == INDIRECT_REF - && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 0))) - return true; - - /* The field declaration is marked as an pointer array. */ - if (TREE_CODE (expr) == COMPONENT_REF - && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 1)) - && !GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (expr, 1)))) - return true; - - return false; -} - - -/* 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) && GFC_DECL_SAVED_DESCRIPTOR (tmp)) - tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp); - - *desc = tmp; - return true; -} - - -/* Return the span of an array. */ - -tree -gfc_get_array_span (tree desc, gfc_expr *expr) -{ - tree tmp; - - if (is_pointer_array (desc) - || (get_CFI_desc (NULL, expr, &desc, NULL) - && (POINTER_TYPE_P (TREE_TYPE (desc)) - ? GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (desc))) - : GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))))) - { - 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 (expr->ts.type == BT_ASSUMED) - { - if (DECL_LANG_SPECIFIC (desc) && GFC_DECL_SAVED_DESCRIPTOR (desc)) - desc = GFC_DECL_SAVED_DESCRIPTOR (desc); - if (POINTER_TYPE_P (TREE_TYPE (desc))) - desc = build_fold_indirect_ref_loc (input_location, desc); - 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)))) - { - /* The descriptor is a class _data field and so use the vtable - size for the receiving span field. */ - tmp = gfc_get_vptr_from_expr (desc); - tmp = gfc_vptr_size_get (tmp); - } - else if (expr && expr->expr_type == EXPR_VARIABLE - && expr->symtree->n.sym->ts.type == BT_CLASS - && expr->ref->type == REF_COMPONENT - && expr->ref->next->type == REF_ARRAY - && expr->ref->next->next == NULL - && CLASS_DATA (expr->symtree->n.sym)->attr.dimension) - { - /* Dummys come in sometimes with the descriptor detached from - the class field or declaration. */ - tmp = gfc_class_vptr_get (expr->symtree->n.sym->backend_decl); - tmp = gfc_vptr_size_get (tmp); - } - else - { - /* If none of the fancy stuff works, the span is the element - size of the array. Attempt to deal with unbounded character - types if possible. Otherwise, return NULL_TREE. */ - tmp = gfc_get_element_type (TREE_TYPE (desc)); - if (tmp && TREE_CODE (tmp) == ARRAY_TYPE && TYPE_STRING_FLAG (tmp)) - { - gcc_assert (expr->ts.type == BT_CHARACTER); - - tmp = gfc_get_character_len_in_bytes (tmp); - - if (tmp == NULL_TREE || integer_zerop (tmp)) - { - tree bs; - - tmp = gfc_get_expr_charlen (expr); - tmp = fold_convert (gfc_array_index_type, tmp); - bs = build_int_cst (gfc_array_index_type, expr->ts.kind); - tmp = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, tmp, bs); - } - - tmp = (tmp && !integer_zerop (tmp)) - ? (fold_convert (gfc_array_index_type, tmp)) : (NULL_TREE); - } - else - tmp = fold_convert (gfc_array_index_type, - size_in_bytes (tmp)); - } - return tmp; -} - - -/* Generate an initializer for a static pointer or allocatable array. */ - -void -gfc_trans_static_array_pointer (gfc_symbol * sym) -{ - tree type; - - gcc_assert (TREE_STATIC (sym->backend_decl)); - /* Just zero the data member. */ - type = TREE_TYPE (sym->backend_decl); - DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type); -} - - -/* If the bounds of SE's loop have not yet been set, see if they can be - determined from array spec AS, which is the array spec of a called - function. MAPPING maps the callee's dummy arguments to the values - that the caller is passing. Add any initialization and finalization - code to SE. */ - -void -gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping, - gfc_se * se, gfc_array_spec * as) -{ - int n, dim, total_dim; - gfc_se tmpse; - gfc_ss *ss; - tree lower; - tree upper; - tree tmp; - - total_dim = 0; - - if (!as || as->type != AS_EXPLICIT) - return; - - for (ss = se->ss; ss; ss = ss->parent) - { - total_dim += ss->loop->dimen; - for (n = 0; n < ss->loop->dimen; n++) - { - /* The bound is known, nothing to do. */ - if (ss->loop->to[n] != NULL_TREE) - continue; - - dim = ss->dim[n]; - gcc_assert (dim < as->rank); - gcc_assert (ss->loop->dimen <= as->rank); - - /* Evaluate the lower bound. */ - gfc_init_se (&tmpse, NULL); - gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]); - gfc_add_block_to_block (&se->pre, &tmpse.pre); - gfc_add_block_to_block (&se->post, &tmpse.post); - lower = fold_convert (gfc_array_index_type, tmpse.expr); - - /* ...and the upper bound. */ - gfc_init_se (&tmpse, NULL); - gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]); - gfc_add_block_to_block (&se->pre, &tmpse.pre); - gfc_add_block_to_block (&se->post, &tmpse.post); - upper = fold_convert (gfc_array_index_type, tmpse.expr); - - /* Set the upper bound of the loop to UPPER - LOWER. */ - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, upper, lower); - tmp = gfc_evaluate_now (tmp, &se->pre); - ss->loop->to[n] = tmp; - } - } - - gcc_assert (total_dim == as->rank); -} - - -/* Generate code to allocate an array temporary, or create a variable to - hold the data. If size is NULL, zero the descriptor so that the - callee will allocate the array. If DEALLOC is true, also generate code to - free the array afterwards. - - If INITIAL is not NULL, it is packed using internal_pack and the result used - as data instead of allocating a fresh, unitialized area of memory. - - Initialization code is added to PRE and finalization code to POST. - DYNAMIC is true if the caller may want to extend the array later - using realloc. This prevents us from putting the array on the stack. */ - -static void -gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post, - gfc_array_info * info, tree size, tree nelem, - tree initial, bool dynamic, bool dealloc) -{ - tree tmp; - tree desc; - bool onstack; - - desc = info->descriptor; - info->offset = gfc_index_zero_node; - if (size == NULL_TREE || integer_zerop (size)) - { - /* A callee allocated array. */ - gfc_conv_descriptor_data_set (pre, desc, null_pointer_node); - onstack = FALSE; - } - else - { - /* Allocate the temporary. */ - onstack = !dynamic && initial == NULL_TREE - && (flag_stack_arrays - || gfc_can_put_var_on_stack (size)); - - if (onstack) - { - /* Make a temporary variable to hold the data. */ - tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (nelem), - nelem, gfc_index_one_node); - tmp = gfc_evaluate_now (tmp, pre); - tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, - tmp); - tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)), - tmp); - tmp = gfc_create_var (tmp, "A"); - /* If we're here only because of -fstack-arrays we have to - emit a DECL_EXPR to make the gimplifier emit alloca calls. */ - if (!gfc_can_put_var_on_stack (size)) - gfc_add_expr_to_block (pre, - fold_build1_loc (input_location, - DECL_EXPR, TREE_TYPE (tmp), - tmp)); - tmp = gfc_build_addr_expr (NULL_TREE, tmp); - gfc_conv_descriptor_data_set (pre, desc, tmp); - } - else - { - /* Allocate memory to hold the data or call internal_pack. */ - if (initial == NULL_TREE) - { - tmp = gfc_call_malloc (pre, NULL, size); - tmp = gfc_evaluate_now (tmp, pre); - } - else - { - tree packed; - tree source_data; - tree was_packed; - stmtblock_t do_copying; - - tmp = TREE_TYPE (initial); /* Pointer to descriptor. */ - gcc_assert (TREE_CODE (tmp) == POINTER_TYPE); - tmp = TREE_TYPE (tmp); /* The descriptor itself. */ - tmp = gfc_get_element_type (tmp); - packed = gfc_create_var (build_pointer_type (tmp), "data"); - - tmp = build_call_expr_loc (input_location, - gfor_fndecl_in_pack, 1, initial); - tmp = fold_convert (TREE_TYPE (packed), tmp); - gfc_add_modify (pre, packed, tmp); - - tmp = build_fold_indirect_ref_loc (input_location, - initial); - source_data = gfc_conv_descriptor_data_get (tmp); - - /* internal_pack may return source->data without any allocation - or copying if it is already packed. If that's the case, we - need to allocate and copy manually. */ - - gfc_start_block (&do_copying); - tmp = gfc_call_malloc (&do_copying, NULL, size); - tmp = fold_convert (TREE_TYPE (packed), tmp); - gfc_add_modify (&do_copying, packed, tmp); - tmp = gfc_build_memcpy_call (packed, source_data, size); - gfc_add_expr_to_block (&do_copying, tmp); - - was_packed = fold_build2_loc (input_location, EQ_EXPR, - logical_type_node, packed, - source_data); - tmp = gfc_finish_block (&do_copying); - tmp = build3_v (COND_EXPR, was_packed, tmp, - build_empty_stmt (input_location)); - gfc_add_expr_to_block (pre, tmp); - - tmp = fold_convert (pvoid_type_node, packed); - } - - gfc_conv_descriptor_data_set (pre, desc, tmp); - } - } - info->data = gfc_conv_descriptor_data_get (desc); - - /* The offset is zero because we create temporaries with a zero - lower bound. */ - gfc_conv_descriptor_offset_set (pre, desc, gfc_index_zero_node); - - if (dealloc && !onstack) - { - /* Free the temporary. */ - tmp = gfc_conv_descriptor_data_get (desc); - tmp = gfc_call_free (tmp); - gfc_add_expr_to_block (post, tmp); - } -} - - -/* Get the scalarizer array dimension corresponding to actual array dimension - given by ARRAY_DIM. - - For example, if SS represents the array ref a(1,:,:,1), it is a - bidimensional scalarizer array, and the result would be 0 for ARRAY_DIM=1, - and 1 for ARRAY_DIM=2. - If SS represents transpose(a(:,1,1,:)), it is again a bidimensional - scalarizer array, and the result would be 1 for ARRAY_DIM=0 and 0 for - ARRAY_DIM=3. - If SS represents sum(a(:,:,:,1), dim=1), it is a 2+1-dimensional scalarizer - array. If called on the inner ss, the result would be respectively 0,1,2 for - ARRAY_DIM=0,1,2. If called on the outer ss, the result would be 0,1 - for ARRAY_DIM=1,2. */ - -static int -get_scalarizer_dim_for_array_dim (gfc_ss *ss, int array_dim) -{ - int array_ref_dim; - int n; - - array_ref_dim = 0; - - for (; ss; ss = ss->parent) - for (n = 0; n < ss->dimen; n++) - if (ss->dim[n] < array_dim) - array_ref_dim++; - - return array_ref_dim; -} - - -static gfc_ss * -innermost_ss (gfc_ss *ss) -{ - while (ss->nested_ss != NULL) - ss = ss->nested_ss; - - return ss; -} - - - -/* Get the array reference dimension corresponding to the given loop dimension. - It is different from the true array dimension given by the dim array in - the case of a partial array reference (i.e. a(:,:,1,:) for example) - It is different from the loop dimension in the case of a transposed array. - */ - -static int -get_array_ref_dim_for_loop_dim (gfc_ss *ss, int loop_dim) -{ - return get_scalarizer_dim_for_array_dim (innermost_ss (ss), - ss->dim[loop_dim]); -} - - -/* Use the information in the ss to obtain the required information about - the type and size of an array temporary, when the lhs in an assignment - is a class expression. */ - -static tree -get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype) -{ - gfc_ss *lhs_ss; - gfc_ss *rhs_ss; - tree tmp; - tree tmp2; - tree vptr; - tree rhs_class_expr = NULL_TREE; - tree lhs_class_expr = NULL_TREE; - bool unlimited_rhs = false; - bool unlimited_lhs = false; - bool rhs_function = false; - gfc_symbol *vtab; - - /* The second element in the loop chain contains the source for the - temporary; ie. the rhs of the assignment. */ - rhs_ss = ss->loop->ss->loop_chain; - - if (rhs_ss != gfc_ss_terminator - && rhs_ss->info - && rhs_ss->info->expr - && rhs_ss->info->expr->ts.type == BT_CLASS - && rhs_ss->info->data.array.descriptor) - { - if (rhs_ss->info->expr->expr_type != EXPR_VARIABLE) - rhs_class_expr - = gfc_get_class_from_expr (rhs_ss->info->data.array.descriptor); - else - rhs_class_expr = gfc_get_class_from_gfc_expr (rhs_ss->info->expr); - unlimited_rhs = UNLIMITED_POLY (rhs_ss->info->expr); - if (rhs_ss->info->expr->expr_type == EXPR_FUNCTION) - rhs_function = true; - } - - /* For an assignment the lhs is the next element in the loop chain. - If we have a class rhs, this had better be a class variable - expression! */ - lhs_ss = rhs_ss->loop_chain; - if (lhs_ss != gfc_ss_terminator - && lhs_ss->info - && lhs_ss->info->expr - && lhs_ss->info->expr->expr_type ==EXPR_VARIABLE - && lhs_ss->info->expr->ts.type == BT_CLASS) - { - tmp = lhs_ss->info->data.array.descriptor; - unlimited_lhs = UNLIMITED_POLY (rhs_ss->info->expr); - } - else - tmp = NULL_TREE; - - /* Get the lhs class expression. */ - if (tmp != NULL_TREE && lhs_ss->loop_chain == gfc_ss_terminator) - lhs_class_expr = gfc_get_class_from_expr (tmp); - else - return rhs_class_expr; - - gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (lhs_class_expr))); - - /* Set the lhs vptr and, if necessary, the _len field. */ - if (rhs_class_expr) - { - /* Both lhs and rhs are class expressions. */ - tmp = gfc_class_vptr_get (lhs_class_expr); - gfc_add_modify (pre, tmp, - fold_convert (TREE_TYPE (tmp), - gfc_class_vptr_get (rhs_class_expr))); - if (unlimited_lhs) - { - tmp = gfc_class_len_get (lhs_class_expr); - if (unlimited_rhs) - tmp2 = gfc_class_len_get (rhs_class_expr); - else - tmp2 = build_int_cst (TREE_TYPE (tmp), 0); - gfc_add_modify (pre, tmp, tmp2); - } - - if (rhs_function) - { - tmp = gfc_class_data_get (rhs_class_expr); - gfc_conv_descriptor_offset_set (pre, tmp, gfc_index_zero_node); - } - } - else - { - /* lhs is class and rhs is intrinsic or derived type. */ - *eltype = TREE_TYPE (rhs_ss->info->data.array.descriptor); - *eltype = gfc_get_element_type (*eltype); - vtab = gfc_find_vtab (&rhs_ss->info->expr->ts); - vptr = vtab->backend_decl; - if (vptr == NULL_TREE) - vptr = gfc_get_symbol_decl (vtab); - vptr = gfc_build_addr_expr (NULL_TREE, vptr); - tmp = gfc_class_vptr_get (lhs_class_expr); - gfc_add_modify (pre, tmp, - fold_convert (TREE_TYPE (tmp), vptr)); - - if (unlimited_lhs) - { - tmp = gfc_class_len_get (lhs_class_expr); - if (rhs_ss->info - && rhs_ss->info->expr - && rhs_ss->info->expr->ts.type == BT_CHARACTER) - tmp2 = build_int_cst (TREE_TYPE (tmp), - rhs_ss->info->expr->ts.kind); - else - tmp2 = build_int_cst (TREE_TYPE (tmp), 0); - gfc_add_modify (pre, tmp, tmp2); - } - } - - return rhs_class_expr; -} - - - -/* Generate code to create and initialize the descriptor for a temporary - array. This is used for both temporaries needed by the scalarizer, and - functions returning arrays. Adjusts the loop variables to be - zero-based, and calculates the loop bounds for callee allocated arrays. - Allocate the array unless it's callee allocated (we have a callee - allocated array if 'callee_alloc' is true, or if loop->to[n] is - NULL_TREE for any n). Also fills in the descriptor, data and offset - fields of info if known. Returns the size of the array, or NULL for a - callee allocated array. - - 'eltype' == NULL signals that the temporary should be a class object. - The 'initial' expression is used to obtain the size of the dynamic - type; otherwise the allocation and initialization proceeds as for any - other expression - - PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for - gfc_trans_allocate_array_storage. */ - -tree -gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss, - tree eltype, tree initial, bool dynamic, - bool dealloc, bool callee_alloc, locus * where) -{ - gfc_loopinfo *loop; - gfc_ss *s; - gfc_array_info *info; - tree from[GFC_MAX_DIMENSIONS], to[GFC_MAX_DIMENSIONS]; - tree type; - tree desc; - tree tmp; - tree size; - tree nelem; - tree cond; - tree or_expr; - tree elemsize; - tree class_expr = NULL_TREE; - int n, dim, tmp_dim; - int total_dim = 0; - - /* This signals a class array for which we need the size of the - dynamic type. Generate an eltype and then the class expression. */ - if (eltype == NULL_TREE && initial) - { - gcc_assert (POINTER_TYPE_P (TREE_TYPE (initial))); - class_expr = build_fold_indirect_ref_loc (input_location, initial); - /* Obtain the structure (class) expression. */ - class_expr = gfc_get_class_from_expr (class_expr); - gcc_assert (class_expr); - } - - /* Otherwise, some expressions, such as class functions, arising from - dependency checking in assignments come here with class element type. - The descriptor can be obtained from the ss->info and then converted - to the class object. */ - if (class_expr == NULL_TREE && GFC_CLASS_TYPE_P (eltype)) - class_expr = get_class_info_from_ss (pre, ss, &eltype); - - /* If the dynamic type is not available, use the declared type. */ - if (eltype && GFC_CLASS_TYPE_P (eltype)) - eltype = gfc_get_element_type (TREE_TYPE (TYPE_FIELDS (eltype))); - - if (class_expr == NULL_TREE) - elemsize = fold_convert (gfc_array_index_type, - TYPE_SIZE_UNIT (eltype)); - else - { - /* Unlimited polymorphic entities are initialised with NULL vptr. They - can be tested for by checking if the len field is present. If so - test the vptr before using the vtable size. */ - tmp = gfc_class_vptr_get (class_expr); - tmp = fold_build2_loc (input_location, NE_EXPR, - logical_type_node, - tmp, build_int_cst (TREE_TYPE (tmp), 0)); - elemsize = fold_build3_loc (input_location, COND_EXPR, - gfc_array_index_type, - tmp, - gfc_class_vtab_size_get (class_expr), - gfc_index_zero_node); - elemsize = gfc_evaluate_now (elemsize, pre); - elemsize = gfc_resize_class_size_with_len (pre, class_expr, elemsize); - /* Casting the data as a character of the dynamic length ensures that - assignment of elements works when needed. */ - eltype = gfc_get_character_type_len (1, elemsize); - } - - memset (from, 0, sizeof (from)); - memset (to, 0, sizeof (to)); - - info = &ss->info->data.array; - - gcc_assert (ss->dimen > 0); - gcc_assert (ss->loop->dimen == ss->dimen); - - if (warn_array_temporaries && where) - gfc_warning (OPT_Warray_temporaries, - "Creating array temporary at %L", where); - - /* Set the lower bound to zero. */ - for (s = ss; s; s = s->parent) - { - loop = s->loop; - - total_dim += loop->dimen; - for (n = 0; n < loop->dimen; n++) - { - dim = s->dim[n]; - - /* Callee allocated arrays may not have a known bound yet. */ - if (loop->to[n]) - loop->to[n] = gfc_evaluate_now ( - fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - loop->to[n], loop->from[n]), - pre); - loop->from[n] = gfc_index_zero_node; - - /* We have just changed the loop bounds, we must clear the - corresponding specloop, so that delta calculation is not skipped - later in gfc_set_delta. */ - loop->specloop[n] = NULL; - - /* We are constructing the temporary's descriptor based on the loop - dimensions. As the dimensions may be accessed in arbitrary order - (think of transpose) the size taken from the n'th loop may not map - to the n'th dimension of the array. We need to reconstruct loop - infos in the right order before using it to set the descriptor - bounds. */ - tmp_dim = get_scalarizer_dim_for_array_dim (ss, dim); - from[tmp_dim] = loop->from[n]; - to[tmp_dim] = loop->to[n]; - - info->delta[dim] = gfc_index_zero_node; - info->start[dim] = gfc_index_zero_node; - info->end[dim] = gfc_index_zero_node; - info->stride[dim] = gfc_index_one_node; - } - } - - /* Initialize the descriptor. */ - type = - gfc_get_array_type_bounds (eltype, total_dim, 0, from, to, 1, - GFC_ARRAY_UNKNOWN, true); - desc = gfc_create_var (type, "atmp"); - GFC_DECL_PACKED_ARRAY (desc) = 1; - - /* Emit a DECL_EXPR for the variable sized array type in - GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type - sizes works correctly. */ - tree arraytype = TREE_TYPE (GFC_TYPE_ARRAY_DATAPTR_TYPE (type)); - if (! TYPE_NAME (arraytype)) - TYPE_NAME (arraytype) = build_decl (UNKNOWN_LOCATION, TYPE_DECL, - NULL_TREE, arraytype); - gfc_add_expr_to_block (pre, build1 (DECL_EXPR, - arraytype, TYPE_NAME (arraytype))); - - if (class_expr != NULL_TREE) - { - tree class_data; - tree dtype; - - /* Create a class temporary. */ - tmp = gfc_create_var (TREE_TYPE (class_expr), "ctmp"); - gfc_add_modify (pre, tmp, class_expr); - - /* Assign the new descriptor to the _data field. This allows the - vptr _copy to be used for scalarized assignment since the class - temporary can be found from the descriptor. */ - class_data = gfc_class_data_get (tmp); - tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR, - TREE_TYPE (desc), desc); - gfc_add_modify (pre, class_data, tmp); - - /* Take the dtype from the class expression. */ - dtype = gfc_conv_descriptor_dtype (gfc_class_data_get (class_expr)); - tmp = gfc_conv_descriptor_dtype (class_data); - gfc_add_modify (pre, tmp, dtype); - - /* Point desc to the class _data field. */ - desc = class_data; - } - else - { - /* Fill in the array dtype. */ - tmp = gfc_conv_descriptor_dtype (desc); - gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc))); - } - - info->descriptor = desc; - size = gfc_index_one_node; - - /* - Fill in the bounds and stride. This is a packed array, so: - - size = 1; - for (n = 0; n < rank; n++) - { - stride[n] = size - delta = ubound[n] + 1 - lbound[n]; - size = size * delta; - } - size = size * sizeof(element); - */ - - or_expr = NULL_TREE; - - /* If there is at least one null loop->to[n], it is a callee allocated - array. */ - for (n = 0; n < total_dim; n++) - if (to[n] == NULL_TREE) - { - size = NULL_TREE; - break; - } - - if (size == NULL_TREE) - for (s = ss; s; s = s->parent) - for (n = 0; n < s->loop->dimen; n++) - { - dim = get_scalarizer_dim_for_array_dim (ss, s->dim[n]); - - /* For a callee allocated array express the loop bounds in terms - of the descriptor fields. */ - tmp = fold_build2_loc (input_location, - MINUS_EXPR, gfc_array_index_type, - gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]), - gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim])); - s->loop->to[n] = tmp; - } - else - { - for (n = 0; n < total_dim; n++) - { - /* Store the stride and bound components in the descriptor. */ - gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size); - - gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n], - gfc_index_zero_node); - - gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], to[n]); - - tmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, - to[n], gfc_index_one_node); - - /* Check whether the size for this dimension is negative. */ - cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, - tmp, gfc_index_zero_node); - cond = gfc_evaluate_now (cond, pre); - - if (n == 0) - or_expr = cond; - else - or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR, - logical_type_node, or_expr, cond); - - size = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, size, tmp); - size = gfc_evaluate_now (size, pre); - } - } - - /* 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); - } - else - { - nelem = size; - 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); - - while (ss->parent) - ss = ss->parent; - - if (ss->dimen > ss->loop->temp_dim) - ss->loop->temp_dim = ss->dimen; - - return size; -} - - -/* Return the number of iterations in a loop that starts at START, - ends at END, and has step STEP. */ - -static tree -gfc_get_iteration_count (tree start, tree end, tree step) -{ - tree tmp; - tree type; - - type = TREE_TYPE (step); - tmp = fold_build2_loc (input_location, MINUS_EXPR, type, end, start); - tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, type, tmp, step); - tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, - build_int_cst (type, 1)); - tmp = fold_build2_loc (input_location, MAX_EXPR, type, tmp, - build_int_cst (type, 0)); - return fold_convert (gfc_array_index_type, tmp); -} - - -/* Extend the data in array DESC by EXTRA elements. */ - -static void -gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra) -{ - tree arg0, arg1; - tree tmp; - tree size; - tree ubound; - - if (integer_zerop (extra)) - return; - - ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]); - - /* Add EXTRA to the upper bound. */ - tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - ubound, extra); - gfc_conv_descriptor_ubound_set (pblock, desc, gfc_rank_cst[0], tmp); - - /* Get the value of the current data pointer. */ - arg0 = gfc_conv_descriptor_data_get (desc); - - /* Calculate the new array size. */ - size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc))); - tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - ubound, gfc_index_one_node); - arg1 = fold_build2_loc (input_location, MULT_EXPR, size_type_node, - fold_convert (size_type_node, tmp), - fold_convert (size_type_node, size)); - - /* Call the realloc() function. */ - tmp = gfc_call_realloc (pblock, arg0, arg1); - gfc_conv_descriptor_data_set (pblock, desc, tmp); -} - - -/* Return true if the bounds of iterator I can only be determined - at run time. */ - -static inline bool -gfc_iterator_has_dynamic_bounds (gfc_iterator * i) -{ - return (i->start->expr_type != EXPR_CONSTANT - || i->end->expr_type != EXPR_CONSTANT - || i->step->expr_type != EXPR_CONSTANT); -} - - -/* Split the size of constructor element EXPR into the sum of two terms, - one of which can be determined at compile time and one of which must - be calculated at run time. Set *SIZE to the former and return true - if the latter might be nonzero. */ - -static bool -gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr) -{ - if (expr->expr_type == EXPR_ARRAY) - return gfc_get_array_constructor_size (size, expr->value.constructor); - else if (expr->rank > 0) - { - /* Calculate everything at run time. */ - mpz_set_ui (*size, 0); - return true; - } - else - { - /* A single element. */ - mpz_set_ui (*size, 1); - return false; - } -} - - -/* Like gfc_get_array_constructor_element_size, but applied to the whole - of array constructor C. */ - -static bool -gfc_get_array_constructor_size (mpz_t * size, gfc_constructor_base base) -{ - gfc_constructor *c; - gfc_iterator *i; - mpz_t val; - mpz_t len; - bool dynamic; - - mpz_set_ui (*size, 0); - mpz_init (len); - mpz_init (val); - - dynamic = false; - for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) - { - i = c->iterator; - if (i && gfc_iterator_has_dynamic_bounds (i)) - dynamic = true; - else - { - dynamic |= gfc_get_array_constructor_element_size (&len, c->expr); - if (i) - { - /* Multiply the static part of the element size by the - number of iterations. */ - mpz_sub (val, i->end->value.integer, i->start->value.integer); - mpz_fdiv_q (val, val, i->step->value.integer); - mpz_add_ui (val, val, 1); - if (mpz_sgn (val) > 0) - mpz_mul (len, len, val); - else - mpz_set_ui (len, 0); - } - mpz_add (*size, *size, len); - } - } - mpz_clear (len); - mpz_clear (val); - return dynamic; -} - - -/* Make sure offset is a variable. */ - -static void -gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset, - tree * offsetvar) -{ - /* We should have already created the offset variable. We cannot - create it here because we may be in an inner scope. */ - gcc_assert (*offsetvar != NULL_TREE); - gfc_add_modify (pblock, *offsetvar, *poffset); - *poffset = *offsetvar; - TREE_USED (*offsetvar) = 1; -} - - -/* Variables needed for bounds-checking. */ -static bool first_len; -static tree first_len_val; -static bool typespec_chararray_ctor; - -static void -gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc, - tree offset, gfc_se * se, gfc_expr * expr) -{ - tree tmp; - - gfc_conv_expr (se, expr); - - /* Store the value. */ - tmp = build_fold_indirect_ref_loc (input_location, - gfc_conv_descriptor_data_get (desc)); - tmp = gfc_build_array_ref (tmp, offset, NULL); - - if (expr->ts.type == BT_CHARACTER) - { - int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false); - tree esize; - - esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc))); - esize = fold_convert (gfc_charlen_type_node, esize); - esize = fold_build2_loc (input_location, TRUNC_DIV_EXPR, - TREE_TYPE (esize), esize, - build_int_cst (TREE_TYPE (esize), - gfc_character_kinds[i].bit_size / 8)); - - gfc_conv_string_parameter (se); - if (POINTER_TYPE_P (TREE_TYPE (tmp))) - { - /* The temporary is an array of pointers. */ - se->expr = fold_convert (TREE_TYPE (tmp), se->expr); - gfc_add_modify (&se->pre, tmp, se->expr); - } - else - { - /* The temporary is an array of string values. */ - tmp = gfc_build_addr_expr (gfc_get_pchar_type (expr->ts.kind), tmp); - /* We know the temporary and the value will be the same length, - so can use memcpy. */ - gfc_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind, - se->string_length, se->expr, expr->ts.kind); - } - if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !typespec_chararray_ctor) - { - if (first_len) - { - gfc_add_modify (&se->pre, first_len_val, - fold_convert (TREE_TYPE (first_len_val), - se->string_length)); - first_len = false; - } - else - { - /* Verify that all constructor elements are of the same - length. */ - tree rhs = fold_convert (TREE_TYPE (first_len_val), - se->string_length); - tree cond = fold_build2_loc (input_location, NE_EXPR, - logical_type_node, first_len_val, - rhs); - gfc_trans_runtime_check - (true, false, cond, &se->pre, &expr->where, - "Different CHARACTER lengths (%ld/%ld) in array constructor", - fold_convert (long_integer_type_node, first_len_val), - fold_convert (long_integer_type_node, se->string_length)); - } - } - } - else if (GFC_CLASS_TYPE_P (TREE_TYPE (se->expr)) - && !GFC_CLASS_TYPE_P (gfc_get_element_type (TREE_TYPE (desc)))) - { - /* Assignment of a CLASS array constructor to a derived type array. */ - if (expr->expr_type == EXPR_FUNCTION) - se->expr = gfc_evaluate_now (se->expr, pblock); - se->expr = gfc_class_data_get (se->expr); - se->expr = build_fold_indirect_ref_loc (input_location, se->expr); - se->expr = fold_convert (TREE_TYPE (tmp), se->expr); - gfc_add_modify (&se->pre, tmp, se->expr); - } - else - { - /* TODO: Should the frontend already have done this conversion? */ - se->expr = fold_convert (TREE_TYPE (tmp), se->expr); - gfc_add_modify (&se->pre, tmp, se->expr); - } - - gfc_add_block_to_block (pblock, &se->pre); - gfc_add_block_to_block (pblock, &se->post); -} - - -/* Add the contents of an array to the constructor. DYNAMIC is as for - gfc_trans_array_constructor_value. */ - -static void -gfc_trans_array_constructor_subarray (stmtblock_t * pblock, - tree type ATTRIBUTE_UNUSED, - tree desc, gfc_expr * expr, - tree * poffset, tree * offsetvar, - bool dynamic) -{ - gfc_se se; - gfc_ss *ss; - gfc_loopinfo loop; - stmtblock_t body; - tree tmp; - tree size; - int n; - - /* We need this to be a variable so we can increment it. */ - gfc_put_offset_into_var (pblock, poffset, offsetvar); - - gfc_init_se (&se, NULL); - - /* Walk the array expression. */ - ss = gfc_walk_expr (expr); - gcc_assert (ss != gfc_ss_terminator); - - /* Initialize the scalarizer. */ - gfc_init_loopinfo (&loop); - gfc_add_ss_to_loop (&loop, ss); - - /* Initialize the loop. */ - gfc_conv_ss_startstride (&loop); - gfc_conv_loop_setup (&loop, &expr->where); - - /* Make sure the constructed array has room for the new data. */ - if (dynamic) - { - /* Set SIZE to the total number of elements in the subarray. */ - size = gfc_index_one_node; - for (n = 0; n < loop.dimen; n++) - { - tmp = gfc_get_iteration_count (loop.from[n], loop.to[n], - gfc_index_one_node); - size = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, size, tmp); - } - - /* Grow the constructed array by SIZE elements. */ - gfc_grow_array (&loop.pre, desc, size); - } - - /* Make the loop body. */ - gfc_mark_ss_chain_used (ss, 1); - gfc_start_scalarized_body (&loop, &body); - gfc_copy_loopinfo_to_se (&se, &loop); - se.ss = ss; - - gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr); - gcc_assert (se.ss == gfc_ss_terminator); - - /* Increment the offset. */ - tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - *poffset, gfc_index_one_node); - gfc_add_modify (&body, *poffset, tmp); - - /* Finish the loop. */ - gfc_trans_scalarizing_loops (&loop, &body); - gfc_add_block_to_block (&loop.pre, &loop.post); - tmp = gfc_finish_block (&loop.pre); - gfc_add_expr_to_block (pblock, tmp); - - gfc_cleanup_loop (&loop); -} - - -/* Assign the values to the elements of an array constructor. DYNAMIC - is true if descriptor DESC only contains enough data for the static - size calculated by gfc_get_array_constructor_size. When true, memory - for the dynamic parts must be allocated using realloc. */ - -static void -gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type, - tree desc, gfc_constructor_base base, - tree * poffset, tree * offsetvar, - bool dynamic) -{ - tree tmp; - tree start = NULL_TREE; - tree end = NULL_TREE; - tree step = NULL_TREE; - stmtblock_t body; - gfc_se se; - mpz_t size; - gfc_constructor *c; - - tree shadow_loopvar = NULL_TREE; - gfc_saved_var saved_loopvar; - - mpz_init (size); - for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) - { - /* If this is an iterator or an array, the offset must be a variable. */ - if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset)) - gfc_put_offset_into_var (pblock, poffset, offsetvar); - - /* Shadowing the iterator avoids changing its value and saves us from - keeping track of it. Further, it makes sure that there's always a - backend-decl for the symbol, even if there wasn't one before, - e.g. in the case of an iterator that appears in a specification - expression in an interface mapping. */ - if (c->iterator) - { - gfc_symbol *sym; - tree type; - - /* Evaluate loop bounds before substituting the loop variable - in case they depend on it. Such a case is invalid, but it is - not more expensive to do the right thing here. - See PR 44354. */ - gfc_init_se (&se, NULL); - gfc_conv_expr_val (&se, c->iterator->start); - gfc_add_block_to_block (pblock, &se.pre); - start = gfc_evaluate_now (se.expr, pblock); - - gfc_init_se (&se, NULL); - gfc_conv_expr_val (&se, c->iterator->end); - gfc_add_block_to_block (pblock, &se.pre); - end = gfc_evaluate_now (se.expr, pblock); - - gfc_init_se (&se, NULL); - gfc_conv_expr_val (&se, c->iterator->step); - gfc_add_block_to_block (pblock, &se.pre); - step = gfc_evaluate_now (se.expr, pblock); - - sym = c->iterator->var->symtree->n.sym; - type = gfc_typenode_for_spec (&sym->ts); - - shadow_loopvar = gfc_create_var (type, "shadow_loopvar"); - gfc_shadow_sym (sym, shadow_loopvar, &saved_loopvar); - } - - gfc_start_block (&body); - - if (c->expr->expr_type == EXPR_ARRAY) - { - /* Array constructors can be nested. */ - gfc_trans_array_constructor_value (&body, type, desc, - c->expr->value.constructor, - poffset, offsetvar, dynamic); - } - else if (c->expr->rank > 0) - { - gfc_trans_array_constructor_subarray (&body, type, desc, c->expr, - poffset, offsetvar, dynamic); - } - else - { - /* This code really upsets the gimplifier so don't bother for now. */ - gfc_constructor *p; - HOST_WIDE_INT n; - HOST_WIDE_INT size; - - p = c; - n = 0; - while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT)) - { - p = gfc_constructor_next (p); - n++; - } - if (n < 4) - { - /* Scalar values. */ - gfc_init_se (&se, NULL); - gfc_trans_array_ctor_element (&body, desc, *poffset, - &se, c->expr); - - *poffset = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, - *poffset, gfc_index_one_node); - } - else - { - /* Collect multiple scalar constants into a constructor. */ - vec *v = NULL; - tree init; - tree bound; - tree tmptype; - HOST_WIDE_INT idx = 0; - - p = c; - /* Count the number of consecutive scalar constants. */ - while (p && !(p->iterator - || p->expr->expr_type != EXPR_CONSTANT)) - { - gfc_init_se (&se, NULL); - gfc_conv_constant (&se, p->expr); - - if (c->expr->ts.type != BT_CHARACTER) - se.expr = fold_convert (type, se.expr); - /* For constant character array constructors we build - an array of pointers. */ - else if (POINTER_TYPE_P (type)) - se.expr = gfc_build_addr_expr - (gfc_get_pchar_type (p->expr->ts.kind), - se.expr); - - CONSTRUCTOR_APPEND_ELT (v, - build_int_cst (gfc_array_index_type, - idx++), - se.expr); - c = p; - p = gfc_constructor_next (p); - } - - bound = size_int (n - 1); - /* Create an array type to hold them. */ - tmptype = build_range_type (gfc_array_index_type, - gfc_index_zero_node, bound); - tmptype = build_array_type (type, tmptype); - - init = build_constructor (tmptype, v); - TREE_CONSTANT (init) = 1; - TREE_STATIC (init) = 1; - /* Create a static variable to hold the data. */ - tmp = gfc_create_var (tmptype, "data"); - TREE_STATIC (tmp) = 1; - TREE_CONSTANT (tmp) = 1; - TREE_READONLY (tmp) = 1; - DECL_INITIAL (tmp) = init; - init = tmp; - - /* Use BUILTIN_MEMCPY to assign the values. */ - tmp = gfc_conv_descriptor_data_get (desc); - tmp = build_fold_indirect_ref_loc (input_location, - tmp); - tmp = gfc_build_array_ref (tmp, *poffset, NULL); - tmp = gfc_build_addr_expr (NULL_TREE, tmp); - init = gfc_build_addr_expr (NULL_TREE, init); - - size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type)); - bound = build_int_cst (size_type_node, n * size); - tmp = build_call_expr_loc (input_location, - builtin_decl_explicit (BUILT_IN_MEMCPY), - 3, tmp, init, bound); - gfc_add_expr_to_block (&body, tmp); - - *poffset = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, *poffset, - build_int_cst (gfc_array_index_type, n)); - } - if (!INTEGER_CST_P (*poffset)) - { - gfc_add_modify (&body, *offsetvar, *poffset); - *poffset = *offsetvar; - } - } - - /* The frontend should already have done any expansions - at compile-time. */ - if (!c->iterator) - { - /* Pass the code as is. */ - tmp = gfc_finish_block (&body); - gfc_add_expr_to_block (pblock, tmp); - } - else - { - /* Build the implied do-loop. */ - stmtblock_t implied_do_block; - tree cond; - tree exit_label; - tree loopbody; - tree tmp2; - - loopbody = gfc_finish_block (&body); - - /* Create a new block that holds the implied-do loop. A temporary - loop-variable is used. */ - gfc_start_block(&implied_do_block); - - /* Initialize the loop. */ - gfc_add_modify (&implied_do_block, shadow_loopvar, start); - - /* If this array expands dynamically, and the number of iterations - is not constant, we won't have allocated space for the static - part of C->EXPR's size. Do that now. */ - if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator)) - { - /* Get the number of iterations. */ - tmp = gfc_get_iteration_count (shadow_loopvar, end, step); - - /* Get the static part of C->EXPR's size. */ - gfc_get_array_constructor_element_size (&size, c->expr); - tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind); - - /* Grow the array by TMP * TMP2 elements. */ - tmp = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, tmp, tmp2); - gfc_grow_array (&implied_do_block, desc, tmp); - } - - /* Generate the loop body. */ - exit_label = gfc_build_label_decl (NULL_TREE); - gfc_start_block (&body); - - /* Generate the exit condition. Depending on the sign of - the step variable we have to generate the correct - comparison. */ - tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node, - step, build_int_cst (TREE_TYPE (step), 0)); - cond = fold_build3_loc (input_location, COND_EXPR, - logical_type_node, tmp, - fold_build2_loc (input_location, GT_EXPR, - logical_type_node, shadow_loopvar, end), - fold_build2_loc (input_location, LT_EXPR, - logical_type_node, shadow_loopvar, end)); - tmp = build1_v (GOTO_EXPR, exit_label); - TREE_USED (exit_label) = 1; - tmp = build3_v (COND_EXPR, cond, tmp, - build_empty_stmt (input_location)); - gfc_add_expr_to_block (&body, tmp); - - /* The main loop body. */ - gfc_add_expr_to_block (&body, loopbody); - - /* Increase loop variable by step. */ - tmp = fold_build2_loc (input_location, PLUS_EXPR, - TREE_TYPE (shadow_loopvar), shadow_loopvar, - step); - gfc_add_modify (&body, shadow_loopvar, tmp); - - /* Finish the loop. */ - tmp = gfc_finish_block (&body); - tmp = build1_v (LOOP_EXPR, tmp); - gfc_add_expr_to_block (&implied_do_block, tmp); - - /* Add the exit label. */ - tmp = build1_v (LABEL_EXPR, exit_label); - gfc_add_expr_to_block (&implied_do_block, tmp); - - /* Finish the implied-do loop. */ - tmp = gfc_finish_block(&implied_do_block); - gfc_add_expr_to_block(pblock, tmp); - - gfc_restore_sym (c->iterator->var->symtree->n.sym, &saved_loopvar); - } - } - mpz_clear (size); -} - - -/* The array constructor code can create a string length with an operand - in the form of a temporary variable. This variable will retain its - context (current_function_decl). If we store this length tree in a - gfc_charlen structure which is shared by a variable in another - context, the resulting gfc_charlen structure with a variable in a - different context, we could trip the assertion in expand_expr_real_1 - when it sees that a variable has been created in one context and - referenced in another. - - If this might be the case, we create a new gfc_charlen structure and - link it into the current namespace. */ - -static void -store_backend_decl (gfc_charlen **clp, tree len, bool force_new_cl) -{ - if (force_new_cl) - { - gfc_charlen *new_cl = gfc_new_charlen (gfc_current_ns, *clp); - *clp = new_cl; - } - (*clp)->backend_decl = len; -} - -/* A catch-all to obtain the string length for anything that is not - a substring of non-constant length, a constant, array or variable. */ - -static void -get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len) -{ - gfc_se se; - - /* Don't bother if we already know the length is a constant. */ - if (*len && INTEGER_CST_P (*len)) - return; - - if (!e->ref && e->ts.u.cl && e->ts.u.cl->length - && e->ts.u.cl->length->expr_type == EXPR_CONSTANT) - { - /* This is easy. */ - gfc_conv_const_charlen (e->ts.u.cl); - *len = e->ts.u.cl->backend_decl; - } - else - { - /* Otherwise, be brutal even if inefficient. */ - gfc_init_se (&se, NULL); - - /* No function call, in case of side effects. */ - se.no_function_call = 1; - if (e->rank == 0) - gfc_conv_expr (&se, e); - else - gfc_conv_expr_descriptor (&se, e); - - /* Fix the value. */ - *len = gfc_evaluate_now (se.string_length, &se.pre); - - gfc_add_block_to_block (block, &se.pre); - gfc_add_block_to_block (block, &se.post); - - store_backend_decl (&e->ts.u.cl, *len, true); - } -} - - -/* Figure out the string length of a variable reference expression. - Used by get_array_ctor_strlen. */ - -static void -get_array_ctor_var_strlen (stmtblock_t *block, gfc_expr * expr, tree * len) -{ - gfc_ref *ref; - gfc_typespec *ts; - mpz_t char_len; - gfc_se se; - - /* Don't bother if we already know the length is a constant. */ - if (*len && INTEGER_CST_P (*len)) - return; - - ts = &expr->symtree->n.sym->ts; - for (ref = expr->ref; ref; ref = ref->next) - { - switch (ref->type) - { - case REF_ARRAY: - /* Array references don't change the string length. */ - if (ts->deferred) - get_array_ctor_all_strlen (block, expr, len); - break; - - case REF_COMPONENT: - /* Use the length of the component. */ - ts = &ref->u.c.component->ts; - break; - - case REF_SUBSTRING: - if (ref->u.ss.end == NULL - || ref->u.ss.start->expr_type != EXPR_CONSTANT - || ref->u.ss.end->expr_type != EXPR_CONSTANT) - { - /* Note that this might evaluate expr. */ - get_array_ctor_all_strlen (block, expr, len); - return; - } - mpz_init_set_ui (char_len, 1); - mpz_add (char_len, char_len, ref->u.ss.end->value.integer); - mpz_sub (char_len, char_len, ref->u.ss.start->value.integer); - *len = gfc_conv_mpz_to_tree_type (char_len, gfc_charlen_type_node); - mpz_clear (char_len); - return; - - case REF_INQUIRY: - break; - - default: - gcc_unreachable (); - } - } - - /* A last ditch attempt that is sometimes needed for deferred characters. */ - if (!ts->u.cl->backend_decl) - { - gfc_init_se (&se, NULL); - if (expr->rank) - gfc_conv_expr_descriptor (&se, expr); - else - gfc_conv_expr (&se, expr); - gcc_assert (se.string_length != NULL_TREE); - gfc_add_block_to_block (block, &se.pre); - ts->u.cl->backend_decl = se.string_length; - } - - *len = ts->u.cl->backend_decl; -} - - -/* Figure out the string length of a character array constructor. - If len is NULL, don't calculate the length; this happens for recursive calls - when a sub-array-constructor is an element but not at the first position, - so when we're not interested in the length. - Returns TRUE if all elements are character constants. */ - -bool -get_array_ctor_strlen (stmtblock_t *block, gfc_constructor_base base, tree * len) -{ - gfc_constructor *c; - bool is_const; - - is_const = TRUE; - - if (gfc_constructor_first (base) == NULL) - { - if (len) - *len = build_int_cstu (gfc_charlen_type_node, 0); - return is_const; - } - - /* Loop over all constructor elements to find out is_const, but in len we - want to store the length of the first, not the last, element. We can - of course exit the loop as soon as is_const is found to be false. */ - for (c = gfc_constructor_first (base); - c && is_const; c = gfc_constructor_next (c)) - { - switch (c->expr->expr_type) - { - case EXPR_CONSTANT: - if (len && !(*len && INTEGER_CST_P (*len))) - *len = build_int_cstu (gfc_charlen_type_node, - c->expr->value.character.length); - break; - - case EXPR_ARRAY: - if (!get_array_ctor_strlen (block, c->expr->value.constructor, len)) - is_const = false; - break; - - case EXPR_VARIABLE: - is_const = false; - if (len) - get_array_ctor_var_strlen (block, c->expr, len); - break; - - default: - is_const = false; - if (len) - get_array_ctor_all_strlen (block, c->expr, len); - break; - } - - /* After the first iteration, we don't want the length modified. */ - len = NULL; - } - - return is_const; -} - -/* Check whether the array constructor C consists entirely of constant - elements, and if so returns the number of those elements, otherwise - return zero. Note, an empty or NULL array constructor returns zero. */ - -unsigned HOST_WIDE_INT -gfc_constant_array_constructor_p (gfc_constructor_base base) -{ - unsigned HOST_WIDE_INT nelem = 0; - - gfc_constructor *c = gfc_constructor_first (base); - while (c) - { - if (c->iterator - || c->expr->rank > 0 - || c->expr->expr_type != EXPR_CONSTANT) - return 0; - c = gfc_constructor_next (c); - nelem++; - } - return nelem; -} - - -/* Given EXPR, the constant array constructor specified by an EXPR_ARRAY, - and the tree type of it's elements, TYPE, return a static constant - variable that is compile-time initialized. */ - -tree -gfc_build_constant_array_constructor (gfc_expr * expr, tree type) -{ - tree tmptype, init, tmp; - HOST_WIDE_INT nelem; - gfc_constructor *c; - gfc_array_spec as; - gfc_se se; - int i; - vec *v = NULL; - - /* First traverse the constructor list, converting the constants - to tree to build an initializer. */ - nelem = 0; - c = gfc_constructor_first (expr->value.constructor); - while (c) - { - gfc_init_se (&se, NULL); - gfc_conv_constant (&se, c->expr); - if (c->expr->ts.type != BT_CHARACTER) - se.expr = fold_convert (type, se.expr); - else if (POINTER_TYPE_P (type)) - se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind), - se.expr); - CONSTRUCTOR_APPEND_ELT (v, build_int_cst (gfc_array_index_type, nelem), - se.expr); - c = gfc_constructor_next (c); - nelem++; - } - - /* Next determine the tree type for the array. We use the gfortran - front-end's gfc_get_nodesc_array_type in order to create a suitable - GFC_ARRAY_TYPE_P that may be used by the scalarizer. */ - - memset (&as, 0, sizeof (gfc_array_spec)); - - as.rank = expr->rank; - as.type = AS_EXPLICIT; - if (!expr->shape) - { - as.lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0); - as.upper[0] = gfc_get_int_expr (gfc_default_integer_kind, - NULL, nelem - 1); - } - else - for (i = 0; i < expr->rank; i++) - { - int tmp = (int) mpz_get_si (expr->shape[i]); - as.lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0); - as.upper[i] = gfc_get_int_expr (gfc_default_integer_kind, - NULL, tmp - 1); - } - - tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true); - - /* as is not needed anymore. */ - for (i = 0; i < as.rank + as.corank; i++) - { - gfc_free_expr (as.lower[i]); - gfc_free_expr (as.upper[i]); - } - - init = build_constructor (tmptype, v); - - TREE_CONSTANT (init) = 1; - TREE_STATIC (init) = 1; - - tmp = build_decl (input_location, VAR_DECL, create_tmp_var_name ("A"), - tmptype); - DECL_ARTIFICIAL (tmp) = 1; - DECL_IGNORED_P (tmp) = 1; - TREE_STATIC (tmp) = 1; - TREE_CONSTANT (tmp) = 1; - TREE_READONLY (tmp) = 1; - DECL_INITIAL (tmp) = init; - pushdecl (tmp); - - return tmp; -} - - -/* Translate a constant EXPR_ARRAY array constructor for the scalarizer. - This mostly initializes the scalarizer state info structure with the - appropriate values to directly use the array created by the function - gfc_build_constant_array_constructor. */ - -static void -trans_constant_array_constructor (gfc_ss * ss, tree type) -{ - gfc_array_info *info; - tree tmp; - int i; - - tmp = gfc_build_constant_array_constructor (ss->info->expr, type); - - info = &ss->info->data.array; - - info->descriptor = tmp; - info->data = gfc_build_addr_expr (NULL_TREE, tmp); - info->offset = gfc_index_zero_node; - - for (i = 0; i < ss->dimen; i++) - { - info->delta[i] = gfc_index_zero_node; - info->start[i] = gfc_index_zero_node; - info->end[i] = gfc_index_zero_node; - info->stride[i] = gfc_index_one_node; - } -} - - -static int -get_rank (gfc_loopinfo *loop) -{ - int rank; - - rank = 0; - for (; loop; loop = loop->parent) - rank += loop->dimen; - - return rank; -} - - -/* Helper routine of gfc_trans_array_constructor to determine if the - bounds of the loop specified by LOOP are constant and simple enough - to use with trans_constant_array_constructor. Returns the - iteration count of the loop if suitable, and NULL_TREE otherwise. */ - -static tree -constant_array_constructor_loop_size (gfc_loopinfo * l) -{ - gfc_loopinfo *loop; - tree size = gfc_index_one_node; - tree tmp; - int i, total_dim; - - total_dim = get_rank (l); - - for (loop = l; loop; loop = loop->parent) - { - for (i = 0; i < loop->dimen; i++) - { - /* If the bounds aren't constant, return NULL_TREE. */ - if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i])) - return NULL_TREE; - if (!integer_zerop (loop->from[i])) - { - /* Only allow nonzero "from" in one-dimensional arrays. */ - if (total_dim != 1) - return NULL_TREE; - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - loop->to[i], loop->from[i]); - } - else - tmp = loop->to[i]; - tmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, tmp, gfc_index_one_node); - size = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, size, tmp); - } - } - - return size; -} - - -static tree * -get_loop_upper_bound_for_array (gfc_ss *array, int array_dim) -{ - gfc_ss *ss; - int n; - - gcc_assert (array->nested_ss == NULL); - - for (ss = array; ss; ss = ss->parent) - for (n = 0; n < ss->loop->dimen; n++) - if (array_dim == get_array_ref_dim_for_loop_dim (ss, n)) - return &(ss->loop->to[n]); - - gcc_unreachable (); -} - - -static gfc_loopinfo * -outermost_loop (gfc_loopinfo * loop) -{ - while (loop->parent != NULL) - loop = loop->parent; - - return loop; -} - - -/* Array constructors are handled by constructing a temporary, then using that - within the scalarization loop. This is not optimal, but seems by far the - simplest method. */ - -static void -trans_array_constructor (gfc_ss * ss, locus * where) -{ - gfc_constructor_base c; - tree offset; - tree offsetvar; - tree desc; - tree type; - tree tmp; - tree *loop_ubound0; - bool dynamic; - bool old_first_len, old_typespec_chararray_ctor; - tree old_first_len_val; - gfc_loopinfo *loop, *outer_loop; - gfc_ss_info *ss_info; - gfc_expr *expr; - gfc_ss *s; - tree neg_len; - char *msg; - - /* Save the old values for nested checking. */ - old_first_len = first_len; - old_first_len_val = first_len_val; - old_typespec_chararray_ctor = typespec_chararray_ctor; - - loop = ss->loop; - outer_loop = outermost_loop (loop); - ss_info = ss->info; - expr = ss_info->expr; - - /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no - typespec was given for the array constructor. */ - typespec_chararray_ctor = (expr->ts.type == BT_CHARACTER - && expr->ts.u.cl - && expr->ts.u.cl->length_from_typespec); - - if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) - && expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor) - { - first_len_val = gfc_create_var (gfc_charlen_type_node, "len"); - first_len = true; - } - - gcc_assert (ss->dimen == ss->loop->dimen); - - c = expr->value.constructor; - if (expr->ts.type == BT_CHARACTER) - { - bool const_string; - bool force_new_cl = false; - - /* get_array_ctor_strlen walks the elements of the constructor, if a - typespec was given, we already know the string length and want the one - specified there. */ - if (typespec_chararray_ctor && expr->ts.u.cl->length - && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT) - { - gfc_se length_se; - - const_string = false; - gfc_init_se (&length_se, NULL); - gfc_conv_expr_type (&length_se, expr->ts.u.cl->length, - gfc_charlen_type_node); - ss_info->string_length = length_se.expr; - - /* Check if the character length is negative. If it is, then - set LEN = 0. */ - neg_len = fold_build2_loc (input_location, LT_EXPR, - logical_type_node, ss_info->string_length, - build_zero_cst (TREE_TYPE - (ss_info->string_length))); - /* Print a warning if bounds checking is enabled. */ - if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) - { - msg = xasprintf ("Negative character length treated as LEN = 0"); - gfc_trans_runtime_check (false, true, neg_len, &length_se.pre, - where, msg); - free (msg); - } - - ss_info->string_length - = fold_build3_loc (input_location, COND_EXPR, - gfc_charlen_type_node, neg_len, - build_zero_cst - (TREE_TYPE (ss_info->string_length)), - ss_info->string_length); - ss_info->string_length = gfc_evaluate_now (ss_info->string_length, - &length_se.pre); - gfc_add_block_to_block (&outer_loop->pre, &length_se.pre); - gfc_add_block_to_block (&outer_loop->post, &length_se.post); - } - else - { - const_string = get_array_ctor_strlen (&outer_loop->pre, c, - &ss_info->string_length); - force_new_cl = true; - } - - /* Complex character array constructors should have been taken care of - and not end up here. */ - gcc_assert (ss_info->string_length); - - store_backend_decl (&expr->ts.u.cl, ss_info->string_length, force_new_cl); - - type = gfc_get_character_type_len (expr->ts.kind, ss_info->string_length); - if (const_string) - type = build_pointer_type (type); - } - else - type = gfc_typenode_for_spec (expr->ts.type == BT_CLASS - ? &CLASS_DATA (expr)->ts : &expr->ts); - - /* See if the constructor determines the loop bounds. */ - dynamic = false; - - loop_ubound0 = get_loop_upper_bound_for_array (ss, 0); - - if (expr->shape && get_rank (loop) > 1 && *loop_ubound0 == NULL_TREE) - { - /* We have a multidimensional parameter. */ - for (s = ss; s; s = s->parent) - { - int n; - for (n = 0; n < s->loop->dimen; n++) - { - s->loop->from[n] = gfc_index_zero_node; - s->loop->to[n] = gfc_conv_mpz_to_tree (expr->shape[s->dim[n]], - gfc_index_integer_kind); - s->loop->to[n] = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - s->loop->to[n], - gfc_index_one_node); - } - } - } - - if (*loop_ubound0 == NULL_TREE) - { - mpz_t size; - - /* We should have a 1-dimensional, zero-based loop. */ - gcc_assert (loop->parent == NULL && loop->nested == NULL); - gcc_assert (loop->dimen == 1); - gcc_assert (integer_zerop (loop->from[0])); - - /* Split the constructor size into a static part and a dynamic part. - Allocate the static size up-front and record whether the dynamic - size might be nonzero. */ - mpz_init (size); - dynamic = gfc_get_array_constructor_size (&size, c); - mpz_sub_ui (size, size, 1); - loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind); - mpz_clear (size); - } - - /* Special case constant array constructors. */ - if (!dynamic) - { - unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c); - if (nelem > 0) - { - tree size = constant_array_constructor_loop_size (loop); - if (size && compare_tree_int (size, nelem) == 0) - { - trans_constant_array_constructor (ss, type); - goto finish; - } - } - } - - gfc_trans_create_temp_array (&outer_loop->pre, &outer_loop->post, ss, type, - NULL_TREE, dynamic, true, false, where); - - desc = ss_info->data.array.descriptor; - offset = gfc_index_zero_node; - offsetvar = gfc_create_var_np (gfc_array_index_type, "offset"); - suppress_warning (offsetvar); - TREE_USED (offsetvar) = 0; - gfc_trans_array_constructor_value (&outer_loop->pre, type, desc, c, - &offset, &offsetvar, dynamic); - - /* If the array grows dynamically, the upper bound of the loop variable - is determined by the array's final upper bound. */ - if (dynamic) - { - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - offsetvar, gfc_index_one_node); - tmp = gfc_evaluate_now (tmp, &outer_loop->pre); - gfc_conv_descriptor_ubound_set (&loop->pre, desc, gfc_rank_cst[0], tmp); - if (*loop_ubound0 && VAR_P (*loop_ubound0)) - gfc_add_modify (&outer_loop->pre, *loop_ubound0, tmp); - else - *loop_ubound0 = tmp; - } - - if (TREE_USED (offsetvar)) - pushdecl (offsetvar); - else - gcc_assert (INTEGER_CST_P (offset)); - -#if 0 - /* Disable bound checking for now because it's probably broken. */ - if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) - { - gcc_unreachable (); - } -#endif - -finish: - /* Restore old values of globals. */ - first_len = old_first_len; - first_len_val = old_first_len_val; - typespec_chararray_ctor = old_typespec_chararray_ctor; -} - - -/* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is - called after evaluating all of INFO's vector dimensions. Go through - each such vector dimension and see if we can now fill in any missing - loop bounds. */ - -static void -set_vector_loop_bounds (gfc_ss * ss) -{ - gfc_loopinfo *loop, *outer_loop; - gfc_array_info *info; - gfc_se se; - tree tmp; - tree desc; - tree zero; - int n; - int dim; - - outer_loop = outermost_loop (ss->loop); - - info = &ss->info->data.array; - - for (; ss; ss = ss->parent) - { - loop = ss->loop; - - for (n = 0; n < loop->dimen; n++) - { - dim = ss->dim[n]; - if (info->ref->u.ar.dimen_type[dim] != DIMEN_VECTOR - || loop->to[n] != NULL) - continue; - - /* Loop variable N indexes vector dimension DIM, and we don't - yet know the upper bound of loop variable N. Set it to the - difference between the vector's upper and lower bounds. */ - gcc_assert (loop->from[n] == gfc_index_zero_node); - gcc_assert (info->subscript[dim] - && info->subscript[dim]->info->type == GFC_SS_VECTOR); - - gfc_init_se (&se, NULL); - desc = info->subscript[dim]->info->data.array.descriptor; - zero = gfc_rank_cst[0]; - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - gfc_conv_descriptor_ubound_get (desc, zero), - gfc_conv_descriptor_lbound_get (desc, zero)); - tmp = gfc_evaluate_now (tmp, &outer_loop->pre); - loop->to[n] = tmp; - } - } -} - - -/* Tells whether a scalar argument to an elemental procedure is saved out - of a scalarization loop as a value or as a reference. */ - -bool -gfc_scalar_elemental_arg_saved_as_reference (gfc_ss_info * ss_info) -{ - if (ss_info->type != GFC_SS_REFERENCE) - return false; - - if (ss_info->data.scalar.needs_temporary) - return false; - - /* If the actual argument can be absent (in other words, it can - be a NULL reference), don't try to evaluate it; pass instead - the reference directly. */ - if (ss_info->can_be_null_ref) - return true; - - /* If the expression is of polymorphic type, it's actual size is not known, - so we avoid copying it anywhere. */ - if (ss_info->data.scalar.dummy_arg - && gfc_dummy_arg_get_typespec (*ss_info->data.scalar.dummy_arg).type - == BT_CLASS - && ss_info->expr->ts.type == BT_CLASS) - return true; - - /* If the expression is a data reference of aggregate type, - and the data reference is not used on the left hand side, - avoid a copy by saving a reference to the content. */ - if (!ss_info->data.scalar.needs_temporary - && (ss_info->expr->ts.type == BT_DERIVED - || ss_info->expr->ts.type == BT_CLASS) - && gfc_expr_is_variable (ss_info->expr)) - return true; - - /* Otherwise the expression is evaluated to a temporary variable before the - scalarization loop. */ - return false; -} - - -/* Add the pre and post chains for all the scalar expressions in a SS chain - to loop. This is called after the loop parameters have been calculated, - but before the actual scalarizing loops. */ - -static void -gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript, - locus * where) -{ - gfc_loopinfo *nested_loop, *outer_loop; - gfc_se se; - gfc_ss_info *ss_info; - gfc_array_info *info; - gfc_expr *expr; - int n; - - /* Don't evaluate the arguments for realloc_lhs_loop_for_fcn_call; otherwise, - arguments could get evaluated multiple times. */ - if (ss->is_alloc_lhs) - return; - - outer_loop = outermost_loop (loop); - - /* TODO: This can generate bad code if there are ordering dependencies, - e.g., a callee allocated function and an unknown size constructor. */ - gcc_assert (ss != NULL); - - for (; ss != gfc_ss_terminator; ss = ss->loop_chain) - { - gcc_assert (ss); - - /* Cross loop arrays are handled from within the most nested loop. */ - if (ss->nested_ss != NULL) - continue; - - ss_info = ss->info; - expr = ss_info->expr; - info = &ss_info->data.array; - - switch (ss_info->type) - { - case GFC_SS_SCALAR: - /* Scalar expression. Evaluate this now. This includes elemental - dimension indices, but not array section bounds. */ - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, expr); - gfc_add_block_to_block (&outer_loop->pre, &se.pre); - - if (expr->ts.type != BT_CHARACTER - && !gfc_is_alloc_class_scalar_function (expr)) - { - /* Move the evaluation of scalar expressions outside the - scalarization loop, except for WHERE assignments. */ - if (subscript) - se.expr = convert(gfc_array_index_type, se.expr); - if (!ss_info->where) - se.expr = gfc_evaluate_now (se.expr, &outer_loop->pre); - gfc_add_block_to_block (&outer_loop->pre, &se.post); - } - else - gfc_add_block_to_block (&outer_loop->post, &se.post); - - ss_info->data.scalar.value = se.expr; - ss_info->string_length = se.string_length; - break; - - case GFC_SS_REFERENCE: - /* Scalar argument to elemental procedure. */ - gfc_init_se (&se, NULL); - if (gfc_scalar_elemental_arg_saved_as_reference (ss_info)) - gfc_conv_expr_reference (&se, expr); - else - { - /* Evaluate the argument outside the loop and pass - a reference to the value. */ - gfc_conv_expr (&se, expr); - } - - /* Ensure that a pointer to the string is stored. */ - if (expr->ts.type == BT_CHARACTER) - gfc_conv_string_parameter (&se); - - gfc_add_block_to_block (&outer_loop->pre, &se.pre); - gfc_add_block_to_block (&outer_loop->post, &se.post); - if (gfc_is_class_scalar_expr (expr)) - /* This is necessary because the dynamic type will always be - large than the declared type. In consequence, assigning - the value to a temporary could segfault. - OOP-TODO: see if this is generally correct or is the value - has to be written to an allocated temporary, whose address - is passed via ss_info. */ - ss_info->data.scalar.value = se.expr; - else - ss_info->data.scalar.value = gfc_evaluate_now (se.expr, - &outer_loop->pre); - - ss_info->string_length = se.string_length; - break; - - case GFC_SS_SECTION: - /* Add the expressions for scalar and vector subscripts. */ - for (n = 0; n < GFC_MAX_DIMENSIONS; n++) - if (info->subscript[n]) - gfc_add_loop_ss_code (loop, info->subscript[n], true, where); - - set_vector_loop_bounds (ss); - break; - - case GFC_SS_VECTOR: - /* Get the vector's descriptor and store it in SS. */ - gfc_init_se (&se, NULL); - gfc_conv_expr_descriptor (&se, expr); - gfc_add_block_to_block (&outer_loop->pre, &se.pre); - gfc_add_block_to_block (&outer_loop->post, &se.post); - info->descriptor = se.expr; - break; - - case GFC_SS_INTRINSIC: - gfc_add_intrinsic_ss_code (loop, ss); - break; - - case GFC_SS_FUNCTION: - /* Array function return value. We call the function and save its - result in a temporary for use inside the loop. */ - gfc_init_se (&se, NULL); - se.loop = loop; - se.ss = ss; - if (gfc_is_class_array_function (expr)) - expr->must_finalize = 1; - gfc_conv_expr (&se, expr); - gfc_add_block_to_block (&outer_loop->pre, &se.pre); - gfc_add_block_to_block (&outer_loop->post, &se.post); - ss_info->string_length = se.string_length; - break; - - case GFC_SS_CONSTRUCTOR: - if (expr->ts.type == BT_CHARACTER - && ss_info->string_length == NULL - && expr->ts.u.cl - && expr->ts.u.cl->length - && expr->ts.u.cl->length->expr_type == EXPR_CONSTANT) - { - gfc_init_se (&se, NULL); - gfc_conv_expr_type (&se, expr->ts.u.cl->length, - gfc_charlen_type_node); - ss_info->string_length = se.expr; - gfc_add_block_to_block (&outer_loop->pre, &se.pre); - gfc_add_block_to_block (&outer_loop->post, &se.post); - } - trans_array_constructor (ss, where); - break; - - case GFC_SS_TEMP: - case GFC_SS_COMPONENT: - /* Do nothing. These are handled elsewhere. */ - break; - - default: - gcc_unreachable (); - } - } - - if (!subscript) - for (nested_loop = loop->nested; nested_loop; - nested_loop = nested_loop->next) - gfc_add_loop_ss_code (nested_loop, nested_loop->ss, subscript, where); -} - - -/* Translate expressions for the descriptor and data pointer of a SS. */ -/*GCC ARRAYS*/ - -static void -gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base) -{ - gfc_se se; - gfc_ss_info *ss_info; - gfc_array_info *info; - tree tmp; - - ss_info = ss->info; - info = &ss_info->data.array; - - /* Get the descriptor for the array to be scalarized. */ - gcc_assert (ss_info->expr->expr_type == EXPR_VARIABLE); - gfc_init_se (&se, NULL); - se.descriptor_only = 1; - gfc_conv_expr_lhs (&se, ss_info->expr); - gfc_add_block_to_block (block, &se.pre); - info->descriptor = se.expr; - ss_info->string_length = se.string_length; - - if (base) - { - if (ss_info->expr->ts.type == BT_CHARACTER && !ss_info->expr->ts.deferred - && ss_info->expr->ts.u.cl->length == NULL) - { - /* Emit a DECL_EXPR for the variable sized array type in - GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type - sizes works correctly. */ - tree arraytype = TREE_TYPE ( - GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (info->descriptor))); - if (! TYPE_NAME (arraytype)) - TYPE_NAME (arraytype) = build_decl (UNKNOWN_LOCATION, TYPE_DECL, - NULL_TREE, arraytype); - gfc_add_expr_to_block (block, build1 (DECL_EXPR, arraytype, - TYPE_NAME (arraytype))); - } - /* Also the data pointer. */ - tmp = gfc_conv_array_data (se.expr); - /* If this is a variable or address or a class array, use it directly. - Otherwise we must evaluate it now to avoid breaking dependency - analysis by pulling the expressions for elemental array indices - inside the loop. */ - if (!(DECL_P (tmp) - || (TREE_CODE (tmp) == ADDR_EXPR - && DECL_P (TREE_OPERAND (tmp, 0))) - || (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)) - && TREE_CODE (se.expr) == COMPONENT_REF - && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (se.expr, 0)))))) - tmp = gfc_evaluate_now (tmp, block); - info->data = tmp; - - tmp = gfc_conv_array_offset (se.expr); - info->offset = gfc_evaluate_now (tmp, block); - - /* Make absolutely sure that the saved_offset is indeed saved - so that the variable is still accessible after the loops - are translated. */ - info->saved_offset = info->offset; - } -} - - -/* Initialize a gfc_loopinfo structure. */ - -void -gfc_init_loopinfo (gfc_loopinfo * loop) -{ - int n; - - memset (loop, 0, sizeof (gfc_loopinfo)); - gfc_init_block (&loop->pre); - gfc_init_block (&loop->post); - - /* Initially scalarize in order and default to no loop reversal. */ - for (n = 0; n < GFC_MAX_DIMENSIONS; n++) - { - loop->order[n] = n; - loop->reverse[n] = GFC_INHIBIT_REVERSE; - } - - loop->ss = gfc_ss_terminator; -} - - -/* Copies the loop variable info to a gfc_se structure. Does not copy the SS - chain. */ - -void -gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop) -{ - se->loop = loop; -} - - -/* Return an expression for the data pointer of an array. */ - -tree -gfc_conv_array_data (tree descriptor) -{ - tree type; - - type = TREE_TYPE (descriptor); - if (GFC_ARRAY_TYPE_P (type)) - { - if (TREE_CODE (type) == POINTER_TYPE) - return descriptor; - else - { - /* Descriptorless arrays. */ - return gfc_build_addr_expr (NULL_TREE, descriptor); - } - } - else - return gfc_conv_descriptor_data_get (descriptor); -} - - -/* Return an expression for the base offset of an array. */ - -tree -gfc_conv_array_offset (tree descriptor) -{ - tree type; - - type = TREE_TYPE (descriptor); - if (GFC_ARRAY_TYPE_P (type)) - return GFC_TYPE_ARRAY_OFFSET (type); - else - return gfc_conv_descriptor_offset_get (descriptor); -} - - -/* Get an expression for the array stride. */ - -tree -gfc_conv_array_stride (tree descriptor, int dim) -{ - tree tmp; - tree type; - - type = TREE_TYPE (descriptor); - - /* For descriptorless arrays use the array size. */ - tmp = GFC_TYPE_ARRAY_STRIDE (type, dim); - if (tmp != NULL_TREE) - return tmp; - - tmp = gfc_conv_descriptor_stride_get (descriptor, gfc_rank_cst[dim]); - return tmp; -} - - -/* Like gfc_conv_array_stride, but for the lower bound. */ - -tree -gfc_conv_array_lbound (tree descriptor, int dim) -{ - tree tmp; - tree type; - - type = TREE_TYPE (descriptor); - - tmp = GFC_TYPE_ARRAY_LBOUND (type, dim); - if (tmp != NULL_TREE) - return tmp; - - tmp = gfc_conv_descriptor_lbound_get (descriptor, gfc_rank_cst[dim]); - return tmp; -} - - -/* Like gfc_conv_array_stride, but for the upper bound. */ - -tree -gfc_conv_array_ubound (tree descriptor, int dim) -{ - tree tmp; - tree type; - - type = TREE_TYPE (descriptor); - - tmp = GFC_TYPE_ARRAY_UBOUND (type, dim); - if (tmp != NULL_TREE) - return tmp; - - /* This should only ever happen when passing an assumed shape array - as an actual parameter. The value will never be used. */ - if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor))) - return gfc_index_zero_node; - - tmp = gfc_conv_descriptor_ubound_get (descriptor, gfc_rank_cst[dim]); - return tmp; -} - - -/* Generate code to perform an array index bound check. */ - -static tree -trans_array_bound_check (gfc_se * se, gfc_ss *ss, tree index, int n, - locus * where, bool check_upper) -{ - tree fault; - tree tmp_lo, tmp_up; - tree descriptor; - char *msg; - const char * name = NULL; - - if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)) - return index; - - descriptor = ss->info->data.array.descriptor; - - index = gfc_evaluate_now (index, &se->pre); - - /* We find a name for the error message. */ - name = ss->info->expr->symtree->n.sym->name; - gcc_assert (name != NULL); - - if (VAR_P (descriptor)) - name = IDENTIFIER_POINTER (DECL_NAME (descriptor)); - - /* If upper bound is present, include both bounds in the error message. */ - if (check_upper) - { - tmp_lo = gfc_conv_array_lbound (descriptor, n); - tmp_up = gfc_conv_array_ubound (descriptor, n); - - if (name) - msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' " - "outside of expected range (%%ld:%%ld)", n+1, name); - else - msg = xasprintf ("Index '%%ld' of dimension %d " - "outside of expected range (%%ld:%%ld)", n+1); - - fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node, - index, tmp_lo); - gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg, - fold_convert (long_integer_type_node, index), - fold_convert (long_integer_type_node, tmp_lo), - fold_convert (long_integer_type_node, tmp_up)); - fault = fold_build2_loc (input_location, GT_EXPR, logical_type_node, - index, tmp_up); - gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg, - fold_convert (long_integer_type_node, index), - fold_convert (long_integer_type_node, tmp_lo), - fold_convert (long_integer_type_node, tmp_up)); - free (msg); - } - else - { - tmp_lo = gfc_conv_array_lbound (descriptor, n); - - if (name) - msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' " - "below lower bound of %%ld", n+1, name); - else - msg = xasprintf ("Index '%%ld' of dimension %d " - "below lower bound of %%ld", n+1); - - fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node, - index, tmp_lo); - gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg, - fold_convert (long_integer_type_node, index), - fold_convert (long_integer_type_node, tmp_lo)); - free (msg); - } - - return index; -} - - -/* Return the offset for an index. Performs bound checking for elemental - dimensions. Single element references are processed separately. - DIM is the array dimension, I is the loop dimension. */ - -static tree -conv_array_index_offset (gfc_se * se, gfc_ss * ss, int dim, int i, - gfc_array_ref * ar, tree stride) -{ - gfc_array_info *info; - tree index; - tree desc; - tree data; - - info = &ss->info->data.array; - - /* Get the index into the array for this dimension. */ - if (ar) - { - gcc_assert (ar->type != AR_ELEMENT); - switch (ar->dimen_type[dim]) - { - case DIMEN_THIS_IMAGE: - gcc_unreachable (); - break; - case DIMEN_ELEMENT: - /* Elemental dimension. */ - gcc_assert (info->subscript[dim] - && info->subscript[dim]->info->type == GFC_SS_SCALAR); - /* We've already translated this value outside the loop. */ - index = info->subscript[dim]->info->data.scalar.value; - - index = trans_array_bound_check (se, ss, index, dim, &ar->where, - ar->as->type != AS_ASSUMED_SIZE - || dim < ar->dimen - 1); - break; - - case DIMEN_VECTOR: - gcc_assert (info && se->loop); - gcc_assert (info->subscript[dim] - && info->subscript[dim]->info->type == GFC_SS_VECTOR); - desc = info->subscript[dim]->info->data.array.descriptor; - - /* Get a zero-based index into the vector. */ - index = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - se->loop->loopvar[i], se->loop->from[i]); - - /* Multiply the index by the stride. */ - index = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, - index, gfc_conv_array_stride (desc, 0)); - - /* Read the vector to get an index into info->descriptor. */ - data = build_fold_indirect_ref_loc (input_location, - gfc_conv_array_data (desc)); - index = gfc_build_array_ref (data, index, NULL); - index = gfc_evaluate_now (index, &se->pre); - index = fold_convert (gfc_array_index_type, index); - - /* Do any bounds checking on the final info->descriptor index. */ - index = trans_array_bound_check (se, ss, index, dim, &ar->where, - ar->as->type != AS_ASSUMED_SIZE - || dim < ar->dimen - 1); - break; - - case DIMEN_RANGE: - /* Scalarized dimension. */ - gcc_assert (info && se->loop); - - /* Multiply the loop variable by the stride and delta. */ - index = se->loop->loopvar[i]; - if (!integer_onep (info->stride[dim])) - index = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, index, - info->stride[dim]); - if (!integer_zerop (info->delta[dim])) - index = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, index, - info->delta[dim]); - break; - - default: - gcc_unreachable (); - } - } - else - { - /* Temporary array or derived type component. */ - gcc_assert (se->loop); - index = se->loop->loopvar[se->loop->order[i]]; - - /* Pointer functions can have stride[0] different from unity. - Use the stride returned by the function call and stored in - the descriptor for the temporary. */ - if (se->ss && se->ss->info->type == GFC_SS_FUNCTION - && se->ss->info->expr - && se->ss->info->expr->symtree - && se->ss->info->expr->symtree->n.sym->result - && se->ss->info->expr->symtree->n.sym->result->attr.pointer) - stride = gfc_conv_descriptor_stride_get (info->descriptor, - gfc_rank_cst[dim]); - - if (info->delta[dim] && !integer_zerop (info->delta[dim])) - index = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, index, info->delta[dim]); - } - - /* Multiply by the stride. */ - if (stride != NULL && !integer_onep (stride)) - index = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - index, stride); - - return index; -} - - -/* Build a scalarized array reference using the vptr 'size'. */ - -static bool -build_class_array_ref (gfc_se *se, tree base, tree index) -{ - tree size; - tree decl = NULL_TREE; - tree tmp; - gfc_expr *expr = se->ss->info->expr; - gfc_expr *class_expr; - gfc_typespec *ts; - gfc_symbol *sym; - - tmp = !VAR_P (base) ? gfc_get_class_from_expr (base) : NULL_TREE; - - if (tmp != NULL_TREE) - decl = tmp; - else - { - /* The base expression does not contain a class component, either - because it is a temporary array or array descriptor. Class - array functions are correctly resolved above. */ - if (!expr - || (expr->ts.type != BT_CLASS - && !gfc_is_class_array_ref (expr, NULL))) - return false; - - /* Obtain the expression for the class entity or component that is - followed by an array reference, which is not an element, so that - the span of the array can be obtained. */ - class_expr = gfc_find_and_cut_at_last_class_ref (expr, false, &ts); - - if (!ts) - return false; - - sym = (!class_expr && expr) ? expr->symtree->n.sym : NULL; - if (sym && sym->attr.function - && sym == sym->result - && sym->backend_decl == current_function_decl) - /* The temporary is the data field of the class data component - of the current function. */ - decl = gfc_get_fake_result_decl (sym, 0); - else if (sym) - { - if (decl == NULL_TREE) - decl = expr->symtree->n.sym->backend_decl; - /* For class arrays the tree containing the class is stored in - GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl. - For all others it's sym's backend_decl directly. */ - if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl)) - decl = GFC_DECL_SAVED_DESCRIPTOR (decl); - } - else - decl = gfc_get_class_from_gfc_expr (class_expr); - - if (POINTER_TYPE_P (TREE_TYPE (decl))) - decl = build_fold_indirect_ref_loc (input_location, decl); - - if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl))) - return false; - } - - se->class_vptr = gfc_evaluate_now (gfc_class_vptr_get (decl), &se->pre); - - size = gfc_class_vtab_size_get (decl); - /* For unlimited polymorphic entities then _len component needs to be - multiplied with the size. */ - size = gfc_resize_class_size_with_len (&se->pre, decl, size); - size = fold_convert (TREE_TYPE (index), size); - - /* Return the element in the se expression. */ - se->expr = gfc_build_spanned_array_ref (base, index, size); - return true; -} - - -/* Build a scalarized reference to an array. */ - -static void -gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar) -{ - gfc_array_info *info; - tree decl = NULL_TREE; - tree index; - tree base; - gfc_ss *ss; - gfc_expr *expr; - int n; - - ss = se->ss; - expr = ss->info->expr; - info = &ss->info->data.array; - if (ar) - n = se->loop->order[0]; - else - n = 0; - - index = conv_array_index_offset (se, ss, ss->dim[n], n, ar, info->stride0); - /* Add the offset for this dimension to the stored offset for all other - dimensions. */ - if (info->offset && !integer_zerop (info->offset)) - index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - index, info->offset); - - base = build_fold_indirect_ref_loc (input_location, info->data); - - /* Use the vptr 'size' field to access the element of a class array. */ - 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); - - /* A pointer array component can be detected from its field decl. Fix - the descriptor, mark the resulting variable decl and pass it to - gfc_build_array_ref. */ - if (is_pointer_array (info->descriptor) - || (expr && expr->ts.deferred && info->descriptor - && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (info->descriptor)))) - { - if (TREE_CODE (info->descriptor) == COMPONENT_REF) - decl = info->descriptor; - else if (TREE_CODE (info->descriptor) == INDIRECT_REF) - decl = TREE_OPERAND (info->descriptor, 0); - - if (decl == NULL_TREE) - decl = info->descriptor; - } - - se->expr = gfc_build_array_ref (base, index, decl); -} - - -/* Translate access of temporary array. */ - -void -gfc_conv_tmp_array_ref (gfc_se * se) -{ - se->string_length = se->ss->info->string_length; - gfc_conv_scalarized_array_ref (se, NULL); - gfc_advance_se_ss_chain (se); -} - -/* Add T to the offset pair *OFFSET, *CST_OFFSET. */ - -static void -add_to_offset (tree *cst_offset, tree *offset, tree t) -{ - if (TREE_CODE (t) == INTEGER_CST) - *cst_offset = int_const_binop (PLUS_EXPR, *cst_offset, t); - else - { - if (!integer_zerop (*offset)) - *offset = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, *offset, t); - else - *offset = t; - } -} - - -static tree -build_array_ref (tree desc, tree offset, tree decl, tree vptr) -{ - tree tmp; - tree type; - tree cdesc; - - /* For class arrays the class declaration is stored in the saved - descriptor. */ - if (INDIRECT_REF_P (desc) - && DECL_LANG_SPECIFIC (TREE_OPERAND (desc, 0)) - && GFC_DECL_SAVED_DESCRIPTOR (TREE_OPERAND (desc, 0))) - cdesc = gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR ( - TREE_OPERAND (desc, 0))); - else - cdesc = desc; - - /* Class container types do not always have the GFC_CLASS_TYPE_P - but the canonical type does. */ - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cdesc)) - && TREE_CODE (cdesc) == COMPONENT_REF) - { - type = TREE_TYPE (TREE_OPERAND (cdesc, 0)); - if (TYPE_CANONICAL (type) - && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type))) - vptr = gfc_class_vptr_get (TREE_OPERAND (cdesc, 0)); - } - - tmp = gfc_conv_array_data (desc); - tmp = build_fold_indirect_ref_loc (input_location, tmp); - tmp = gfc_build_array_ref (tmp, offset, decl, vptr); - return tmp; -} - - -/* Build an array reference. se->expr already holds the array descriptor. - This should be either a variable, indirect variable reference or component - reference. For arrays which do not have a descriptor, se->expr will be - the data pointer. - a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/ - -void -gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr, - locus * where) -{ - int n; - tree offset, cst_offset; - tree tmp; - tree stride; - tree decl = NULL_TREE; - gfc_se indexse; - gfc_se tmpse; - gfc_symbol * sym = expr->symtree->n.sym; - char *var_name = NULL; - - if (ar->dimen == 0) - { - gcc_assert (ar->codimen || sym->attr.select_rank_temporary - || (ar->as && ar->as->corank)); - - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr))) - se->expr = build_fold_indirect_ref (gfc_conv_array_data (se->expr)); - else - { - if (GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr)) - && TREE_CODE (TREE_TYPE (se->expr)) == POINTER_TYPE) - se->expr = build_fold_indirect_ref_loc (input_location, se->expr); - - /* Use the actual tree type and not the wrapped coarray. */ - if (!se->want_pointer) - se->expr = fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se->expr)), - se->expr); - } - - return; - } - - /* Handle scalarized references separately. */ - if (ar->type != AR_ELEMENT) - { - gfc_conv_scalarized_array_ref (se, ar); - gfc_advance_se_ss_chain (se); - return; - } - - if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) - { - size_t len; - gfc_ref *ref; - - len = strlen (sym->name) + 1; - for (ref = expr->ref; ref; ref = ref->next) - { - if (ref->type == REF_ARRAY && &ref->u.ar == ar) - break; - if (ref->type == REF_COMPONENT) - len += 2 + strlen (ref->u.c.component->name); - } - - var_name = XALLOCAVEC (char, len); - strcpy (var_name, sym->name); - - for (ref = expr->ref; ref; ref = ref->next) - { - if (ref->type == REF_ARRAY && &ref->u.ar == ar) - break; - if (ref->type == REF_COMPONENT) - { - strcat (var_name, "%%"); - strcat (var_name, ref->u.c.component->name); - } - } - } - - decl = se->expr; - if (IS_CLASS_ARRAY (sym) && sym->attr.dummy && ar->as->type != AS_DEFERRED) - decl = sym->backend_decl; - - cst_offset = offset = gfc_index_zero_node; - add_to_offset (&cst_offset, &offset, gfc_conv_array_offset (decl)); - - /* Calculate the offsets from all the dimensions. Make sure to associate - the final offset so that we form a chain of loop invariant summands. */ - for (n = ar->dimen - 1; n >= 0; n--) - { - /* Calculate the index for this dimension. */ - gfc_init_se (&indexse, se); - gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type); - gfc_add_block_to_block (&se->pre, &indexse.pre); - - if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && ! expr->no_bounds_check) - { - /* Check array bounds. */ - tree cond; - char *msg; - - /* Evaluate the indexse.expr only once. */ - indexse.expr = save_expr (indexse.expr); - - /* Lower bound. */ - tmp = gfc_conv_array_lbound (decl, n); - if (sym->attr.temporary) - { - gfc_init_se (&tmpse, se); - gfc_conv_expr_type (&tmpse, ar->as->lower[n], - gfc_array_index_type); - gfc_add_block_to_block (&se->pre, &tmpse.pre); - tmp = tmpse.expr; - } - - cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, - indexse.expr, tmp); - msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' " - "below lower bound of %%ld", n+1, var_name); - gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg, - fold_convert (long_integer_type_node, - indexse.expr), - fold_convert (long_integer_type_node, tmp)); - free (msg); - - /* Upper bound, but not for the last dimension of assumed-size - arrays. */ - if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE) - { - tmp = gfc_conv_array_ubound (decl, n); - if (sym->attr.temporary) - { - gfc_init_se (&tmpse, se); - gfc_conv_expr_type (&tmpse, ar->as->upper[n], - gfc_array_index_type); - gfc_add_block_to_block (&se->pre, &tmpse.pre); - tmp = tmpse.expr; - } - - cond = fold_build2_loc (input_location, GT_EXPR, - logical_type_node, indexse.expr, tmp); - msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' " - "above upper bound of %%ld", n+1, var_name); - gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg, - fold_convert (long_integer_type_node, - indexse.expr), - fold_convert (long_integer_type_node, tmp)); - free (msg); - } - } - - /* Multiply the index by the stride. */ - stride = gfc_conv_array_stride (decl, n); - tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - indexse.expr, stride); - - /* And add it to the total. */ - add_to_offset (&cst_offset, &offset, tmp); - } - - if (!integer_zerop (cst_offset)) - offset = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, offset, cst_offset); - - /* 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. */ - decl = NULL_TREE; - 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)) - { - if (TREE_CODE (se->expr) == COMPONENT_REF) - decl = se->expr; - else if (TREE_CODE (se->expr) == INDIRECT_REF) - decl = TREE_OPERAND (se->expr, 0); - else - decl = se->expr; - } - else if (expr->ts.deferred - || (sym->ts.type == BT_CHARACTER - && sym->attr.select_type_temporary)) - { - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr))) - { - decl = se->expr; - if (TREE_CODE (decl) == INDIRECT_REF) - decl = TREE_OPERAND (decl, 0); - } - else - decl = sym->backend_decl; - } - else if (sym->ts.type == BT_CLASS) - { - if (UNLIMITED_POLY (sym)) - { - gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (expr); - gfc_init_se (&tmpse, NULL); - gfc_conv_expr (&tmpse, class_expr); - if (!se->class_vptr) - se->class_vptr = gfc_class_vptr_get (tmpse.expr); - gfc_free_expr (class_expr); - decl = tmpse.expr; - } - else - decl = NULL_TREE; - } - - se->expr = build_array_ref (se->expr, offset, decl, se->class_vptr); -} - - -/* Add the offset corresponding to array's ARRAY_DIM dimension and loop's - LOOP_DIM dimension (if any) to array's offset. */ - -static void -add_array_offset (stmtblock_t *pblock, gfc_loopinfo *loop, gfc_ss *ss, - gfc_array_ref *ar, int array_dim, int loop_dim) -{ - gfc_se se; - gfc_array_info *info; - tree stride, index; - - info = &ss->info->data.array; - - gfc_init_se (&se, NULL); - se.loop = loop; - se.expr = info->descriptor; - stride = gfc_conv_array_stride (info->descriptor, array_dim); - index = conv_array_index_offset (&se, ss, array_dim, loop_dim, ar, stride); - gfc_add_block_to_block (pblock, &se.pre); - - info->offset = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, - info->offset, index); - info->offset = gfc_evaluate_now (info->offset, pblock); -} - - -/* Generate the code to be executed immediately before entering a - scalarization loop. */ - -static void -gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag, - stmtblock_t * pblock) -{ - tree stride; - gfc_ss_info *ss_info; - gfc_array_info *info; - gfc_ss_type ss_type; - gfc_ss *ss, *pss; - gfc_loopinfo *ploop; - gfc_array_ref *ar; - int i; - - /* This code will be executed before entering the scalarization loop - for this dimension. */ - for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) - { - ss_info = ss->info; - - if ((ss_info->useflags & flag) == 0) - continue; - - ss_type = ss_info->type; - if (ss_type != GFC_SS_SECTION - && ss_type != GFC_SS_FUNCTION - && ss_type != GFC_SS_CONSTRUCTOR - && ss_type != GFC_SS_COMPONENT) - continue; - - info = &ss_info->data.array; - - gcc_assert (dim < ss->dimen); - gcc_assert (ss->dimen == loop->dimen); - - if (info->ref) - ar = &info->ref->u.ar; - else - ar = NULL; - - if (dim == loop->dimen - 1 && loop->parent != NULL) - { - /* If we are in the outermost dimension of this loop, the previous - dimension shall be in the parent loop. */ - gcc_assert (ss->parent != NULL); - - pss = ss->parent; - ploop = loop->parent; - - /* ss and ss->parent are about the same array. */ - gcc_assert (ss_info == pss->info); - } - else - { - ploop = loop; - pss = ss; - } - - if (dim == loop->dimen - 1) - i = 0; - else - i = dim + 1; - - /* For the time being, there is no loop reordering. */ - gcc_assert (i == ploop->order[i]); - i = ploop->order[i]; - - if (dim == loop->dimen - 1 && loop->parent == NULL) - { - stride = gfc_conv_array_stride (info->descriptor, - innermost_ss (ss)->dim[i]); - - /* Calculate the stride of the innermost loop. Hopefully this will - allow the backend optimizers to do their stuff more effectively. - */ - info->stride0 = gfc_evaluate_now (stride, pblock); - - /* For the outermost loop calculate the offset due to any - elemental dimensions. It will have been initialized with the - base offset of the array. */ - if (info->ref) - { - for (i = 0; i < ar->dimen; i++) - { - if (ar->dimen_type[i] != DIMEN_ELEMENT) - continue; - - add_array_offset (pblock, loop, ss, ar, i, /* unused */ -1); - } - } - } - else - /* Add the offset for the previous loop dimension. */ - add_array_offset (pblock, ploop, ss, ar, pss->dim[i], i); - - /* Remember this offset for the second loop. */ - if (dim == loop->temp_dim - 1 && loop->parent == NULL) - info->saved_offset = info->offset; - } -} - - -/* Start a scalarized expression. Creates a scope and declares loop - variables. */ - -void -gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody) -{ - int dim; - int n; - int flags; - - gcc_assert (!loop->array_parameter); - - for (dim = loop->dimen - 1; dim >= 0; dim--) - { - n = loop->order[dim]; - - gfc_start_block (&loop->code[n]); - - /* Create the loop variable. */ - loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S"); - - if (dim < loop->temp_dim) - flags = 3; - else - flags = 1; - /* Calculate values that will be constant within this loop. */ - gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]); - } - gfc_start_block (pbody); -} - - -/* Generates the actual loop code for a scalarization loop. */ - -static void -gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n, - stmtblock_t * pbody) -{ - stmtblock_t block; - tree cond; - tree tmp; - tree loopbody; - tree exit_label; - tree stmt; - tree init; - tree incr; - - if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS - | OMPWS_SCALARIZER_BODY)) - == (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS) - && n == loop->dimen - 1) - { - /* We create an OMP_FOR construct for the outermost scalarized loop. */ - init = make_tree_vec (1); - cond = make_tree_vec (1); - incr = make_tree_vec (1); - - /* Cycle statement is implemented with a goto. Exit statement must not - be present for this loop. */ - exit_label = gfc_build_label_decl (NULL_TREE); - TREE_USED (exit_label) = 1; - - /* Label for cycle statements (if needed). */ - tmp = build1_v (LABEL_EXPR, exit_label); - gfc_add_expr_to_block (pbody, tmp); - - stmt = make_node (OMP_FOR); - - TREE_TYPE (stmt) = void_type_node; - OMP_FOR_BODY (stmt) = loopbody = gfc_finish_block (pbody); - - OMP_FOR_CLAUSES (stmt) = build_omp_clause (input_location, - OMP_CLAUSE_SCHEDULE); - OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt)) - = OMP_CLAUSE_SCHEDULE_STATIC; - if (ompws_flags & OMPWS_NOWAIT) - OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt)) - = build_omp_clause (input_location, OMP_CLAUSE_NOWAIT); - - /* Initialize the loopvar. */ - TREE_VEC_ELT (init, 0) = build2_v (MODIFY_EXPR, loop->loopvar[n], - loop->from[n]); - OMP_FOR_INIT (stmt) = init; - /* The exit condition. */ - TREE_VEC_ELT (cond, 0) = build2_loc (input_location, LE_EXPR, - logical_type_node, - loop->loopvar[n], loop->to[n]); - SET_EXPR_LOCATION (TREE_VEC_ELT (cond, 0), input_location); - OMP_FOR_COND (stmt) = cond; - /* Increment the loopvar. */ - tmp = build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - loop->loopvar[n], gfc_index_one_node); - TREE_VEC_ELT (incr, 0) = fold_build2_loc (input_location, MODIFY_EXPR, - void_type_node, loop->loopvar[n], tmp); - OMP_FOR_INCR (stmt) = incr; - - ompws_flags &= ~OMPWS_CURR_SINGLEUNIT; - gfc_add_expr_to_block (&loop->code[n], stmt); - } - else - { - bool reverse_loop = (loop->reverse[n] == GFC_REVERSE_SET) - && (loop->temp_ss == NULL); - - loopbody = gfc_finish_block (pbody); - - if (reverse_loop) - std::swap (loop->from[n], loop->to[n]); - - /* Initialize the loopvar. */ - if (loop->loopvar[n] != loop->from[n]) - gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]); - - exit_label = gfc_build_label_decl (NULL_TREE); - - /* Generate the loop body. */ - gfc_init_block (&block); - - /* The exit condition. */ - cond = fold_build2_loc (input_location, reverse_loop ? LT_EXPR : GT_EXPR, - logical_type_node, loop->loopvar[n], loop->to[n]); - tmp = build1_v (GOTO_EXPR, exit_label); - TREE_USED (exit_label) = 1; - tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location)); - gfc_add_expr_to_block (&block, tmp); - - /* The main body. */ - gfc_add_expr_to_block (&block, loopbody); - - /* Increment the loopvar. */ - tmp = fold_build2_loc (input_location, - reverse_loop ? MINUS_EXPR : PLUS_EXPR, - gfc_array_index_type, loop->loopvar[n], - gfc_index_one_node); - - gfc_add_modify (&block, loop->loopvar[n], tmp); - - /* Build the loop. */ - tmp = gfc_finish_block (&block); - tmp = build1_v (LOOP_EXPR, tmp); - gfc_add_expr_to_block (&loop->code[n], tmp); - - /* Add the exit label. */ - tmp = build1_v (LABEL_EXPR, exit_label); - gfc_add_expr_to_block (&loop->code[n], tmp); - } - -} - - -/* Finishes and generates the loops for a scalarized expression. */ - -void -gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body) -{ - int dim; - int n; - gfc_ss *ss; - stmtblock_t *pblock; - tree tmp; - - pblock = body; - /* Generate the loops. */ - for (dim = 0; dim < loop->dimen; dim++) - { - n = loop->order[dim]; - gfc_trans_scalarized_loop_end (loop, n, pblock); - loop->loopvar[n] = NULL_TREE; - pblock = &loop->code[n]; - } - - tmp = gfc_finish_block (pblock); - gfc_add_expr_to_block (&loop->pre, tmp); - - /* Clear all the used flags. */ - for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) - if (ss->parent == NULL) - ss->info->useflags = 0; -} - - -/* Finish the main body of a scalarized expression, and start the secondary - copying body. */ - -void -gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body) -{ - int dim; - int n; - stmtblock_t *pblock; - gfc_ss *ss; - - pblock = body; - /* We finish as many loops as are used by the temporary. */ - for (dim = 0; dim < loop->temp_dim - 1; dim++) - { - n = loop->order[dim]; - gfc_trans_scalarized_loop_end (loop, n, pblock); - loop->loopvar[n] = NULL_TREE; - pblock = &loop->code[n]; - } - - /* We don't want to finish the outermost loop entirely. */ - n = loop->order[loop->temp_dim - 1]; - gfc_trans_scalarized_loop_end (loop, n, pblock); - - /* Restore the initial offsets. */ - for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) - { - gfc_ss_type ss_type; - gfc_ss_info *ss_info; - - ss_info = ss->info; - - if ((ss_info->useflags & 2) == 0) - continue; - - ss_type = ss_info->type; - if (ss_type != GFC_SS_SECTION - && ss_type != GFC_SS_FUNCTION - && ss_type != GFC_SS_CONSTRUCTOR - && ss_type != GFC_SS_COMPONENT) - continue; - - ss_info->data.array.offset = ss_info->data.array.saved_offset; - } - - /* Restart all the inner loops we just finished. */ - for (dim = loop->temp_dim - 2; dim >= 0; dim--) - { - n = loop->order[dim]; - - gfc_start_block (&loop->code[n]); - - loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q"); - - gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]); - } - - /* Start a block for the secondary copying code. */ - gfc_start_block (body); -} - - -/* Precalculate (either lower or upper) bound of an array section. - BLOCK: Block in which the (pre)calculation code will go. - BOUNDS[DIM]: Where the bound value will be stored once evaluated. - VALUES[DIM]: Specified bound (NULL <=> unspecified). - DESC: Array descriptor from which the bound will be picked if unspecified - (either lower or upper bound according to LBOUND). */ - -static void -evaluate_bound (stmtblock_t *block, tree *bounds, gfc_expr ** values, - tree desc, int dim, bool lbound, bool deferred) -{ - gfc_se se; - gfc_expr * input_val = values[dim]; - tree *output = &bounds[dim]; - - - if (input_val) - { - /* Specified section bound. */ - gfc_init_se (&se, NULL); - gfc_conv_expr_type (&se, input_val, gfc_array_index_type); - gfc_add_block_to_block (block, &se.pre); - *output = se.expr; - } - else if (deferred && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))) - { - /* The gfc_conv_array_lbound () routine returns a constant zero for - deferred length arrays, which in the scalarizer wreaks havoc, when - copying to a (newly allocated) one-based array. - Keep returning the actual result in sync for both bounds. */ - *output = lbound ? gfc_conv_descriptor_lbound_get (desc, - gfc_rank_cst[dim]): - gfc_conv_descriptor_ubound_get (desc, - gfc_rank_cst[dim]); - } - else - { - /* No specific bound specified so use the bound of the array. */ - *output = lbound ? gfc_conv_array_lbound (desc, dim) : - gfc_conv_array_ubound (desc, dim); - } - *output = gfc_evaluate_now (*output, block); -} - - -/* Calculate the lower bound of an array section. */ - -static void -gfc_conv_section_startstride (stmtblock_t * block, gfc_ss * ss, int dim) -{ - gfc_expr *stride = NULL; - tree desc; - gfc_se se; - gfc_array_info *info; - gfc_array_ref *ar; - - gcc_assert (ss->info->type == GFC_SS_SECTION); - - info = &ss->info->data.array; - ar = &info->ref->u.ar; - - if (ar->dimen_type[dim] == DIMEN_VECTOR) - { - /* We use a zero-based index to access the vector. */ - info->start[dim] = gfc_index_zero_node; - info->end[dim] = NULL; - info->stride[dim] = gfc_index_one_node; - return; - } - - gcc_assert (ar->dimen_type[dim] == DIMEN_RANGE - || ar->dimen_type[dim] == DIMEN_THIS_IMAGE); - desc = info->descriptor; - stride = ar->stride[dim]; - - - /* Calculate the start of the range. For vector subscripts this will - be the range of the vector. */ - evaluate_bound (block, info->start, ar->start, desc, dim, true, - ar->as->type == AS_DEFERRED); - - /* Similarly calculate the end. Although this is not used in the - scalarizer, it is needed when checking bounds and where the end - is an expression with side-effects. */ - evaluate_bound (block, info->end, ar->end, desc, dim, false, - ar->as->type == AS_DEFERRED); - - - /* Calculate the stride. */ - if (stride == NULL) - info->stride[dim] = gfc_index_one_node; - else - { - gfc_init_se (&se, NULL); - gfc_conv_expr_type (&se, stride, gfc_array_index_type); - gfc_add_block_to_block (block, &se.pre); - info->stride[dim] = gfc_evaluate_now (se.expr, block); - } -} - - -/* Calculates the range start and stride for a SS chain. Also gets the - descriptor and data pointer. The range of vector subscripts is the size - of the vector. Array bounds are also checked. */ - -void -gfc_conv_ss_startstride (gfc_loopinfo * loop) -{ - int n; - tree tmp; - gfc_ss *ss; - tree desc; - - gfc_loopinfo * const outer_loop = outermost_loop (loop); - - loop->dimen = 0; - /* Determine the rank of the loop. */ - for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) - { - switch (ss->info->type) - { - case GFC_SS_SECTION: - case GFC_SS_CONSTRUCTOR: - case GFC_SS_FUNCTION: - case GFC_SS_COMPONENT: - loop->dimen = ss->dimen; - goto done; - - /* As usual, lbound and ubound are exceptions!. */ - case GFC_SS_INTRINSIC: - switch (ss->info->expr->value.function.isym->id) - { - case GFC_ISYM_LBOUND: - case GFC_ISYM_UBOUND: - case GFC_ISYM_LCOBOUND: - case GFC_ISYM_UCOBOUND: - case GFC_ISYM_SHAPE: - case GFC_ISYM_THIS_IMAGE: - loop->dimen = ss->dimen; - goto done; - - default: - break; - } - - default: - break; - } - } - - /* We should have determined the rank of the expression by now. If - not, that's bad news. */ - gcc_unreachable (); - -done: - /* Loop over all the SS in the chain. */ - for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) - { - gfc_ss_info *ss_info; - gfc_array_info *info; - gfc_expr *expr; - - ss_info = ss->info; - expr = ss_info->expr; - info = &ss_info->data.array; - - if (expr && expr->shape && !info->shape) - info->shape = expr->shape; - - switch (ss_info->type) - { - case GFC_SS_SECTION: - /* Get the descriptor for the array. If it is a cross loops array, - we got the descriptor already in the outermost loop. */ - if (ss->parent == NULL) - gfc_conv_ss_descriptor (&outer_loop->pre, ss, - !loop->array_parameter); - - for (n = 0; n < ss->dimen; n++) - gfc_conv_section_startstride (&outer_loop->pre, ss, ss->dim[n]); - break; - - case GFC_SS_INTRINSIC: - switch (expr->value.function.isym->id) - { - /* Fall through to supply start and stride. */ - case GFC_ISYM_LBOUND: - case GFC_ISYM_UBOUND: - /* This is the variant without DIM=... */ - gcc_assert (expr->value.function.actual->next->expr == NULL); - /* Fall through. */ - - case GFC_ISYM_SHAPE: - { - gfc_expr *arg; - - arg = expr->value.function.actual->expr; - if (arg->rank == -1) - { - gfc_se se; - tree rank, tmp; - - /* The rank (hence the return value's shape) is unknown, - we have to retrieve it. */ - gfc_init_se (&se, NULL); - se.descriptor_only = 1; - gfc_conv_expr (&se, arg); - /* This is a bare variable, so there is no preliminary - or cleanup code. */ - gcc_assert (se.pre.head == NULL_TREE - && se.post.head == NULL_TREE); - rank = gfc_conv_descriptor_rank (se.expr); - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - fold_convert (gfc_array_index_type, - rank), - gfc_index_one_node); - info->end[0] = gfc_evaluate_now (tmp, &outer_loop->pre); - info->start[0] = gfc_index_zero_node; - info->stride[0] = gfc_index_one_node; - continue; - } - /* Otherwise fall through GFC_SS_FUNCTION. */ - gcc_fallthrough (); - } - case GFC_ISYM_LCOBOUND: - case GFC_ISYM_UCOBOUND: - case GFC_ISYM_THIS_IMAGE: - break; - - default: - continue; - } - - /* FALLTHRU */ - case GFC_SS_CONSTRUCTOR: - case GFC_SS_FUNCTION: - for (n = 0; n < ss->dimen; n++) - { - int dim = ss->dim[n]; - - info->start[dim] = gfc_index_zero_node; - info->end[dim] = gfc_index_zero_node; - info->stride[dim] = gfc_index_one_node; - } - break; - - default: - break; - } - } - - /* The rest is just runtime bounds checking. */ - if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) - { - stmtblock_t block; - tree lbound, ubound; - tree end; - tree size[GFC_MAX_DIMENSIONS]; - tree stride_pos, stride_neg, non_zerosized, tmp2, tmp3; - gfc_array_info *info; - char *msg; - int dim; - - gfc_start_block (&block); - - for (n = 0; n < loop->dimen; n++) - size[n] = NULL_TREE; - - for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) - { - stmtblock_t inner; - gfc_ss_info *ss_info; - gfc_expr *expr; - locus *expr_loc; - const char *expr_name; - - ss_info = ss->info; - if (ss_info->type != GFC_SS_SECTION) - continue; - - /* Catch allocatable lhs in f2003. */ - if (flag_realloc_lhs && ss->no_bounds_check) - continue; - - expr = ss_info->expr; - expr_loc = &expr->where; - expr_name = expr->symtree->name; - - gfc_start_block (&inner); - - /* TODO: range checking for mapped dimensions. */ - info = &ss_info->data.array; - - /* This code only checks ranges. Elemental and vector - dimensions are checked later. */ - for (n = 0; n < loop->dimen; n++) - { - bool check_upper; - - dim = ss->dim[n]; - if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE) - continue; - - if (dim == info->ref->u.ar.dimen - 1 - && info->ref->u.ar.as->type == AS_ASSUMED_SIZE) - check_upper = false; - else - check_upper = true; - - /* Zero stride is not allowed. */ - tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, - info->stride[dim], gfc_index_zero_node); - msg = xasprintf ("Zero stride is not allowed, for dimension %d " - "of array '%s'", dim + 1, expr_name); - gfc_trans_runtime_check (true, false, tmp, &inner, - expr_loc, msg); - free (msg); - - desc = info->descriptor; - - /* This is the run-time equivalent of resolve.c's - check_dimension(). The logical is more readable there - than it is here, with all the trees. */ - lbound = gfc_conv_array_lbound (desc, dim); - end = info->end[dim]; - if (check_upper) - ubound = gfc_conv_array_ubound (desc, dim); - else - ubound = NULL; - - /* non_zerosized is true when the selected range is not - empty. */ - stride_pos = fold_build2_loc (input_location, GT_EXPR, - logical_type_node, info->stride[dim], - gfc_index_zero_node); - tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node, - info->start[dim], end); - stride_pos = fold_build2_loc (input_location, TRUTH_AND_EXPR, - logical_type_node, stride_pos, tmp); - - stride_neg = fold_build2_loc (input_location, LT_EXPR, - logical_type_node, - info->stride[dim], gfc_index_zero_node); - tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node, - info->start[dim], end); - stride_neg = fold_build2_loc (input_location, TRUTH_AND_EXPR, - logical_type_node, - stride_neg, tmp); - non_zerosized = fold_build2_loc (input_location, TRUTH_OR_EXPR, - logical_type_node, - stride_pos, stride_neg); - - /* Check the start of the range against the lower and upper - bounds of the array, if the range is not empty. - If upper bound is present, include both bounds in the - error message. */ - if (check_upper) - { - tmp = fold_build2_loc (input_location, LT_EXPR, - logical_type_node, - info->start[dim], lbound); - tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, - logical_type_node, - non_zerosized, tmp); - tmp2 = fold_build2_loc (input_location, GT_EXPR, - logical_type_node, - info->start[dim], ubound); - tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR, - logical_type_node, - non_zerosized, tmp2); - msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' " - "outside of expected range (%%ld:%%ld)", - dim + 1, expr_name); - gfc_trans_runtime_check (true, false, tmp, &inner, - expr_loc, msg, - fold_convert (long_integer_type_node, info->start[dim]), - fold_convert (long_integer_type_node, lbound), - fold_convert (long_integer_type_node, ubound)); - gfc_trans_runtime_check (true, false, tmp2, &inner, - expr_loc, msg, - fold_convert (long_integer_type_node, info->start[dim]), - fold_convert (long_integer_type_node, lbound), - fold_convert (long_integer_type_node, ubound)); - free (msg); - } - else - { - tmp = fold_build2_loc (input_location, LT_EXPR, - logical_type_node, - info->start[dim], lbound); - tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, - logical_type_node, non_zerosized, tmp); - msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' " - "below lower bound of %%ld", - dim + 1, expr_name); - gfc_trans_runtime_check (true, false, tmp, &inner, - expr_loc, msg, - fold_convert (long_integer_type_node, info->start[dim]), - fold_convert (long_integer_type_node, lbound)); - free (msg); - } - - /* Compute the last element of the range, which is not - necessarily "end" (think 0:5:3, which doesn't contain 5) - and check it against both lower and upper bounds. */ - - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, end, - info->start[dim]); - tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR, - gfc_array_index_type, tmp, - info->stride[dim]); - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, end, tmp); - tmp2 = fold_build2_loc (input_location, LT_EXPR, - logical_type_node, tmp, lbound); - tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR, - logical_type_node, non_zerosized, tmp2); - if (check_upper) - { - tmp3 = fold_build2_loc (input_location, GT_EXPR, - logical_type_node, tmp, ubound); - tmp3 = fold_build2_loc (input_location, TRUTH_AND_EXPR, - logical_type_node, non_zerosized, tmp3); - msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' " - "outside of expected range (%%ld:%%ld)", - dim + 1, expr_name); - gfc_trans_runtime_check (true, false, tmp2, &inner, - expr_loc, msg, - fold_convert (long_integer_type_node, tmp), - fold_convert (long_integer_type_node, ubound), - fold_convert (long_integer_type_node, lbound)); - gfc_trans_runtime_check (true, false, tmp3, &inner, - expr_loc, msg, - fold_convert (long_integer_type_node, tmp), - fold_convert (long_integer_type_node, ubound), - fold_convert (long_integer_type_node, lbound)); - free (msg); - } - else - { - msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' " - "below lower bound of %%ld", - dim + 1, expr_name); - gfc_trans_runtime_check (true, false, tmp2, &inner, - expr_loc, msg, - fold_convert (long_integer_type_node, tmp), - fold_convert (long_integer_type_node, lbound)); - free (msg); - } - - /* Check the section sizes match. */ - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, end, - info->start[dim]); - tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, - gfc_array_index_type, tmp, - info->stride[dim]); - tmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, - gfc_index_one_node, tmp); - tmp = fold_build2_loc (input_location, MAX_EXPR, - gfc_array_index_type, tmp, - build_int_cst (gfc_array_index_type, 0)); - /* We remember the size of the first section, and check all the - others against this. */ - if (size[n]) - { - tmp3 = fold_build2_loc (input_location, NE_EXPR, - logical_type_node, tmp, size[n]); - msg = xasprintf ("Array bound mismatch for dimension %d " - "of array '%s' (%%ld/%%ld)", - dim + 1, expr_name); - - gfc_trans_runtime_check (true, false, tmp3, &inner, - expr_loc, msg, - fold_convert (long_integer_type_node, tmp), - fold_convert (long_integer_type_node, size[n])); - - free (msg); - } - else - size[n] = gfc_evaluate_now (tmp, &inner); - } - - tmp = gfc_finish_block (&inner); - - /* For optional arguments, only check bounds if the argument is - present. */ - if ((expr->symtree->n.sym->attr.optional - || expr->symtree->n.sym->attr.not_always_present) - && expr->symtree->n.sym->attr.dummy) - tmp = build3_v (COND_EXPR, - gfc_conv_expr_present (expr->symtree->n.sym), - tmp, build_empty_stmt (input_location)); - - gfc_add_expr_to_block (&block, tmp); - - } - - tmp = gfc_finish_block (&block); - gfc_add_expr_to_block (&outer_loop->pre, tmp); - } - - for (loop = loop->nested; loop; loop = loop->next) - gfc_conv_ss_startstride (loop); -} - -/* Return true if both symbols could refer to the same data object. Does - not take account of aliasing due to equivalence statements. */ - -static int -symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym, bool lsym_pointer, - bool lsym_target, bool rsym_pointer, bool rsym_target) -{ - /* Aliasing isn't possible if the symbols have different base types. */ - if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0) - return 0; - - /* Pointers can point to other pointers and target objects. */ - - if ((lsym_pointer && (rsym_pointer || rsym_target)) - || (rsym_pointer && (lsym_pointer || lsym_target))) - return 1; - - /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7 - and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already - checked above. */ - if (lsym_target && rsym_target - && ((lsym->attr.dummy && !lsym->attr.contiguous - && (!lsym->attr.dimension || lsym->as->type == AS_ASSUMED_SHAPE)) - || (rsym->attr.dummy && !rsym->attr.contiguous - && (!rsym->attr.dimension - || rsym->as->type == AS_ASSUMED_SHAPE)))) - return 1; - - return 0; -} - - -/* Return true if the two SS could be aliased, i.e. both point to the same data - object. */ -/* TODO: resolve aliases based on frontend expressions. */ - -static int -gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss) -{ - gfc_ref *lref; - gfc_ref *rref; - gfc_expr *lexpr, *rexpr; - gfc_symbol *lsym; - gfc_symbol *rsym; - bool lsym_pointer, lsym_target, rsym_pointer, rsym_target; - - lexpr = lss->info->expr; - rexpr = rss->info->expr; - - lsym = lexpr->symtree->n.sym; - rsym = rexpr->symtree->n.sym; - - lsym_pointer = lsym->attr.pointer; - lsym_target = lsym->attr.target; - rsym_pointer = rsym->attr.pointer; - rsym_target = rsym->attr.target; - - if (symbols_could_alias (lsym, rsym, lsym_pointer, lsym_target, - rsym_pointer, rsym_target)) - return 1; - - if (rsym->ts.type != BT_DERIVED && rsym->ts.type != BT_CLASS - && lsym->ts.type != BT_DERIVED && lsym->ts.type != BT_CLASS) - return 0; - - /* For derived types we must check all the component types. We can ignore - array references as these will have the same base type as the previous - component ref. */ - for (lref = lexpr->ref; lref != lss->info->data.array.ref; lref = lref->next) - { - if (lref->type != REF_COMPONENT) - continue; - - lsym_pointer = lsym_pointer || lref->u.c.sym->attr.pointer; - lsym_target = lsym_target || lref->u.c.sym->attr.target; - - if (symbols_could_alias (lref->u.c.sym, rsym, lsym_pointer, lsym_target, - rsym_pointer, rsym_target)) - return 1; - - if ((lsym_pointer && (rsym_pointer || rsym_target)) - || (rsym_pointer && (lsym_pointer || lsym_target))) - { - if (gfc_compare_types (&lref->u.c.component->ts, - &rsym->ts)) - return 1; - } - - for (rref = rexpr->ref; rref != rss->info->data.array.ref; - rref = rref->next) - { - if (rref->type != REF_COMPONENT) - continue; - - rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer; - rsym_target = lsym_target || rref->u.c.sym->attr.target; - - if (symbols_could_alias (lref->u.c.sym, rref->u.c.sym, - lsym_pointer, lsym_target, - rsym_pointer, rsym_target)) - return 1; - - if ((lsym_pointer && (rsym_pointer || rsym_target)) - || (rsym_pointer && (lsym_pointer || lsym_target))) - { - if (gfc_compare_types (&lref->u.c.component->ts, - &rref->u.c.sym->ts)) - return 1; - if (gfc_compare_types (&lref->u.c.sym->ts, - &rref->u.c.component->ts)) - return 1; - if (gfc_compare_types (&lref->u.c.component->ts, - &rref->u.c.component->ts)) - return 1; - } - } - } - - lsym_pointer = lsym->attr.pointer; - lsym_target = lsym->attr.target; - - for (rref = rexpr->ref; rref != rss->info->data.array.ref; rref = rref->next) - { - if (rref->type != REF_COMPONENT) - break; - - rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer; - rsym_target = lsym_target || rref->u.c.sym->attr.target; - - if (symbols_could_alias (rref->u.c.sym, lsym, - lsym_pointer, lsym_target, - rsym_pointer, rsym_target)) - return 1; - - if ((lsym_pointer && (rsym_pointer || rsym_target)) - || (rsym_pointer && (lsym_pointer || lsym_target))) - { - if (gfc_compare_types (&lsym->ts, &rref->u.c.component->ts)) - return 1; - } - } - - return 0; -} - - -/* Resolve array data dependencies. Creates a temporary if required. */ -/* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to - dependency.c. */ - -void -gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest, - gfc_ss * rss) -{ - gfc_ss *ss; - gfc_ref *lref; - gfc_ref *rref; - gfc_ss_info *ss_info; - gfc_expr *dest_expr; - gfc_expr *ss_expr; - int nDepend = 0; - int i, j; - - loop->temp_ss = NULL; - dest_expr = dest->info->expr; - - for (ss = rss; ss != gfc_ss_terminator; ss = ss->next) - { - ss_info = ss->info; - ss_expr = ss_info->expr; - - if (ss_info->array_outer_dependency) - { - nDepend = 1; - break; - } - - if (ss_info->type != GFC_SS_SECTION) - { - if (flag_realloc_lhs - && dest_expr != ss_expr - && gfc_is_reallocatable_lhs (dest_expr) - && ss_expr->rank) - nDepend = gfc_check_dependency (dest_expr, ss_expr, true); - - /* Check for cases like c(:)(1:2) = c(2)(2:3) */ - if (!nDepend && dest_expr->rank > 0 - && dest_expr->ts.type == BT_CHARACTER - && ss_expr->expr_type == EXPR_VARIABLE) - - nDepend = gfc_check_dependency (dest_expr, ss_expr, false); - - if (ss_info->type == GFC_SS_REFERENCE - && gfc_check_dependency (dest_expr, ss_expr, false)) - ss_info->data.scalar.needs_temporary = 1; - - if (nDepend) - break; - else - continue; - } - - if (dest_expr->symtree->n.sym != ss_expr->symtree->n.sym) - { - if (gfc_could_be_alias (dest, ss) - || gfc_are_equivalenced_arrays (dest_expr, ss_expr)) - { - nDepend = 1; - break; - } - } - else - { - lref = dest_expr->ref; - rref = ss_expr->ref; - - nDepend = gfc_dep_resolver (lref, rref, &loop->reverse[0]); - - if (nDepend == 1) - break; - - for (i = 0; i < dest->dimen; i++) - for (j = 0; j < ss->dimen; j++) - if (i != j - && dest->dim[i] == ss->dim[j]) - { - /* If we don't access array elements in the same order, - there is a dependency. */ - nDepend = 1; - goto temporary; - } -#if 0 - /* TODO : loop shifting. */ - if (nDepend == 1) - { - /* Mark the dimensions for LOOP SHIFTING */ - for (n = 0; n < loop->dimen; n++) - { - int dim = dest->data.info.dim[n]; - - if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR) - depends[n] = 2; - else if (! gfc_is_same_range (&lref->u.ar, - &rref->u.ar, dim, 0)) - depends[n] = 1; - } - - /* Put all the dimensions with dependencies in the - innermost loops. */ - dim = 0; - for (n = 0; n < loop->dimen; n++) - { - gcc_assert (loop->order[n] == n); - if (depends[n]) - loop->order[dim++] = n; - } - for (n = 0; n < loop->dimen; n++) - { - if (! depends[n]) - loop->order[dim++] = n; - } - - gcc_assert (dim == loop->dimen); - break; - } -#endif - } - } - -temporary: - - if (nDepend == 1) - { - tree base_type = gfc_typenode_for_spec (&dest_expr->ts); - if (GFC_ARRAY_TYPE_P (base_type) - || GFC_DESCRIPTOR_TYPE_P (base_type)) - base_type = gfc_get_element_type (base_type); - loop->temp_ss = gfc_get_temp_ss (base_type, dest->info->string_length, - loop->dimen); - gfc_add_ss_to_loop (loop, loop->temp_ss); - } - else - loop->temp_ss = NULL; -} - - -/* Browse through each array's information from the scalarizer and set the loop - bounds according to the "best" one (per dimension), i.e. the one which - provides the most information (constant bounds, shape, etc.). */ - -static void -set_loop_bounds (gfc_loopinfo *loop) -{ - int n, dim, spec_dim; - gfc_array_info *info; - gfc_array_info *specinfo; - gfc_ss *ss; - tree tmp; - gfc_ss **loopspec; - bool dynamic[GFC_MAX_DIMENSIONS]; - mpz_t *cshape; - mpz_t i; - bool nonoptional_arr; - - gfc_loopinfo * const outer_loop = outermost_loop (loop); - - loopspec = loop->specloop; - - mpz_init (i); - for (n = 0; n < loop->dimen; n++) - { - loopspec[n] = NULL; - dynamic[n] = false; - - /* If there are both optional and nonoptional array arguments, scalarize - over the nonoptional; otherwise, it does not matter as then all - (optional) arrays have to be present per F2008, 125.2.12p3(6). */ - - nonoptional_arr = false; - - for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) - if (ss->info->type != GFC_SS_SCALAR && ss->info->type != GFC_SS_TEMP - && ss->info->type != GFC_SS_REFERENCE && !ss->info->can_be_null_ref) - { - nonoptional_arr = true; - break; - } - - /* We use one SS term, and use that to determine the bounds of the - loop for this dimension. We try to pick the simplest term. */ - for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) - { - gfc_ss_type ss_type; - - ss_type = ss->info->type; - if (ss_type == GFC_SS_SCALAR - || ss_type == GFC_SS_TEMP - || ss_type == GFC_SS_REFERENCE - || (ss->info->can_be_null_ref && nonoptional_arr)) - continue; - - info = &ss->info->data.array; - dim = ss->dim[n]; - - if (loopspec[n] != NULL) - { - specinfo = &loopspec[n]->info->data.array; - spec_dim = loopspec[n]->dim[n]; - } - else - { - /* Silence uninitialized warnings. */ - specinfo = NULL; - spec_dim = 0; - } - - if (info->shape) - { - /* The frontend has worked out the size for us. */ - if (!loopspec[n] - || !specinfo->shape - || !integer_zerop (specinfo->start[spec_dim])) - /* Prefer zero-based descriptors if possible. */ - loopspec[n] = ss; - continue; - } - - if (ss_type == GFC_SS_CONSTRUCTOR) - { - gfc_constructor_base base; - /* An unknown size constructor will always be rank one. - Higher rank constructors will either have known shape, - or still be wrapped in a call to reshape. */ - gcc_assert (loop->dimen == 1); - - /* Always prefer to use the constructor bounds if the size - can be determined at compile time. Prefer not to otherwise, - since the general case involves realloc, and it's better to - avoid that overhead if possible. */ - base = ss->info->expr->value.constructor; - dynamic[n] = gfc_get_array_constructor_size (&i, base); - if (!dynamic[n] || !loopspec[n]) - loopspec[n] = ss; - continue; - } - - /* Avoid using an allocatable lhs in an assignment, since - there might be a reallocation coming. */ - if (loopspec[n] && ss->is_alloc_lhs) - continue; - - if (!loopspec[n]) - loopspec[n] = ss; - /* Criteria for choosing a loop specifier (most important first): - doesn't need realloc - stride of one - known stride - known lower bound - known upper bound - */ - else if (loopspec[n]->info->type == GFC_SS_CONSTRUCTOR && dynamic[n]) - loopspec[n] = ss; - else if (integer_onep (info->stride[dim]) - && !integer_onep (specinfo->stride[spec_dim])) - loopspec[n] = ss; - else if (INTEGER_CST_P (info->stride[dim]) - && !INTEGER_CST_P (specinfo->stride[spec_dim])) - loopspec[n] = ss; - else if (INTEGER_CST_P (info->start[dim]) - && !INTEGER_CST_P (specinfo->start[spec_dim]) - && integer_onep (info->stride[dim]) - == integer_onep (specinfo->stride[spec_dim]) - && INTEGER_CST_P (info->stride[dim]) - == INTEGER_CST_P (specinfo->stride[spec_dim])) - loopspec[n] = ss; - /* We don't work out the upper bound. - else if (INTEGER_CST_P (info->finish[n]) - && ! INTEGER_CST_P (specinfo->finish[n])) - loopspec[n] = ss; */ - } - - /* We should have found the scalarization loop specifier. If not, - that's bad news. */ - gcc_assert (loopspec[n]); - - info = &loopspec[n]->info->data.array; - dim = loopspec[n]->dim[n]; - - /* Set the extents of this range. */ - cshape = info->shape; - if (cshape && INTEGER_CST_P (info->start[dim]) - && INTEGER_CST_P (info->stride[dim])) - { - loop->from[n] = info->start[dim]; - mpz_set (i, cshape[get_array_ref_dim_for_loop_dim (loopspec[n], n)]); - mpz_sub_ui (i, i, 1); - /* To = from + (size - 1) * stride. */ - tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind); - if (!integer_onep (info->stride[dim])) - tmp = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, tmp, - info->stride[dim]); - loop->to[n] = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, - loop->from[n], tmp); - } - else - { - loop->from[n] = info->start[dim]; - switch (loopspec[n]->info->type) - { - case GFC_SS_CONSTRUCTOR: - /* The upper bound is calculated when we expand the - constructor. */ - gcc_assert (loop->to[n] == NULL_TREE); - break; - - case GFC_SS_SECTION: - /* Use the end expression if it exists and is not constant, - so that it is only evaluated once. */ - loop->to[n] = info->end[dim]; - break; - - case GFC_SS_FUNCTION: - /* The loop bound will be set when we generate the call. */ - gcc_assert (loop->to[n] == NULL_TREE); - break; - - case GFC_SS_INTRINSIC: - { - gfc_expr *expr = loopspec[n]->info->expr; - - /* The {l,u}bound of an assumed rank. */ - if (expr->value.function.isym->id == GFC_ISYM_SHAPE) - gcc_assert (expr->value.function.actual->expr->rank == -1); - else - gcc_assert ((expr->value.function.isym->id == GFC_ISYM_LBOUND - || expr->value.function.isym->id == GFC_ISYM_UBOUND) - && expr->value.function.actual->next->expr == NULL - && expr->value.function.actual->expr->rank == -1); - - loop->to[n] = info->end[dim]; - break; - } - - case GFC_SS_COMPONENT: - { - if (info->end[dim] != NULL_TREE) - { - loop->to[n] = info->end[dim]; - break; - } - else - gcc_unreachable (); - } - - default: - gcc_unreachable (); - } - } - - /* Transform everything so we have a simple incrementing variable. */ - if (integer_onep (info->stride[dim])) - info->delta[dim] = gfc_index_zero_node; - else - { - /* Set the delta for this section. */ - info->delta[dim] = gfc_evaluate_now (loop->from[n], &outer_loop->pre); - /* Number of iterations is (end - start + step) / step. - with start = 0, this simplifies to - last = end / step; - for (i = 0; i<=last; i++){...}; */ - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, loop->to[n], - loop->from[n]); - tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, - gfc_array_index_type, tmp, info->stride[dim]); - tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type, - tmp, build_int_cst (gfc_array_index_type, -1)); - loop->to[n] = gfc_evaluate_now (tmp, &outer_loop->pre); - /* Make the loop variable start at 0. */ - loop->from[n] = gfc_index_zero_node; - } - } - mpz_clear (i); - - for (loop = loop->nested; loop; loop = loop->next) - set_loop_bounds (loop); -} - - -/* Initialize the scalarization loop. Creates the loop variables. Determines - the range of the loop variables. Creates a temporary if required. - Also generates code for scalar expressions which have been - moved outside the loop. */ - -void -gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) -{ - gfc_ss *tmp_ss; - tree tmp; - - set_loop_bounds (loop); - - /* Add all the scalar code that can be taken out of the loops. - This may include calculating the loop bounds, so do it before - allocating the temporary. */ - gfc_add_loop_ss_code (loop, loop->ss, false, where); - - tmp_ss = loop->temp_ss; - /* If we want a temporary then create it. */ - if (tmp_ss != NULL) - { - gfc_ss_info *tmp_ss_info; - - tmp_ss_info = tmp_ss->info; - gcc_assert (tmp_ss_info->type == GFC_SS_TEMP); - gcc_assert (loop->parent == NULL); - - /* Make absolutely sure that this is a complete type. */ - if (tmp_ss_info->string_length) - tmp_ss_info->data.temp.type - = gfc_get_character_type_len_for_eltype - (TREE_TYPE (tmp_ss_info->data.temp.type), - tmp_ss_info->string_length); - - tmp = tmp_ss_info->data.temp.type; - memset (&tmp_ss_info->data.array, 0, sizeof (gfc_array_info)); - tmp_ss_info->type = GFC_SS_SECTION; - - gcc_assert (tmp_ss->dimen != 0); - - gfc_trans_create_temp_array (&loop->pre, &loop->post, tmp_ss, tmp, - NULL_TREE, false, true, false, where); - } - - /* For array parameters we don't have loop variables, so don't calculate the - translations. */ - if (!loop->array_parameter) - gfc_set_delta (loop); -} - - -/* Calculates how to transform from loop variables to array indices for each - array: once loop bounds are chosen, sets the difference (DELTA field) between - loop bounds and array reference bounds, for each array info. */ - -void -gfc_set_delta (gfc_loopinfo *loop) -{ - gfc_ss *ss, **loopspec; - gfc_array_info *info; - tree tmp; - int n, dim; - - gfc_loopinfo * const outer_loop = outermost_loop (loop); - - loopspec = loop->specloop; - - /* Calculate the translation from loop variables to array indices. */ - for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) - { - gfc_ss_type ss_type; - - ss_type = ss->info->type; - if (ss_type != GFC_SS_SECTION - && ss_type != GFC_SS_COMPONENT - && ss_type != GFC_SS_CONSTRUCTOR) - continue; - - info = &ss->info->data.array; - - for (n = 0; n < ss->dimen; n++) - { - /* If we are specifying the range the delta is already set. */ - if (loopspec[n] != ss) - { - dim = ss->dim[n]; - - /* Calculate the offset relative to the loop variable. - First multiply by the stride. */ - tmp = loop->from[n]; - if (!integer_onep (info->stride[dim])) - tmp = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, - tmp, info->stride[dim]); - - /* Then subtract this from our starting value. */ - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - info->start[dim], tmp); - - info->delta[dim] = gfc_evaluate_now (tmp, &outer_loop->pre); - } - } - } - - for (loop = loop->nested; loop; loop = loop->next) - gfc_set_delta (loop); -} - - -/* Calculate the size of a given array dimension from the bounds. This - is simply (ubound - lbound + 1) if this expression is positive - or 0 if it is negative (pick either one if it is zero). Optionally - (if or_expr is present) OR the (expression != 0) condition to it. */ - -tree -gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr) -{ - tree res; - tree cond; - - /* Calculate (ubound - lbound + 1). */ - res = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, - ubound, lbound); - res = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, res, - gfc_index_one_node); - - /* Check whether the size for this dimension is negative. */ - cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, res, - gfc_index_zero_node); - res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond, - gfc_index_zero_node, res); - - /* Build OR expression. */ - if (or_expr) - *or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR, - logical_type_node, *or_expr, cond); - - return res; -} - - -/* For an array descriptor, get the total number of elements. This is just - the product of the extents along from_dim to to_dim. */ - -static tree -gfc_conv_descriptor_size_1 (tree desc, int from_dim, int to_dim) -{ - tree res; - int dim; - - res = gfc_index_one_node; - - for (dim = from_dim; dim < to_dim; ++dim) - { - tree lbound; - tree ubound; - tree extent; - - lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]); - ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]); - - extent = gfc_conv_array_extent_dim (lbound, ubound, NULL); - res = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - res, extent); - } - - return res; -} - - -/* Full size of an array. */ - -tree -gfc_conv_descriptor_size (tree desc, int rank) -{ - return gfc_conv_descriptor_size_1 (desc, 0, rank); -} - - -/* Size of a coarray for all dimensions but the last. */ - -tree -gfc_conv_descriptor_cosize (tree desc, int rank, int corank) -{ - return gfc_conv_descriptor_size_1 (desc, rank, rank + corank - 1); -} - - -/* Fills in an array descriptor, and returns the size of the array. - The size will be a simple_val, ie a variable or a constant. Also - calculates the offset of the base. The pointer argument overflow, - which should be of integer type, will increase in value if overflow - occurs during the size calculation. Returns the size of the array. - { - stride = 1; - offset = 0; - for (n = 0; n < rank; n++) - { - a.lbound[n] = specified_lower_bound; - offset = offset + a.lbond[n] * stride; - size = 1 - lbound; - a.ubound[n] = specified_upper_bound; - a.stride[n] = stride; - size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound - overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0); - stride = stride * size; - } - for (n = rank; n < rank+corank; n++) - (Set lcobound/ucobound as above.) - element_size = sizeof (array element); - if (!rank) - return element_size - stride = (size_t) stride; - overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0); - stride = stride * element_size; - return (stride); - } */ -/*GCC ARRAYS*/ - -static tree -gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, - gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock, - stmtblock_t * descriptor_block, tree * overflow, - tree expr3_elem_size, tree *nelems, gfc_expr *expr3, - tree expr3_desc, bool e3_has_nodescriptor, gfc_expr *expr, - tree *element_size) -{ - tree type; - tree tmp; - tree size; - tree offset; - tree stride; - tree or_expr; - tree thencase; - tree elsecase; - tree cond; - tree var; - stmtblock_t thenblock; - stmtblock_t elseblock; - gfc_expr *ubound; - gfc_se se; - int n; - - type = TREE_TYPE (descriptor); - - stride = gfc_index_one_node; - offset = gfc_index_zero_node; - - /* Set the dtype before the alloc, because registration of coarrays needs - it initialized. */ - if (expr->ts.type == BT_CHARACTER - && expr->ts.deferred - && VAR_P (expr->ts.u.cl->backend_decl)) - { - type = gfc_typenode_for_spec (&expr->ts); - tmp = gfc_conv_descriptor_dtype (descriptor); - gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type)); - } - else if (expr->ts.type == BT_CHARACTER - && expr->ts.deferred - && TREE_CODE (descriptor) == COMPONENT_REF) - { - /* Deferred character components have their string length tucked away - in a hidden field of the derived type. Obtain that and use it to - set the dtype. The charlen backend decl is zero because the field - type is zero length. */ - gfc_ref *ref; - tmp = NULL_TREE; - for (ref = expr->ref; ref; ref = ref->next) - if (ref->type == REF_COMPONENT - && gfc_deferred_strlen (ref->u.c.component, &tmp)) - break; - gcc_assert (tmp != NULL_TREE); - tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp), - TREE_OPERAND (descriptor, 0), tmp, NULL_TREE); - tmp = fold_convert (gfc_charlen_type_node, tmp); - type = gfc_get_character_type_len (expr->ts.kind, tmp); - tmp = gfc_conv_descriptor_dtype (descriptor); - gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type)); - } - else - { - tmp = gfc_conv_descriptor_dtype (descriptor); - gfc_add_modify (pblock, tmp, gfc_get_dtype (type)); - } - - or_expr = logical_false_node; - - for (n = 0; n < rank; n++) - { - tree conv_lbound; - tree conv_ubound; - - /* We have 3 possibilities for determining the size of the array: - lower == NULL => lbound = 1, ubound = upper[n] - upper[n] = NULL => lbound = 1, ubound = lower[n] - upper[n] != NULL => lbound = lower[n], ubound = upper[n] */ - ubound = upper[n]; - - /* Set lower bound. */ - gfc_init_se (&se, NULL); - if (expr3_desc != NULL_TREE) - { - if (e3_has_nodescriptor) - /* The lbound of nondescriptor arrays like array constructors, - nonallocatable/nonpointer function results/variables, - start at zero, but when allocating it, the standard expects - the array to start at one. */ - se.expr = gfc_index_one_node; - else - se.expr = gfc_conv_descriptor_lbound_get (expr3_desc, - gfc_rank_cst[n]); - } - else if (lower == NULL) - se.expr = gfc_index_one_node; - else - { - gcc_assert (lower[n]); - if (ubound) - { - gfc_conv_expr_type (&se, lower[n], gfc_array_index_type); - gfc_add_block_to_block (pblock, &se.pre); - } - else - { - se.expr = gfc_index_one_node; - ubound = lower[n]; - } - } - gfc_conv_descriptor_lbound_set (descriptor_block, descriptor, - gfc_rank_cst[n], se.expr); - conv_lbound = se.expr; - - /* Work out the offset for this component. */ - tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - se.expr, stride); - offset = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, offset, tmp); - - /* Set upper bound. */ - gfc_init_se (&se, NULL); - if (expr3_desc != NULL_TREE) - { - if (e3_has_nodescriptor) - { - /* The lbound of nondescriptor arrays like array constructors, - nonallocatable/nonpointer function results/variables, - start at zero, but when allocating it, the standard expects - the array to start at one. Therefore fix the upper bound to be - (desc.ubound - desc.lbound) + 1. */ - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - gfc_conv_descriptor_ubound_get ( - expr3_desc, gfc_rank_cst[n]), - gfc_conv_descriptor_lbound_get ( - expr3_desc, gfc_rank_cst[n])); - tmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, tmp, - gfc_index_one_node); - se.expr = gfc_evaluate_now (tmp, pblock); - } - else - se.expr = gfc_conv_descriptor_ubound_get (expr3_desc, - gfc_rank_cst[n]); - } - else - { - gcc_assert (ubound); - gfc_conv_expr_type (&se, ubound, gfc_array_index_type); - gfc_add_block_to_block (pblock, &se.pre); - if (ubound->expr_type == EXPR_FUNCTION) - se.expr = gfc_evaluate_now (se.expr, pblock); - } - gfc_conv_descriptor_ubound_set (descriptor_block, descriptor, - gfc_rank_cst[n], se.expr); - conv_ubound = se.expr; - - /* Store the stride. */ - gfc_conv_descriptor_stride_set (descriptor_block, descriptor, - gfc_rank_cst[n], stride); - - /* Calculate size and check whether extent is negative. */ - size = gfc_conv_array_extent_dim (conv_lbound, conv_ubound, &or_expr); - size = gfc_evaluate_now (size, pblock); - - /* Check whether multiplying the stride by the number of - elements in this dimension would overflow. We must also check - whether the current dimension has zero size in order to avoid - division by zero. - */ - tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, - gfc_array_index_type, - fold_convert (gfc_array_index_type, - TYPE_MAX_VALUE (gfc_array_index_type)), - size); - cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR, - logical_type_node, tmp, stride), - PRED_FORTRAN_OVERFLOW); - tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond, - integer_one_node, integer_zero_node); - cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR, - logical_type_node, size, - gfc_index_zero_node), - PRED_FORTRAN_SIZE_ZERO); - tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond, - integer_zero_node, tmp); - tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node, - *overflow, tmp); - *overflow = gfc_evaluate_now (tmp, pblock); - - /* Multiply the stride by the number of elements in this dimension. */ - stride = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, stride, size); - stride = gfc_evaluate_now (stride, pblock); - } - - for (n = rank; n < rank + corank; n++) - { - ubound = upper[n]; - - /* Set lower bound. */ - gfc_init_se (&se, NULL); - if (lower == NULL || lower[n] == NULL) - { - gcc_assert (n == rank + corank - 1); - se.expr = gfc_index_one_node; - } - else - { - if (ubound || n == rank + corank - 1) - { - gfc_conv_expr_type (&se, lower[n], gfc_array_index_type); - gfc_add_block_to_block (pblock, &se.pre); - } - else - { - se.expr = gfc_index_one_node; - ubound = lower[n]; - } - } - gfc_conv_descriptor_lbound_set (descriptor_block, descriptor, - gfc_rank_cst[n], se.expr); - - if (n < rank + corank - 1) - { - gfc_init_se (&se, NULL); - gcc_assert (ubound); - gfc_conv_expr_type (&se, ubound, gfc_array_index_type); - gfc_add_block_to_block (pblock, &se.pre); - gfc_conv_descriptor_ubound_set (descriptor_block, descriptor, - gfc_rank_cst[n], se.expr); - } - } - - /* The stride is the number of elements in the array, so multiply by the - size of an element to get the total size. Obviously, if there is a - SOURCE expression (expr3) we must use its element size. */ - if (expr3_elem_size != NULL_TREE) - tmp = expr3_elem_size; - else if (expr3 != NULL) - { - if (expr3->ts.type == BT_CLASS) - { - gfc_se se_sz; - gfc_expr *sz = gfc_copy_expr (expr3); - gfc_add_vptr_component (sz); - gfc_add_size_component (sz); - gfc_init_se (&se_sz, NULL); - gfc_conv_expr (&se_sz, sz); - gfc_free_expr (sz); - tmp = se_sz.expr; - } - else - { - tmp = gfc_typenode_for_spec (&expr3->ts); - tmp = TYPE_SIZE_UNIT (tmp); - } - } - else - tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type)); - - /* Convert to size_t. */ - *element_size = fold_convert (size_type_node, tmp); - - if (rank == 0) - return *element_size; - - *nelems = gfc_evaluate_now (stride, pblock); - stride = fold_convert (size_type_node, stride); - - /* First check for overflow. Since an array of type character can - have zero element_size, we must check for that before - dividing. */ - tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, - size_type_node, - TYPE_MAX_VALUE (size_type_node), *element_size); - cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR, - logical_type_node, tmp, stride), - PRED_FORTRAN_OVERFLOW); - tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond, - integer_one_node, integer_zero_node); - cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR, - logical_type_node, *element_size, - build_int_cst (size_type_node, 0)), - PRED_FORTRAN_SIZE_ZERO); - tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond, - integer_zero_node, tmp); - tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node, - *overflow, tmp); - *overflow = gfc_evaluate_now (tmp, pblock); - - size = fold_build2_loc (input_location, MULT_EXPR, size_type_node, - stride, *element_size); - - if (poffset != NULL) - { - offset = gfc_evaluate_now (offset, pblock); - *poffset = offset; - } - - if (integer_zerop (or_expr)) - return size; - if (integer_onep (or_expr)) - return build_int_cst (size_type_node, 0); - - var = gfc_create_var (TREE_TYPE (size), "size"); - gfc_start_block (&thenblock); - gfc_add_modify (&thenblock, var, build_int_cst (size_type_node, 0)); - thencase = gfc_finish_block (&thenblock); - - gfc_start_block (&elseblock); - gfc_add_modify (&elseblock, var, size); - elsecase = gfc_finish_block (&elseblock); - - tmp = gfc_evaluate_now (or_expr, pblock); - tmp = build3_v (COND_EXPR, tmp, thencase, elsecase); - gfc_add_expr_to_block (pblock, tmp); - - return var; -} - - -/* Retrieve the last ref from the chain. This routine is specific to - gfc_array_allocate ()'s needs. */ - -bool -retrieve_last_ref (gfc_ref **ref_in, gfc_ref **prev_ref_in) -{ - gfc_ref *ref, *prev_ref; - - ref = *ref_in; - /* Prevent warnings for uninitialized variables. */ - prev_ref = *prev_ref_in; - while (ref && ref->next != NULL) - { - gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT - || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0)); - prev_ref = ref; - ref = ref->next; - } - - if (ref == NULL || ref->type != REF_ARRAY) - return false; - - *ref_in = ref; - *prev_ref_in = prev_ref; - return true; -} - -/* Initializes the descriptor and generates a call to _gfor_allocate. Does - the work for an ALLOCATE statement. */ -/*GCC ARRAYS*/ - -bool -gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, - tree errlen, tree label_finish, tree expr3_elem_size, - tree *nelems, gfc_expr *expr3, tree e3_arr_desc, - bool e3_has_nodescriptor) -{ - tree tmp; - tree pointer; - tree offset = NULL_TREE; - tree token = NULL_TREE; - tree size; - tree msg; - tree error = NULL_TREE; - tree overflow; /* Boolean storing whether size calculation overflows. */ - tree var_overflow = NULL_TREE; - tree cond; - tree set_descriptor; - tree not_prev_allocated = NULL_TREE; - tree element_size = NULL_TREE; - stmtblock_t set_descriptor_block; - stmtblock_t elseblock; - gfc_expr **lower; - gfc_expr **upper; - gfc_ref *ref, *prev_ref = NULL, *coref; - bool allocatable, coarray, dimension, alloc_w_e3_arr_spec = false, - non_ulimate_coarray_ptr_comp; - - ref = expr->ref; - - /* Find the last reference in the chain. */ - if (!retrieve_last_ref (&ref, &prev_ref)) - return false; - - /* Take the allocatable and coarray properties solely from the expr-ref's - attributes and not from source=-expression. */ - if (!prev_ref) - { - allocatable = expr->symtree->n.sym->attr.allocatable; - dimension = expr->symtree->n.sym->attr.dimension; - non_ulimate_coarray_ptr_comp = false; - } - else - { - allocatable = prev_ref->u.c.component->attr.allocatable; - /* Pointer components in coarrayed derived types must be treated - specially in that they are registered without a check if the are - already associated. This does not hold for ultimate coarray - pointers. */ - non_ulimate_coarray_ptr_comp = (prev_ref->u.c.component->attr.pointer - && !prev_ref->u.c.component->attr.codimension); - dimension = prev_ref->u.c.component->attr.dimension; - } - - /* For allocatable/pointer arrays in derived types, one of the refs has to be - a coarray. In this case it does not matter whether we are on this_image - or not. */ - coarray = false; - for (coref = expr->ref; coref; coref = coref->next) - if (coref->type == REF_ARRAY && coref->u.ar.codimen > 0) - { - coarray = true; - break; - } - - if (!dimension) - gcc_assert (coarray); - - if (ref->u.ar.type == AR_FULL && expr3 != NULL) - { - gfc_ref *old_ref = ref; - /* F08:C633: Array shape from expr3. */ - ref = expr3->ref; - - /* Find the last reference in the chain. */ - if (!retrieve_last_ref (&ref, &prev_ref)) - { - if (expr3->expr_type == EXPR_FUNCTION - && gfc_expr_attr (expr3).dimension) - ref = old_ref; - else - return false; - } - alloc_w_e3_arr_spec = true; - } - - /* Figure out the size of the array. */ - switch (ref->u.ar.type) - { - case AR_ELEMENT: - if (!coarray) - { - lower = NULL; - upper = ref->u.ar.start; - break; - } - /* Fall through. */ - - case AR_SECTION: - lower = ref->u.ar.start; - upper = ref->u.ar.end; - break; - - case AR_FULL: - gcc_assert (ref->u.ar.as->type == AS_EXPLICIT - || alloc_w_e3_arr_spec); - - lower = ref->u.ar.as->lower; - upper = ref->u.ar.as->upper; - break; - - default: - gcc_unreachable (); - break; - } - - overflow = integer_zero_node; - - if (expr->ts.type == BT_CHARACTER - && TREE_CODE (se->string_length) == COMPONENT_REF - && expr->ts.u.cl->backend_decl != se->string_length - && VAR_P (expr->ts.u.cl->backend_decl)) - gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl, - fold_convert (TREE_TYPE (expr->ts.u.cl->backend_decl), - se->string_length)); - - gfc_init_block (&set_descriptor_block); - /* Take the corank only from the actual ref and not from the coref. The - later will mislead the generation of the array dimensions for allocatable/ - pointer components in derived types. */ - size = gfc_array_init_size (se->expr, alloc_w_e3_arr_spec ? expr->rank - : ref->u.ar.as->rank, - coarray ? ref->u.ar.as->corank : 0, - &offset, lower, upper, - &se->pre, &set_descriptor_block, &overflow, - expr3_elem_size, nelems, expr3, e3_arr_desc, - e3_has_nodescriptor, expr, &element_size); - - if (dimension) - { - var_overflow = gfc_create_var (integer_type_node, "overflow"); - gfc_add_modify (&se->pre, var_overflow, overflow); - - if (status == NULL_TREE) - { - /* Generate the block of code handling overflow. */ - msg = gfc_build_addr_expr (pchar_type_node, - gfc_build_localized_cstring_const - ("Integer overflow when calculating the amount of " - "memory to allocate")); - error = build_call_expr_loc (input_location, - gfor_fndecl_runtime_error, 1, msg); - } - else - { - tree status_type = TREE_TYPE (status); - stmtblock_t set_status_block; - - gfc_start_block (&set_status_block); - gfc_add_modify (&set_status_block, status, - build_int_cst (status_type, LIBERROR_ALLOCATION)); - error = gfc_finish_block (&set_status_block); - } - } - - /* Allocate memory to store the data. */ - if (POINTER_TYPE_P (TREE_TYPE (se->expr))) - se->expr = build_fold_indirect_ref_loc (input_location, se->expr); - - if (coarray && flag_coarray == GFC_FCOARRAY_LIB) - { - pointer = non_ulimate_coarray_ptr_comp ? se->expr - : gfc_conv_descriptor_data_get (se->expr); - token = gfc_conv_descriptor_token (se->expr); - token = gfc_build_addr_expr (NULL_TREE, token); - } - else - pointer = gfc_conv_descriptor_data_get (se->expr); - STRIP_NOPS (pointer); - - if (allocatable) - { - not_prev_allocated = gfc_create_var (logical_type_node, - "not_prev_allocated"); - tmp = fold_build2_loc (input_location, EQ_EXPR, - logical_type_node, pointer, - build_int_cst (TREE_TYPE (pointer), 0)); - - gfc_add_modify (&se->pre, not_prev_allocated, tmp); - } - - gfc_start_block (&elseblock); - - /* The allocatable variant takes the old pointer as first argument. */ - if (allocatable) - gfc_allocate_allocatable (&elseblock, pointer, size, token, - status, errmsg, errlen, label_finish, expr, - coref != NULL ? coref->u.ar.as->corank : 0); - else if (non_ulimate_coarray_ptr_comp && token) - /* The token is set only for GFC_FCOARRAY_LIB mode. */ - gfc_allocate_using_caf_lib (&elseblock, pointer, size, token, status, - errmsg, errlen, - GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY); - else - gfc_allocate_using_malloc (&elseblock, pointer, size, status); - - if (dimension) - { - cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR, - logical_type_node, var_overflow, integer_zero_node), - PRED_FORTRAN_OVERFLOW); - tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, - error, gfc_finish_block (&elseblock)); - } - else - tmp = gfc_finish_block (&elseblock); - - gfc_add_expr_to_block (&se->pre, tmp); - - /* Update the array descriptor with the offset and the span. */ - if (dimension) - { - gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset); - tmp = fold_convert (gfc_array_index_type, element_size); - gfc_conv_descriptor_span_set (&set_descriptor_block, se->expr, tmp); - } - - set_descriptor = gfc_finish_block (&set_descriptor_block); - if (status != NULL_TREE) - { - cond = fold_build2_loc (input_location, EQ_EXPR, - logical_type_node, status, - build_int_cst (TREE_TYPE (status), 0)); - - if (not_prev_allocated != NULL_TREE) - cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, - logical_type_node, cond, not_prev_allocated); - - gfc_add_expr_to_block (&se->pre, - fold_build3_loc (input_location, COND_EXPR, void_type_node, - cond, - set_descriptor, - build_empty_stmt (input_location))); - } - else - gfc_add_expr_to_block (&se->pre, set_descriptor); - - return true; -} - - -/* Create an array constructor from an initialization expression. - We assume the frontend already did any expansions and conversions. */ - -tree -gfc_conv_array_initializer (tree type, gfc_expr * expr) -{ - gfc_constructor *c; - tree tmp; - gfc_se se; - tree index, range; - vec *v = NULL; - - if (expr->expr_type == EXPR_VARIABLE - && expr->symtree->n.sym->attr.flavor == FL_PARAMETER - && expr->symtree->n.sym->value) - expr = expr->symtree->n.sym->value; - - switch (expr->expr_type) - { - case EXPR_CONSTANT: - case EXPR_STRUCTURE: - /* A single scalar or derived type value. Create an array with all - elements equal to that value. */ - gfc_init_se (&se, NULL); - - if (expr->expr_type == EXPR_CONSTANT) - gfc_conv_constant (&se, expr); - else - gfc_conv_structure (&se, expr, 1); - - CONSTRUCTOR_APPEND_ELT (v, build2 (RANGE_EXPR, gfc_array_index_type, - TYPE_MIN_VALUE (TYPE_DOMAIN (type)), - TYPE_MAX_VALUE (TYPE_DOMAIN (type))), - se.expr); - break; - - case EXPR_ARRAY: - /* Create a vector of all the elements. */ - for (c = gfc_constructor_first (expr->value.constructor); - c && c->expr; c = gfc_constructor_next (c)) - { - if (c->iterator) - { - /* Problems occur when we get something like - integer :: a(lots) = (/(i, i=1, lots)/) */ - gfc_fatal_error ("The number of elements in the array " - "constructor at %L requires an increase of " - "the allowed %d upper limit. See " - "%<-fmax-array-constructor%> option", - &expr->where, flag_max_array_constructor); - return NULL_TREE; - } - if (mpz_cmp_si (c->offset, 0) != 0) - index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind); - else - index = NULL_TREE; - - if (mpz_cmp_si (c->repeat, 1) > 0) - { - tree tmp1, tmp2; - mpz_t maxval; - - mpz_init (maxval); - mpz_add (maxval, c->offset, c->repeat); - mpz_sub_ui (maxval, maxval, 1); - tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind); - if (mpz_cmp_si (c->offset, 0) != 0) - { - mpz_add_ui (maxval, c->offset, 1); - tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind); - } - else - tmp1 = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind); - - range = fold_build2 (RANGE_EXPR, gfc_array_index_type, tmp1, tmp2); - mpz_clear (maxval); - } - else - range = NULL; - - gfc_init_se (&se, NULL); - switch (c->expr->expr_type) - { - case EXPR_CONSTANT: - gfc_conv_constant (&se, c->expr); - - /* See gfortran.dg/charlen_15.f90 for instance. */ - if (TREE_CODE (se.expr) == STRING_CST - && TREE_CODE (type) == ARRAY_TYPE) - { - tree atype = type; - while (TREE_CODE (TREE_TYPE (atype)) == ARRAY_TYPE) - atype = TREE_TYPE (atype); - gcc_checking_assert (TREE_CODE (TREE_TYPE (atype)) - == INTEGER_TYPE); - gcc_checking_assert (TREE_TYPE (TREE_TYPE (se.expr)) - == TREE_TYPE (atype)); - if (tree_to_uhwi (TYPE_SIZE_UNIT (TREE_TYPE (se.expr))) - > tree_to_uhwi (TYPE_SIZE_UNIT (atype))) - { - unsigned HOST_WIDE_INT size - = tree_to_uhwi (TYPE_SIZE_UNIT (atype)); - const char *p = TREE_STRING_POINTER (se.expr); - - se.expr = build_string (size, p); - } - TREE_TYPE (se.expr) = atype; - } - break; - - case EXPR_STRUCTURE: - gfc_conv_structure (&se, c->expr, 1); - break; - - default: - /* Catch those occasional beasts that do not simplify - for one reason or another, assuming that if they are - standard defying the frontend will catch them. */ - gfc_conv_expr (&se, c->expr); - break; - } - - if (range == NULL_TREE) - CONSTRUCTOR_APPEND_ELT (v, index, se.expr); - else - { - if (index != NULL_TREE) - CONSTRUCTOR_APPEND_ELT (v, index, se.expr); - CONSTRUCTOR_APPEND_ELT (v, range, se.expr); - } - } - break; - - case EXPR_NULL: - return gfc_build_null_descriptor (type); - - default: - gcc_unreachable (); - } - - /* Create a constructor from the list of elements. */ - tmp = build_constructor (type, v); - TREE_CONSTANT (tmp) = 1; - return tmp; -} - - -/* Generate code to evaluate non-constant coarray cobounds. */ - -void -gfc_trans_array_cobounds (tree type, stmtblock_t * pblock, - const gfc_symbol *sym) -{ - int dim; - tree ubound; - tree lbound; - gfc_se se; - gfc_array_spec *as; - - as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as; - - for (dim = as->rank; dim < as->rank + as->corank; dim++) - { - /* Evaluate non-constant array bound expressions. */ - lbound = GFC_TYPE_ARRAY_LBOUND (type, dim); - if (as->lower[dim] && !INTEGER_CST_P (lbound)) - { - gfc_init_se (&se, NULL); - gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type); - gfc_add_block_to_block (pblock, &se.pre); - gfc_add_modify (pblock, lbound, se.expr); - } - ubound = GFC_TYPE_ARRAY_UBOUND (type, dim); - if (as->upper[dim] && !INTEGER_CST_P (ubound)) - { - gfc_init_se (&se, NULL); - gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type); - gfc_add_block_to_block (pblock, &se.pre); - gfc_add_modify (pblock, ubound, se.expr); - } - } -} - - -/* Generate code to evaluate non-constant array bounds. Sets *poffset and - returns the size (in elements) of the array. */ - -tree -gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset, - stmtblock_t * pblock) -{ - gfc_array_spec *as; - tree size; - tree stride; - tree offset; - tree ubound; - tree lbound; - tree tmp; - gfc_se se; - - int dim; - - as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as; - - size = gfc_index_one_node; - offset = gfc_index_zero_node; - for (dim = 0; dim < as->rank; dim++) - { - /* Evaluate non-constant array bound expressions. */ - lbound = GFC_TYPE_ARRAY_LBOUND (type, dim); - if (as->lower[dim] && !INTEGER_CST_P (lbound)) - { - gfc_init_se (&se, NULL); - gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type); - gfc_add_block_to_block (pblock, &se.pre); - gfc_add_modify (pblock, lbound, se.expr); - } - ubound = GFC_TYPE_ARRAY_UBOUND (type, dim); - if (as->upper[dim] && !INTEGER_CST_P (ubound)) - { - gfc_init_se (&se, NULL); - gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type); - gfc_add_block_to_block (pblock, &se.pre); - gfc_add_modify (pblock, ubound, se.expr); - } - /* The offset of this dimension. offset = offset - lbound * stride. */ - tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - lbound, size); - offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, - offset, tmp); - - /* The size of this dimension, and the stride of the next. */ - if (dim + 1 < as->rank) - stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1); - else - stride = GFC_TYPE_ARRAY_SIZE (type); - - if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride))) - { - /* Calculate stride = size * (ubound + 1 - lbound). */ - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - gfc_index_one_node, lbound); - tmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, ubound, tmp); - tmp = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, size, tmp); - if (stride) - gfc_add_modify (pblock, stride, tmp); - else - stride = gfc_evaluate_now (tmp, pblock); - - /* Make sure that negative size arrays are translated - to being zero size. */ - tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node, - stride, gfc_index_zero_node); - tmp = fold_build3_loc (input_location, COND_EXPR, - gfc_array_index_type, tmp, - stride, gfc_index_zero_node); - gfc_add_modify (pblock, stride, tmp); - } - - size = stride; - } - - gfc_trans_array_cobounds (type, pblock, sym); - gfc_trans_vla_type_sizes (sym, pblock); - - *poffset = offset; - return size; -} - - -/* Generate code to initialize/allocate an array variable. */ - -void -gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, - gfc_wrapped_block * block) -{ - stmtblock_t init; - tree type; - tree tmp = NULL_TREE; - tree size; - tree offset; - tree space; - tree inittree; - bool onstack; - - gcc_assert (!(sym->attr.pointer || sym->attr.allocatable)); - - /* Do nothing for USEd variables. */ - if (sym->attr.use_assoc) - return; - - type = TREE_TYPE (decl); - gcc_assert (GFC_ARRAY_TYPE_P (type)); - onstack = TREE_CODE (type) != POINTER_TYPE; - - gfc_init_block (&init); - - /* Evaluate character string length. */ - if (sym->ts.type == BT_CHARACTER - && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl)) - { - gfc_conv_string_length (sym->ts.u.cl, NULL, &init); - - gfc_trans_vla_type_sizes (sym, &init); - - /* Emit a DECL_EXPR for this variable, which will cause the - gimplifier to allocate storage, and all that good stuff. */ - tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl); - gfc_add_expr_to_block (&init, tmp); - } - - if (onstack) - { - gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); - return; - } - - type = TREE_TYPE (type); - - gcc_assert (!sym->attr.use_assoc); - gcc_assert (!TREE_STATIC (decl)); - gcc_assert (!sym->module); - - if (sym->ts.type == BT_CHARACTER - && !INTEGER_CST_P (sym->ts.u.cl->backend_decl)) - gfc_conv_string_length (sym->ts.u.cl, NULL, &init); - - size = gfc_trans_array_bounds (type, sym, &offset, &init); - - /* Don't actually allocate space for Cray Pointees. */ - if (sym->attr.cray_pointee) - { - if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type))) - gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset); - - gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); - return; - } - - if (flag_stack_arrays) - { - gcc_assert (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE); - space = build_decl (gfc_get_location (&sym->declared_at), - VAR_DECL, create_tmp_var_name ("A"), - TREE_TYPE (TREE_TYPE (decl))); - gfc_trans_vla_type_sizes (sym, &init); - } - else - { - /* The size is the number of elements in the array, so multiply by the - size of an element to get the total size. */ - tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type)); - size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - size, fold_convert (gfc_array_index_type, tmp)); - - /* Allocate memory to hold the data. */ - tmp = gfc_call_malloc (&init, TREE_TYPE (decl), size); - gfc_add_modify (&init, decl, tmp); - - /* Free the temporary. */ - tmp = gfc_call_free (decl); - space = NULL_TREE; - } - - /* Set offset of the array. */ - if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type))) - gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset); - - /* Automatic arrays should not have initializers. */ - gcc_assert (!sym->value); - - inittree = gfc_finish_block (&init); - - if (space) - { - tree addr; - pushdecl (space); - - /* Don't create new scope, emit the DECL_EXPR in exactly the scope - where also space is located. */ - gfc_init_block (&init); - tmp = fold_build1_loc (input_location, DECL_EXPR, - TREE_TYPE (space), space); - gfc_add_expr_to_block (&init, tmp); - addr = fold_build1_loc (gfc_get_location (&sym->declared_at), - ADDR_EXPR, TREE_TYPE (decl), space); - gfc_add_modify (&init, decl, addr); - gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); - tmp = NULL_TREE; - } - gfc_add_init_cleanup (block, inittree, tmp); -} - - -/* Generate entry and exit code for g77 calling convention arrays. */ - -void -gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block) -{ - tree parm; - tree type; - locus loc; - tree offset; - tree tmp; - tree stmt; - stmtblock_t init; - - gfc_save_backend_locus (&loc); - gfc_set_backend_locus (&sym->declared_at); - - /* Descriptor type. */ - parm = sym->backend_decl; - type = TREE_TYPE (parm); - gcc_assert (GFC_ARRAY_TYPE_P (type)); - - gfc_start_block (&init); - - if (sym->ts.type == BT_CHARACTER - && VAR_P (sym->ts.u.cl->backend_decl)) - gfc_conv_string_length (sym->ts.u.cl, NULL, &init); - - /* Evaluate the bounds of the array. */ - gfc_trans_array_bounds (type, sym, &offset, &init); - - /* Set the offset. */ - if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type))) - gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset); - - /* Set the pointer itself if we aren't using the parameter directly. */ - if (TREE_CODE (parm) != PARM_DECL) - { - tmp = GFC_DECL_SAVED_DESCRIPTOR (parm); - if (sym->ts.type == BT_CLASS) - { - tmp = build_fold_indirect_ref_loc (input_location, tmp); - tmp = gfc_class_data_get (tmp); - tmp = gfc_conv_descriptor_data_get (tmp); - } - tmp = convert (TREE_TYPE (parm), tmp); - gfc_add_modify (&init, parm, tmp); - } - stmt = gfc_finish_block (&init); - - gfc_restore_backend_locus (&loc); - - /* Add the initialization code to the start of the function. */ - - if ((sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.optional) - || sym->attr.optional - || sym->attr.not_always_present) - { - tree nullify; - if (TREE_CODE (parm) != PARM_DECL) - nullify = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, - parm, null_pointer_node); - else - nullify = build_empty_stmt (input_location); - tmp = gfc_conv_expr_present (sym, true); - stmt = build3_v (COND_EXPR, tmp, stmt, nullify); - } - - gfc_add_init_cleanup (block, stmt, NULL_TREE); -} - - -/* Modify the descriptor of an array parameter so that it has the - correct lower bound. Also move the upper bound accordingly. - If the array is not packed, it will be copied into a temporary. - For each dimension we set the new lower and upper bounds. Then we copy the - stride and calculate the offset for this dimension. We also work out - what the stride of a packed array would be, and see it the two match. - If the array need repacking, we set the stride to the values we just - calculated, recalculate the offset and copy the array data. - Code is also added to copy the data back at the end of the function. - */ - -void -gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, - gfc_wrapped_block * block) -{ - tree size; - tree type; - tree offset; - locus loc; - stmtblock_t init; - tree stmtInit, stmtCleanup; - tree lbound; - tree ubound; - tree dubound; - tree dlbound; - tree dumdesc; - tree tmp; - tree stride, stride2; - tree stmt_packed; - tree stmt_unpacked; - tree partial; - gfc_se se; - int n; - int checkparm; - int no_repack; - bool optional_arg; - gfc_array_spec *as; - bool is_classarray = IS_CLASS_ARRAY (sym); - - /* Do nothing for pointer and allocatable arrays. */ - if ((sym->ts.type != BT_CLASS && sym->attr.pointer) - || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer) - || sym->attr.allocatable - || (is_classarray && CLASS_DATA (sym)->attr.allocatable)) - return; - - if (!is_classarray && sym->attr.dummy && gfc_is_nodesc_array (sym)) - { - gfc_trans_g77_array (sym, block); - return; - } - - loc.nextc = NULL; - gfc_save_backend_locus (&loc); - /* loc.nextc is not set by save_backend_locus but the location routines - depend on it. */ - if (loc.nextc == NULL) - loc.nextc = loc.lb->line; - gfc_set_backend_locus (&sym->declared_at); - - /* Descriptor type. */ - type = TREE_TYPE (tmpdesc); - gcc_assert (GFC_ARRAY_TYPE_P (type)); - dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc); - if (is_classarray) - /* For a class array the dummy array descriptor is in the _class - component. */ - dumdesc = gfc_class_data_get (dumdesc); - else - dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc); - as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as; - gfc_start_block (&init); - - if (sym->ts.type == BT_CHARACTER - && VAR_P (sym->ts.u.cl->backend_decl)) - gfc_conv_string_length (sym->ts.u.cl, NULL, &init); - - /* TODO: Fix the exclusion of class arrays from extent checking. */ - checkparm = (as->type == AS_EXPLICIT && !is_classarray - && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)); - - no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc) - || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc)); - - if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc)) - { - /* For non-constant shape arrays we only check if the first dimension - is contiguous. Repacking higher dimensions wouldn't gain us - anything as we still don't know the array stride. */ - partial = gfc_create_var (logical_type_node, "partial"); - TREE_USED (partial) = 1; - tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]); - tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, tmp, - gfc_index_one_node); - gfc_add_modify (&init, partial, tmp); - } - else - partial = NULL_TREE; - - /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive - here, however I think it does the right thing. */ - if (no_repack) - { - /* Set the first stride. */ - stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]); - stride = gfc_evaluate_now (stride, &init); - - tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, - stride, gfc_index_zero_node); - tmp = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, - tmp, gfc_index_one_node, stride); - stride = GFC_TYPE_ARRAY_STRIDE (type, 0); - gfc_add_modify (&init, stride, tmp); - - /* Allow the user to disable array repacking. */ - stmt_unpacked = NULL_TREE; - } - else - { - gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0))); - /* A library call to repack the array if necessary. */ - tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc); - stmt_unpacked = build_call_expr_loc (input_location, - gfor_fndecl_in_pack, 1, tmp); - - stride = gfc_index_one_node; - - if (warn_array_temporaries) - gfc_warning (OPT_Warray_temporaries, - "Creating array temporary at %L", &loc); - } - - /* This is for the case where the array data is used directly without - calling the repack function. */ - if (no_repack || partial != NULL_TREE) - stmt_packed = gfc_conv_descriptor_data_get (dumdesc); - else - stmt_packed = NULL_TREE; - - /* Assign the data pointer. */ - if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE) - { - /* Don't repack unknown shape arrays when the first stride is 1. */ - tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (stmt_packed), - partial, stmt_packed, stmt_unpacked); - } - else - tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked; - gfc_add_modify (&init, tmpdesc, fold_convert (type, tmp)); - - offset = gfc_index_zero_node; - size = gfc_index_one_node; - - /* Evaluate the bounds of the array. */ - for (n = 0; n < as->rank; n++) - { - if (checkparm || !as->upper[n]) - { - /* Get the bounds of the actual parameter. */ - dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]); - dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]); - } - else - { - dubound = NULL_TREE; - dlbound = NULL_TREE; - } - - lbound = GFC_TYPE_ARRAY_LBOUND (type, n); - if (!INTEGER_CST_P (lbound)) - { - gfc_init_se (&se, NULL); - gfc_conv_expr_type (&se, as->lower[n], - gfc_array_index_type); - gfc_add_block_to_block (&init, &se.pre); - gfc_add_modify (&init, lbound, se.expr); - } - - ubound = GFC_TYPE_ARRAY_UBOUND (type, n); - /* Set the desired upper bound. */ - if (as->upper[n]) - { - /* We know what we want the upper bound to be. */ - if (!INTEGER_CST_P (ubound)) - { - gfc_init_se (&se, NULL); - gfc_conv_expr_type (&se, as->upper[n], - gfc_array_index_type); - gfc_add_block_to_block (&init, &se.pre); - gfc_add_modify (&init, ubound, se.expr); - } - - /* Check the sizes match. */ - if (checkparm) - { - /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */ - char * msg; - tree temp; - - temp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, ubound, lbound); - temp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, - gfc_index_one_node, temp); - stride2 = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, dubound, - dlbound); - stride2 = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, - gfc_index_one_node, stride2); - tmp = fold_build2_loc (input_location, NE_EXPR, - gfc_array_index_type, temp, stride2); - msg = xasprintf ("Dimension %d of array '%s' has extent " - "%%ld instead of %%ld", n+1, sym->name); - - gfc_trans_runtime_check (true, false, tmp, &init, &loc, msg, - fold_convert (long_integer_type_node, temp), - fold_convert (long_integer_type_node, stride2)); - - free (msg); - } - } - else - { - /* For assumed shape arrays move the upper bound by the same amount - as the lower bound. */ - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, dubound, dlbound); - tmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, tmp, lbound); - gfc_add_modify (&init, ubound, tmp); - } - /* The offset of this dimension. offset = offset - lbound * stride. */ - tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - lbound, stride); - offset = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, offset, tmp); - - /* The size of this dimension, and the stride of the next. */ - if (n + 1 < as->rank) - { - stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1); - - if (no_repack || partial != NULL_TREE) - stmt_unpacked = - gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]); - - /* Figure out the stride if not a known constant. */ - if (!INTEGER_CST_P (stride)) - { - if (no_repack) - stmt_packed = NULL_TREE; - else - { - /* Calculate stride = size * (ubound + 1 - lbound). */ - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - gfc_index_one_node, lbound); - tmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, ubound, tmp); - size = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, size, tmp); - stmt_packed = size; - } - - /* Assign the stride. */ - if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE) - tmp = fold_build3_loc (input_location, COND_EXPR, - gfc_array_index_type, partial, - stmt_unpacked, stmt_packed); - else - tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked; - gfc_add_modify (&init, stride, tmp); - } - } - else - { - stride = GFC_TYPE_ARRAY_SIZE (type); - - if (stride && !INTEGER_CST_P (stride)) - { - /* Calculate size = stride * (ubound + 1 - lbound). */ - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - gfc_index_one_node, lbound); - tmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, - ubound, tmp); - tmp = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, - GFC_TYPE_ARRAY_STRIDE (type, n), tmp); - gfc_add_modify (&init, stride, tmp); - } - } - } - - gfc_trans_array_cobounds (type, &init, sym); - - /* Set the offset. */ - if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type))) - gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset); - - gfc_trans_vla_type_sizes (sym, &init); - - stmtInit = gfc_finish_block (&init); - - /* Only do the entry/initialization code if the arg is present. */ - dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc); - optional_arg = (sym->attr.optional - || (sym->ns->proc_name->attr.entry_master - && sym->attr.dummy)); - if (optional_arg) - { - tree zero_init = fold_convert (TREE_TYPE (tmpdesc), null_pointer_node); - zero_init = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, - tmpdesc, zero_init); - tmp = gfc_conv_expr_present (sym, true); - stmtInit = build3_v (COND_EXPR, tmp, stmtInit, zero_init); - } - - /* Cleanup code. */ - if (no_repack) - stmtCleanup = NULL_TREE; - else - { - stmtblock_t cleanup; - gfc_start_block (&cleanup); - - if (sym->attr.intent != INTENT_IN) - { - /* Copy the data back. */ - tmp = build_call_expr_loc (input_location, - gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc); - gfc_add_expr_to_block (&cleanup, tmp); - } - - /* Free the temporary. */ - tmp = gfc_call_free (tmpdesc); - gfc_add_expr_to_block (&cleanup, tmp); - - stmtCleanup = gfc_finish_block (&cleanup); - - /* Only do the cleanup if the array was repacked. */ - if (is_classarray) - /* For a class array the dummy array descriptor is in the _class - component. */ - tmp = gfc_class_data_get (dumdesc); - else - tmp = build_fold_indirect_ref_loc (input_location, dumdesc); - tmp = gfc_conv_descriptor_data_get (tmp); - tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - tmp, tmpdesc); - stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup, - build_empty_stmt (input_location)); - - if (optional_arg) - { - tmp = gfc_conv_expr_present (sym); - stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup, - build_empty_stmt (input_location)); - } - } - - /* We don't need to free any memory allocated by internal_pack as it will - be freed at the end of the function by pop_context. */ - gfc_add_init_cleanup (block, stmtInit, stmtCleanup); - - gfc_restore_backend_locus (&loc); -} - - -/* 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) -{ - tree tmp; - tree field; - tree stride; - tree index; - gfc_ref *ref; - gfc_se start; - int n; - - /* If offset is NULL and this is not a subreferenced array, there is - nothing to do. */ - if (offset == NULL_TREE) - { - if (subref) - offset = gfc_index_zero_node; - else - return; - } - - tmp = build_array_ref (desc, offset, NULL, NULL); - - /* Offset the data pointer for pointer assignments from arrays with - subreferences; e.g. my_integer => my_type(:)%integer_component. */ - if (subref) - { - /* Go past the array reference. */ - for (ref = expr->ref; ref; ref = ref->next) - if (ref->type == REF_ARRAY && - ref->u.ar.type != AR_ELEMENT) - { - ref = ref->next; - break; - } - - /* Calculate the offset for each subsequent subreference. */ - for (; ref; ref = ref->next) - { - switch (ref->type) - { - case REF_COMPONENT: - field = ref->u.c.component->backend_decl; - gcc_assert (field && TREE_CODE (field) == FIELD_DECL); - tmp = fold_build3_loc (input_location, COMPONENT_REF, - TREE_TYPE (field), - tmp, field, NULL_TREE); - break; - - case REF_SUBSTRING: - gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE); - gfc_init_se (&start, NULL); - gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node); - gfc_add_block_to_block (block, &start.pre); - tmp = gfc_build_array_ref (tmp, start.expr, NULL); - break; - - case REF_ARRAY: - gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE - && ref->u.ar.type == AR_ELEMENT); - - /* TODO - Add bounds checking. */ - stride = gfc_index_one_node; - index = gfc_index_zero_node; - for (n = 0; n < ref->u.ar.dimen; n++) - { - tree itmp; - tree jtmp; - - /* Update the index. */ - gfc_init_se (&start, NULL); - gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type); - itmp = gfc_evaluate_now (start.expr, block); - gfc_init_se (&start, NULL); - gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type); - jtmp = gfc_evaluate_now (start.expr, block); - itmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, itmp, jtmp); - itmp = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, itmp, stride); - index = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, itmp, index); - index = gfc_evaluate_now (index, block); - - /* Update the stride. */ - gfc_init_se (&start, NULL); - gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type); - itmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, start.expr, - jtmp); - itmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, - gfc_index_one_node, itmp); - stride = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, stride, itmp); - stride = gfc_evaluate_now (stride, block); - } - - /* Apply the index to obtain the array element. */ - tmp = gfc_build_array_ref (tmp, index, NULL); - break; - - case REF_INQUIRY: - switch (ref->u.i) - { - case INQUIRY_RE: - tmp = fold_build1_loc (input_location, REALPART_EXPR, - TREE_TYPE (TREE_TYPE (tmp)), tmp); - break; - - case INQUIRY_IM: - tmp = fold_build1_loc (input_location, IMAGPART_EXPR, - TREE_TYPE (TREE_TYPE (tmp)), tmp); - break; - - default: - break; - } - break; - - default: - gcc_unreachable (); - break; - } - } - } - - /* Set the target data pointer. */ - offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp); - gfc_conv_descriptor_data_set (block, parm, offset); -} - - -/* gfc_conv_expr_descriptor needs the string length an expression - so that the size of the temporary can be obtained. This is done - by adding up the string lengths of all the elements in the - expression. Function with non-constant expressions have their - string lengths mapped onto the actual arguments using the - interface mapping machinery in trans-expr.c. */ -static void -get_array_charlen (gfc_expr *expr, gfc_se *se) -{ - gfc_interface_mapping mapping; - gfc_formal_arglist *formal; - gfc_actual_arglist *arg; - gfc_se tse; - gfc_expr *e; - - if (expr->ts.u.cl->length - && gfc_is_constant_expr (expr->ts.u.cl->length)) - { - if (!expr->ts.u.cl->backend_decl) - gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre); - return; - } - - switch (expr->expr_type) - { - case EXPR_ARRAY: - - /* This is somewhat brutal. The expression for the first - element of the array is evaluated and assigned to a - new string length for the original expression. */ - e = gfc_constructor_first (expr->value.constructor)->expr; - - gfc_init_se (&tse, NULL); - - /* Avoid evaluating trailing array references since all we need is - the string length. */ - if (e->rank) - tse.descriptor_only = 1; - if (e->rank && e->expr_type != EXPR_VARIABLE) - gfc_conv_expr_descriptor (&tse, e); - else - gfc_conv_expr (&tse, e); - - gfc_add_block_to_block (&se->pre, &tse.pre); - gfc_add_block_to_block (&se->post, &tse.post); - - if (!expr->ts.u.cl->backend_decl || !VAR_P (expr->ts.u.cl->backend_decl)) - { - expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); - expr->ts.u.cl->backend_decl = - gfc_create_var (gfc_charlen_type_node, "sln"); - } - - gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl, - tse.string_length); - - /* Make sure that deferred length components point to the hidden - string_length component. */ - if (TREE_CODE (tse.expr) == COMPONENT_REF - && TREE_CODE (tse.string_length) == COMPONENT_REF - && TREE_OPERAND (tse.expr, 0) == TREE_OPERAND (tse.string_length, 0)) - e->ts.u.cl->backend_decl = expr->ts.u.cl->backend_decl; - - return; - - case EXPR_OP: - get_array_charlen (expr->value.op.op1, se); - - /* For parentheses the expression ts.u.cl should be identical. */ - if (expr->value.op.op == INTRINSIC_PARENTHESES) - { - if (expr->value.op.op1->ts.u.cl != expr->ts.u.cl) - expr->ts.u.cl->backend_decl - = expr->value.op.op1->ts.u.cl->backend_decl; - return; - } - - expr->ts.u.cl->backend_decl = - gfc_create_var (gfc_charlen_type_node, "sln"); - - if (expr->value.op.op2) - { - get_array_charlen (expr->value.op.op2, se); - - gcc_assert (expr->value.op.op == INTRINSIC_CONCAT); - - /* Add the string lengths and assign them to the expression - string length backend declaration. */ - gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl, - fold_build2_loc (input_location, PLUS_EXPR, - gfc_charlen_type_node, - expr->value.op.op1->ts.u.cl->backend_decl, - expr->value.op.op2->ts.u.cl->backend_decl)); - } - else - gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl, - expr->value.op.op1->ts.u.cl->backend_decl); - break; - - case EXPR_FUNCTION: - if (expr->value.function.esym == NULL - || expr->ts.u.cl->length->expr_type == EXPR_CONSTANT) - { - gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre); - break; - } - - /* Map expressions involving the dummy arguments onto the actual - argument expressions. */ - gfc_init_interface_mapping (&mapping); - formal = gfc_sym_get_dummy_args (expr->symtree->n.sym); - arg = expr->value.function.actual; - - /* Set se = NULL in the calls to the interface mapping, to suppress any - backend stuff. */ - for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL) - { - if (!arg->expr) - continue; - if (formal->sym) - gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr); - } - - gfc_init_se (&tse, NULL); - - /* Build the expression for the character length and convert it. */ - gfc_apply_interface_mapping (&mapping, &tse, expr->ts.u.cl->length); - - gfc_add_block_to_block (&se->pre, &tse.pre); - gfc_add_block_to_block (&se->post, &tse.post); - tse.expr = fold_convert (gfc_charlen_type_node, tse.expr); - tse.expr = fold_build2_loc (input_location, MAX_EXPR, - TREE_TYPE (tse.expr), tse.expr, - build_zero_cst (TREE_TYPE (tse.expr))); - expr->ts.u.cl->backend_decl = tse.expr; - gfc_free_interface_mapping (&mapping); - break; - - default: - gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre); - break; - } -} - - -/* Helper function to check dimensions. */ -static bool -transposed_dims (gfc_ss *ss) -{ - int n; - - for (n = 0; n < ss->dimen; n++) - if (ss->dim[n] != n) - return true; - return false; -} - - -/* Convert the last ref of a scalar coarray from an AR_ELEMENT to an - AR_FULL, suitable for the scalarizer. */ - -static gfc_ss * -walk_coarray (gfc_expr *e) -{ - gfc_ss *ss; - - gcc_assert (gfc_get_corank (e) > 0); - - ss = gfc_walk_expr (e); - - /* Fix scalar coarray. */ - if (ss == gfc_ss_terminator) - { - gfc_ref *ref; - - ref = e->ref; - while (ref) - { - if (ref->type == REF_ARRAY - && ref->u.ar.codimen > 0) - break; - - ref = ref->next; - } - - gcc_assert (ref != NULL); - if (ref->u.ar.type == AR_ELEMENT) - ref->u.ar.type = AR_SECTION; - ss = gfc_reverse_ss (gfc_walk_array_ref (ss, e, ref)); - } - - return ss; -} - - -/* Convert an array for passing as an actual argument. Expressions and - vector subscripts are evaluated and stored in a temporary, which is then - passed. For whole arrays the descriptor is passed. For array sections - a modified copy of the descriptor is passed, but using the original data. - - This function is also used for array pointer assignments, and there - are three cases: - - - se->want_pointer && !se->direct_byref - EXPR is an actual argument. On exit, se->expr contains a - pointer to the array descriptor. - - - !se->want_pointer && !se->direct_byref - EXPR is an actual argument to an intrinsic function or the - left-hand side of a pointer assignment. On exit, se->expr - contains the descriptor for EXPR. - - - !se->want_pointer && se->direct_byref - EXPR is the right-hand side of a pointer assignment and - se->expr is the descriptor for the previously-evaluated - left-hand side. The function creates an assignment from - EXPR to se->expr. - - - The se->force_tmp flag disables the non-copying descriptor optimization - that is used for transpose. It may be used in cases where there is an - alias between the transpose argument and another argument in the same - function call. */ - -void -gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) -{ - gfc_ss *ss; - gfc_ss_type ss_type; - gfc_ss_info *ss_info; - gfc_loopinfo loop; - gfc_array_info *info; - int need_tmp; - int n; - tree tmp; - tree desc; - stmtblock_t block; - tree start; - int full; - bool subref_array_target = false; - bool deferred_array_component = false; - gfc_expr *arg, *ss_expr; - - if (se->want_coarray) - ss = walk_coarray (expr); - else - ss = gfc_walk_expr (expr); - - gcc_assert (ss != NULL); - gcc_assert (ss != gfc_ss_terminator); - - ss_info = ss->info; - ss_type = ss_info->type; - ss_expr = ss_info->expr; - - /* Special case: TRANSPOSE which needs no temporary. */ - while (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym - && (arg = gfc_get_noncopying_intrinsic_argument (expr)) != NULL) - { - /* This is a call to transpose which has already been handled by the - scalarizer, so that we just need to get its argument's descriptor. */ - gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE); - expr = expr->value.function.actual->expr; - } - - if (!se->direct_byref) - se->unlimited_polymorphic = UNLIMITED_POLY (expr); - - /* Special case things we know we can pass easily. */ - switch (expr->expr_type) - { - case EXPR_VARIABLE: - /* If we have a linear array section, we can pass it directly. - Otherwise we need to copy it into a temporary. */ - - gcc_assert (ss_type == GFC_SS_SECTION); - gcc_assert (ss_expr == expr); - info = &ss_info->data.array; - - /* Get the descriptor for the array. */ - gfc_conv_ss_descriptor (&se->pre, ss, 0); - desc = info->descriptor; - - /* The charlen backend decl for deferred character components cannot - be used because it is fixed at zero. Instead, the hidden string - length component is used. */ - if (expr->ts.type == BT_CHARACTER - && expr->ts.deferred - && TREE_CODE (desc) == COMPONENT_REF) - deferred_array_component = true; - - subref_array_target = (is_subref_array (expr) - && (se->direct_byref - || expr->ts.type == BT_CHARACTER)); - need_tmp = (gfc_ref_needs_temporary_p (expr->ref) - && !subref_array_target); - - if (se->force_tmp) - need_tmp = 1; - else if (se->force_no_tmp) - need_tmp = 0; - - if (need_tmp) - full = 0; - else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc))) - { - /* Create a new descriptor if the array doesn't have one. */ - full = 0; - } - else if (info->ref->u.ar.type == AR_FULL || se->descriptor_only) - full = 1; - else if (se->direct_byref) - full = 0; - else if (info->ref->u.ar.dimen == 0 && !info->ref->next) - full = 1; - else if (info->ref->u.ar.type == AR_SECTION && se->want_pointer) - full = 0; - else - full = gfc_full_array_ref_p (info->ref, NULL); - - if (full && !transposed_dims (ss)) - { - if (se->direct_byref && !se->byref_noassign) - { - /* Copy the descriptor for pointer assignments. */ - gfc_add_modify (&se->pre, se->expr, desc); - - /* Add any offsets from subreferences. */ - gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE, - subref_array_target, expr); - - /* ....and set the span field. */ - tmp = gfc_conv_descriptor_span_get (desc); - gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp); - } - else if (se->want_pointer) - { - /* We pass full arrays directly. This means that pointers and - allocatable arrays should also work. */ - se->expr = gfc_build_addr_expr (NULL_TREE, desc); - } - else - { - se->expr = desc; - } - - if (expr->ts.type == BT_CHARACTER && !deferred_array_component) - se->string_length = gfc_get_expr_charlen (expr); - /* The ss_info string length is returned set to the value of the - hidden string length component. */ - else if (deferred_array_component) - se->string_length = ss_info->string_length; - - gfc_free_ss_chain (ss); - return; - } - break; - - case EXPR_FUNCTION: - /* A transformational function return value will be a temporary - array descriptor. We still need to go through the scalarizer - to create the descriptor. Elemental functions are handled as - arbitrary expressions, i.e. copy to a temporary. */ - - if (se->direct_byref) - { - gcc_assert (ss_type == GFC_SS_FUNCTION && ss_expr == expr); - - /* For pointer assignments pass the descriptor directly. */ - if (se->ss == NULL) - se->ss = ss; - else - gcc_assert (se->ss == ss); - - if (!is_pointer_array (se->expr)) - { - tmp = gfc_get_element_type (TREE_TYPE (se->expr)); - tmp = fold_convert (gfc_array_index_type, - size_in_bytes (tmp)); - gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp); - } - - se->expr = gfc_build_addr_expr (NULL_TREE, se->expr); - gfc_conv_expr (se, expr); - - gfc_free_ss_chain (ss); - return; - } - - if (ss_expr != expr || ss_type != GFC_SS_FUNCTION) - { - if (ss_expr != expr) - /* Elemental function. */ - gcc_assert ((expr->value.function.esym != NULL - && expr->value.function.esym->attr.elemental) - || (expr->value.function.isym != NULL - && expr->value.function.isym->elemental) - || (gfc_expr_attr (expr).proc_pointer - && gfc_expr_attr (expr).elemental) - || gfc_inline_intrinsic_function_p (expr)); - - need_tmp = 1; - if (expr->ts.type == BT_CHARACTER - && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT) - get_array_charlen (expr, se); - - info = NULL; - } - else - { - /* Transformational function. */ - info = &ss_info->data.array; - need_tmp = 0; - } - break; - - case EXPR_ARRAY: - /* Constant array constructors don't need a temporary. */ - if (ss_type == GFC_SS_CONSTRUCTOR - && expr->ts.type != BT_CHARACTER - && gfc_constant_array_constructor_p (expr->value.constructor)) - { - need_tmp = 0; - info = &ss_info->data.array; - } - else - { - need_tmp = 1; - info = NULL; - } - break; - - default: - /* Something complicated. Copy it into a temporary. */ - need_tmp = 1; - info = NULL; - break; - } - - /* If we are creating a temporary, we don't need to bother about aliases - anymore. */ - if (need_tmp) - se->force_tmp = 0; - - gfc_init_loopinfo (&loop); - - /* Associate the SS with the loop. */ - gfc_add_ss_to_loop (&loop, ss); - - /* Tell the scalarizer not to bother creating loop variables, etc. */ - if (!need_tmp) - loop.array_parameter = 1; - else - /* The right-hand side of a pointer assignment mustn't use a temporary. */ - gcc_assert (!se->direct_byref); - - /* Do we need bounds checking or not? */ - ss->no_bounds_check = expr->no_bounds_check; - - /* Setup the scalarizing loops and bounds. */ - gfc_conv_ss_startstride (&loop); - - if (need_tmp) - { - if (expr->ts.type == BT_CHARACTER - && (!expr->ts.u.cl->backend_decl || expr->expr_type == EXPR_ARRAY)) - get_array_charlen (expr, se); - - /* Tell the scalarizer to make a temporary. */ - loop.temp_ss = gfc_get_temp_ss (gfc_typenode_for_spec (&expr->ts), - ((expr->ts.type == BT_CHARACTER) - ? expr->ts.u.cl->backend_decl - : NULL), - loop.dimen); - - se->string_length = loop.temp_ss->info->string_length; - gcc_assert (loop.temp_ss->dimen == loop.dimen); - gfc_add_ss_to_loop (&loop, loop.temp_ss); - } - - gfc_conv_loop_setup (&loop, & expr->where); - - if (need_tmp) - { - /* Copy into a temporary and pass that. We don't need to copy the data - back because expressions and vector subscripts must be INTENT_IN. */ - /* TODO: Optimize passing function return values. */ - gfc_se lse; - gfc_se rse; - bool deep_copy; - - /* Start the copying loops. */ - gfc_mark_ss_chain_used (loop.temp_ss, 1); - gfc_mark_ss_chain_used (ss, 1); - gfc_start_scalarized_body (&loop, &block); - - /* Copy each data element. */ - gfc_init_se (&lse, NULL); - gfc_copy_loopinfo_to_se (&lse, &loop); - gfc_init_se (&rse, NULL); - gfc_copy_loopinfo_to_se (&rse, &loop); - - lse.ss = loop.temp_ss; - rse.ss = ss; - - gfc_conv_scalarized_array_ref (&lse, NULL); - if (expr->ts.type == BT_CHARACTER) - { - gfc_conv_expr (&rse, expr); - if (POINTER_TYPE_P (TREE_TYPE (rse.expr))) - rse.expr = build_fold_indirect_ref_loc (input_location, - rse.expr); - } - else - gfc_conv_expr_val (&rse, expr); - - gfc_add_block_to_block (&block, &rse.pre); - gfc_add_block_to_block (&block, &lse.pre); - - lse.string_length = rse.string_length; - - deep_copy = !se->data_not_needed - && (expr->expr_type == EXPR_VARIABLE - || expr->expr_type == EXPR_ARRAY); - tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, - deep_copy, false); - gfc_add_expr_to_block (&block, tmp); - - /* Finish the copying loops. */ - gfc_trans_scalarizing_loops (&loop, &block); - - desc = loop.temp_ss->info->data.array.descriptor; - } - else if (expr->expr_type == EXPR_FUNCTION && !transposed_dims (ss)) - { - desc = info->descriptor; - se->string_length = ss_info->string_length; - } - else - { - /* We pass sections without copying to a temporary. Make a new - descriptor and point it at the section we want. The loop variable - limits will be the limits of the section. - A function may decide to repack the array to speed up access, but - we're not bothered about that here. */ - int dim, ndim, codim; - tree parm; - tree parmtype; - tree dtype; - tree stride; - tree from; - tree to; - tree base; - tree offset; - - ndim = info->ref ? info->ref->u.ar.dimen : ss->dimen; - - if (se->want_coarray) - { - gfc_array_ref *ar = &info->ref->u.ar; - - codim = gfc_get_corank (expr); - for (n = 0; n < codim - 1; n++) - { - /* Make sure we are not lost somehow. */ - gcc_assert (ar->dimen_type[n + ndim] == DIMEN_THIS_IMAGE); - - /* Make sure the call to gfc_conv_section_startstride won't - generate unnecessary code to calculate stride. */ - gcc_assert (ar->stride[n + ndim] == NULL); - - gfc_conv_section_startstride (&loop.pre, ss, n + ndim); - loop.from[n + loop.dimen] = info->start[n + ndim]; - loop.to[n + loop.dimen] = info->end[n + ndim]; - } - - gcc_assert (n == codim - 1); - evaluate_bound (&loop.pre, info->start, ar->start, - info->descriptor, n + ndim, true, - ar->as->type == AS_DEFERRED); - loop.from[n + loop.dimen] = info->start[n + ndim]; - } - else - codim = 0; - - /* Set the string_length for a character array. */ - if (expr->ts.type == BT_CHARACTER) - { - if (deferred_array_component) - se->string_length = ss_info->string_length; - else - se->string_length = gfc_get_expr_charlen (expr); - - if (VAR_P (se->string_length) - && expr->ts.u.cl->backend_decl == se->string_length) - tmp = ss_info->string_length; - else - tmp = se->string_length; - - if (expr->ts.deferred && VAR_P (expr->ts.u.cl->backend_decl)) - gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl, tmp); - else - expr->ts.u.cl->backend_decl = tmp; - } - - /* If we have an array section, are assigning or passing an array - section argument make sure that the lower bound is 1. References - to the full array should otherwise keep the original bounds. */ - if (!info->ref || info->ref->u.ar.type != AR_FULL) - for (dim = 0; dim < loop.dimen; dim++) - if (!integer_onep (loop.from[dim])) - { - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, gfc_index_one_node, - loop.from[dim]); - loop.to[dim] = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, - loop.to[dim], tmp); - loop.from[dim] = gfc_index_one_node; - } - - desc = info->descriptor; - if (se->direct_byref && !se->byref_noassign) - { - /* For pointer assignments we fill in the destination. */ - parm = se->expr; - parmtype = TREE_TYPE (parm); - } - else - { - /* Otherwise make a new one. */ - if (expr->ts.type == BT_CHARACTER) - parmtype = gfc_typenode_for_spec (&expr->ts); - else - parmtype = gfc_get_element_type (TREE_TYPE (desc)); - - parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, codim, - loop.from, loop.to, 0, - GFC_ARRAY_UNKNOWN, false); - parm = gfc_create_var (parmtype, "parm"); - - /* When expression is a class object, then add the class' handle to - the parm_decl. */ - if (expr->ts.type == BT_CLASS && expr->expr_type == EXPR_VARIABLE) - { - gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (expr); - gfc_se classse; - - /* class_expr can be NULL, when no _class ref is in expr. - We must not fix this here with a gfc_fix_class_ref (). */ - if (class_expr) - { - gfc_init_se (&classse, NULL); - gfc_conv_expr (&classse, class_expr); - gfc_free_expr (class_expr); - - gcc_assert (classse.pre.head == NULL_TREE - && classse.post.head == NULL_TREE); - gfc_allocate_lang_decl (parm); - GFC_DECL_SAVED_DESCRIPTOR (parm) = classse.expr; - } - } - } - - /* Set the span field. */ - tmp = gfc_get_array_span (desc, expr); - if (tmp) - gfc_conv_descriptor_span_set (&loop.pre, parm, tmp); - - /* The following can be somewhat confusing. We have two - descriptors, a new one and the original array. - {parm, parmtype, dim} refer to the new one. - {desc, type, n, loop} refer to the original, which maybe - a descriptorless array. - The bounds of the scalarization are the bounds of the section. - We don't have to worry about numeric overflows when calculating - the offsets because all elements are within the array data. */ - - /* Set the dtype. */ - tmp = gfc_conv_descriptor_dtype (parm); - if (se->unlimited_polymorphic) - dtype = gfc_get_dtype (TREE_TYPE (desc), &loop.dimen); - else if (expr->ts.type == BT_ASSUMED) - { - tree tmp2 = desc; - if (DECL_LANG_SPECIFIC (tmp2) && GFC_DECL_SAVED_DESCRIPTOR (tmp2)) - tmp2 = GFC_DECL_SAVED_DESCRIPTOR (tmp2); - if (POINTER_TYPE_P (TREE_TYPE (tmp2))) - tmp2 = build_fold_indirect_ref_loc (input_location, tmp2); - dtype = gfc_conv_descriptor_dtype (tmp2); - } - else - dtype = gfc_get_dtype (parmtype); - gfc_add_modify (&loop.pre, tmp, dtype); - - /* The 1st element in the section. */ - base = gfc_index_zero_node; - - /* The offset from the 1st element in the section. */ - offset = gfc_index_zero_node; - - for (n = 0; n < ndim; n++) - { - stride = gfc_conv_array_stride (desc, n); - - /* Work out the 1st element in the section. */ - if (info->ref - && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT) - { - gcc_assert (info->subscript[n] - && info->subscript[n]->info->type == GFC_SS_SCALAR); - start = info->subscript[n]->info->data.scalar.value; - } - else - { - /* Evaluate and remember the start of the section. */ - start = info->start[n]; - stride = gfc_evaluate_now (stride, &loop.pre); - } - - tmp = gfc_conv_array_lbound (desc, n); - tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp), - start, tmp); - tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp), - tmp, stride); - base = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp), - base, tmp); - - if (info->ref - && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT) - { - /* For elemental dimensions, we only need the 1st - element in the section. */ - continue; - } - - /* Vector subscripts need copying and are handled elsewhere. */ - if (info->ref) - gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE); - - /* look for the corresponding scalarizer dimension: dim. */ - for (dim = 0; dim < ndim; dim++) - if (ss->dim[dim] == n) - break; - - /* loop exited early: the DIM being looked for has been found. */ - gcc_assert (dim < ndim); - - /* Set the new lower bound. */ - from = loop.from[dim]; - to = loop.to[dim]; - - gfc_conv_descriptor_lbound_set (&loop.pre, parm, - gfc_rank_cst[dim], from); - - /* Set the new upper bound. */ - gfc_conv_descriptor_ubound_set (&loop.pre, parm, - gfc_rank_cst[dim], to); - - /* Multiply the stride by the section stride to get the - total stride. */ - stride = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, - stride, info->stride[n]); - - tmp = fold_build2_loc (input_location, MULT_EXPR, - TREE_TYPE (offset), stride, from); - offset = fold_build2_loc (input_location, MINUS_EXPR, - TREE_TYPE (offset), offset, tmp); - - /* Store the new stride. */ - gfc_conv_descriptor_stride_set (&loop.pre, parm, - gfc_rank_cst[dim], stride); - } - - for (n = loop.dimen; n < loop.dimen + codim; n++) - { - from = loop.from[n]; - to = loop.to[n]; - gfc_conv_descriptor_lbound_set (&loop.pre, parm, - gfc_rank_cst[n], from); - if (n < loop.dimen + codim - 1) - gfc_conv_descriptor_ubound_set (&loop.pre, parm, - gfc_rank_cst[n], to); - } - - if (se->data_not_needed) - gfc_conv_descriptor_data_set (&loop.pre, parm, - gfc_index_zero_node); - else - /* Point the data pointer at the 1st element in the section. */ - gfc_get_dataptr_offset (&loop.pre, parm, desc, base, - subref_array_target, expr); - - gfc_conv_descriptor_offset_set (&loop.pre, parm, offset); - - desc = parm; - } - - /* For class arrays add the class tree into the saved descriptor to - enable getting of _vptr and the like. */ - if (expr->expr_type == EXPR_VARIABLE && VAR_P (desc) - && IS_CLASS_ARRAY (expr->symtree->n.sym)) - { - gfc_allocate_lang_decl (desc); - GFC_DECL_SAVED_DESCRIPTOR (desc) = - DECL_LANG_SPECIFIC (expr->symtree->n.sym->backend_decl) ? - GFC_DECL_SAVED_DESCRIPTOR (expr->symtree->n.sym->backend_decl) - : expr->symtree->n.sym->backend_decl; - } - else if (expr->expr_type == EXPR_ARRAY && VAR_P (desc) - && IS_CLASS_ARRAY (expr)) - { - tree vtype; - gfc_allocate_lang_decl (desc); - tmp = gfc_create_var (expr->ts.u.derived->backend_decl, "class"); - GFC_DECL_SAVED_DESCRIPTOR (desc) = tmp; - vtype = gfc_class_vptr_get (tmp); - gfc_add_modify (&se->pre, vtype, - gfc_build_addr_expr (TREE_TYPE (vtype), - gfc_find_vtab (&expr->ts)->backend_decl)); - } - if (!se->direct_byref || se->byref_noassign) - { - /* Get a pointer to the new descriptor. */ - if (se->want_pointer) - se->expr = gfc_build_addr_expr (NULL_TREE, desc); - else - se->expr = desc; - } - - gfc_add_block_to_block (&se->pre, &loop.pre); - gfc_add_block_to_block (&se->post, &loop.post); - - /* Cleanup the scalarizer. */ - gfc_cleanup_loop (&loop); -} - - -/* Calculate the array size (number of elements); if dim != NULL_TREE, - return size for that dim (dim=0..rank-1; only for GFC_DESCRIPTOR_TYPE_P). */ -tree -gfc_tree_array_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree dim) -{ - if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc))) - { - gcc_assert (dim == NULL_TREE); - return GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc)); - } - tree size, tmp, rank = NULL_TREE, cond = NULL_TREE; - symbol_attribute attr = gfc_expr_attr (expr); - gfc_array_spec *as = gfc_get_full_arrayspec_from_expr (expr); - gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))); - if ((!attr.pointer && !attr.allocatable && as && as->type == AS_ASSUMED_RANK) - || !dim) - { - if (expr->rank < 0) - rank = fold_convert (signed_char_type_node, - gfc_conv_descriptor_rank (desc)); - else - rank = build_int_cst (signed_char_type_node, expr->rank); - } - - if (dim || expr->rank == 1) - { - if (!dim) - dim = gfc_index_zero_node; - tree ubound = gfc_conv_descriptor_ubound_get (desc, dim); - tree lbound = gfc_conv_descriptor_lbound_get (desc, dim); - - size = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, ubound, lbound); - size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - size, gfc_index_one_node); - /* if (!allocatable && !pointer && assumed rank) - size = (idx == rank && ubound[rank-1] == -1 ? -1 : size; - else - size = max (0, size); */ - size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type, - size, gfc_index_zero_node); - if (!attr.pointer && !attr.allocatable - && as && as->type == AS_ASSUMED_RANK) - { - tmp = fold_build2_loc (input_location, MINUS_EXPR, signed_char_type_node, - rank, build_int_cst (signed_char_type_node, 1)); - cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, - fold_convert (signed_char_type_node, dim), - tmp); - tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, - gfc_conv_descriptor_ubound_get (desc, dim), - build_int_cst (gfc_array_index_type, -1)); - cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node, - cond, tmp); - tmp = build_int_cst (gfc_array_index_type, -1); - size = build3_loc (input_location, COND_EXPR, gfc_array_index_type, - cond, tmp, size); - } - return size; - } - - /* size = 1. */ - size = gfc_create_var (gfc_array_index_type, "size"); - gfc_add_modify (block, size, build_int_cst (TREE_TYPE (size), 1)); - tree extent = gfc_create_var (gfc_array_index_type, "extent"); - - stmtblock_t cond_block, loop_body; - gfc_init_block (&cond_block); - gfc_init_block (&loop_body); - - /* Loop: for (i = 0; i < rank; ++i). */ - tree idx = gfc_create_var (signed_char_type_node, "idx"); - /* Loop body. */ - /* #if (assumed-rank + !allocatable && !pointer) - if (idx == rank - 1 && dim[idx].ubound == -1) - extent = -1; - else - #endif - extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1 - if (extent < 0) - extent = 0 - size *= extent. */ - cond = NULL_TREE; - if (!attr.pointer && !attr.allocatable && as && as->type == AS_ASSUMED_RANK) - { - tmp = fold_build2_loc (input_location, MINUS_EXPR, signed_char_type_node, - rank, build_int_cst (signed_char_type_node, 1)); - cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, - idx, tmp); - tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, - gfc_conv_descriptor_ubound_get (desc, idx), - build_int_cst (gfc_array_index_type, -1)); - cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node, - cond, tmp); - } - tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, - gfc_conv_descriptor_ubound_get (desc, idx), - gfc_conv_descriptor_lbound_get (desc, idx)); - tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - tmp, gfc_index_one_node); - gfc_add_modify (&cond_block, extent, tmp); - tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, - extent, gfc_index_zero_node); - tmp = build3_v (COND_EXPR, tmp, - fold_build2_loc (input_location, MODIFY_EXPR, - gfc_array_index_type, - extent, gfc_index_zero_node), - build_empty_stmt (input_location)); - gfc_add_expr_to_block (&cond_block, tmp); - tmp = gfc_finish_block (&cond_block); - if (cond) - tmp = build3_v (COND_EXPR, cond, - fold_build2_loc (input_location, MODIFY_EXPR, - gfc_array_index_type, extent, - build_int_cst (gfc_array_index_type, -1)), - tmp); - gfc_add_expr_to_block (&loop_body, tmp); - /* size *= extent. */ - gfc_add_modify (&loop_body, size, - fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - size, extent)); - /* Generate loop. */ - gfc_simple_for_loop (block, idx, build_int_cst (TREE_TYPE (idx), 0), rank, LT_EXPR, - build_int_cst (TREE_TYPE (idx), 1), - gfc_finish_block (&loop_body)); - return size; -} - -/* Helper function for gfc_conv_array_parameter if array size needs to be - computed. */ - -static void -array_parameter_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree *size) -{ - tree elem; - *size = gfc_tree_array_size (block, desc, expr, NULL); - elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc))); - *size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - *size, fold_convert (gfc_array_index_type, elem)); -} - -/* Helper function - return true if the argument is a pointer. */ - -static bool -is_pointer (gfc_expr *e) -{ - gfc_symbol *sym; - - if (e->expr_type != EXPR_VARIABLE || e->symtree == NULL) - return false; - - sym = e->symtree->n.sym; - if (sym == NULL) - return false; - - return sym->attr.pointer || sym->attr.proc_pointer; -} - -/* Convert an array for passing as an actual parameter. */ - -void -gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77, - const gfc_symbol *fsym, const char *proc_name, - tree *size) -{ - tree ptr; - tree desc; - tree tmp = NULL_TREE; - tree stmt; - tree parent = DECL_CONTEXT (current_function_decl); - bool full_array_var; - bool this_array_result; - bool contiguous; - bool no_pack; - bool array_constructor; - bool good_allocatable; - bool ultimate_ptr_comp; - bool ultimate_alloc_comp; - gfc_symbol *sym; - stmtblock_t block; - gfc_ref *ref; - - ultimate_ptr_comp = false; - ultimate_alloc_comp = false; - - for (ref = expr->ref; ref; ref = ref->next) - { - if (ref->next == NULL) - break; - - if (ref->type == REF_COMPONENT) - { - ultimate_ptr_comp = ref->u.c.component->attr.pointer; - ultimate_alloc_comp = ref->u.c.component->attr.allocatable; - } - } - - full_array_var = false; - contiguous = false; - - if (expr->expr_type == EXPR_VARIABLE && ref && !ultimate_ptr_comp) - full_array_var = gfc_full_array_ref_p (ref, &contiguous); - - sym = full_array_var ? expr->symtree->n.sym : NULL; - - /* The symbol should have an array specification. */ - gcc_assert (!sym || sym->as || ref->u.ar.as); - - if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER) - { - get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp); - expr->ts.u.cl->backend_decl = tmp; - se->string_length = tmp; - } - - /* Is this the result of the enclosing procedure? */ - this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE); - if (this_array_result - && (sym->backend_decl != current_function_decl) - && (sym->backend_decl != parent)) - this_array_result = false; - - /* Passing address of the array if it is not pointer or assumed-shape. */ - if (full_array_var && g77 && !this_array_result - && sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS) - { - tmp = gfc_get_symbol_decl (sym); - - if (sym->ts.type == BT_CHARACTER) - se->string_length = sym->ts.u.cl->backend_decl; - - if (!sym->attr.pointer - && sym->as - && sym->as->type != AS_ASSUMED_SHAPE - && sym->as->type != AS_DEFERRED - && sym->as->type != AS_ASSUMED_RANK - && !sym->attr.allocatable) - { - /* Some variables are declared directly, others are declared as - pointers and allocated on the heap. */ - if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp))) - se->expr = tmp; - else - se->expr = gfc_build_addr_expr (NULL_TREE, tmp); - if (size) - array_parameter_size (&se->pre, tmp, expr, size); - return; - } - - if (sym->attr.allocatable) - { - if (sym->attr.dummy || sym->attr.result) - { - gfc_conv_expr_descriptor (se, expr); - tmp = se->expr; - } - if (size) - array_parameter_size (&se->pre, tmp, expr, size); - se->expr = gfc_conv_array_data (tmp); - return; - } - } - - /* A convenient reduction in scope. */ - contiguous = g77 && !this_array_result && contiguous; - - /* There is no need to pack and unpack the array, if it is contiguous - and not a deferred- or assumed-shape array, or if it is simply - contiguous. */ - no_pack = ((sym && sym->as - && !sym->attr.pointer - && sym->as->type != AS_DEFERRED - && sym->as->type != AS_ASSUMED_RANK - && sym->as->type != AS_ASSUMED_SHAPE) - || - (ref && ref->u.ar.as - && ref->u.ar.as->type != AS_DEFERRED - && ref->u.ar.as->type != AS_ASSUMED_RANK - && ref->u.ar.as->type != AS_ASSUMED_SHAPE) - || - gfc_is_simply_contiguous (expr, false, true)); - - no_pack = contiguous && no_pack; - - /* If we have an EXPR_OP or a function returning an explicit-shaped - or allocatable array, an array temporary will be generated which - does not need to be packed / unpacked if passed to an - explicit-shape dummy array. */ - - if (g77) - { - if (expr->expr_type == EXPR_OP) - no_pack = 1; - else if (expr->expr_type == EXPR_FUNCTION && expr->value.function.esym) - { - gfc_symbol *result = expr->value.function.esym->result; - if (result->attr.dimension - && (result->as->type == AS_EXPLICIT - || result->attr.allocatable - || result->attr.contiguous)) - no_pack = 1; - } - } - - /* Array constructors are always contiguous and do not need packing. */ - array_constructor = g77 && !this_array_result && expr->expr_type == EXPR_ARRAY; - - /* Same is true of contiguous sections from allocatable variables. */ - good_allocatable = contiguous - && expr->symtree - && expr->symtree->n.sym->attr.allocatable; - - /* Or ultimate allocatable components. */ - ultimate_alloc_comp = contiguous && ultimate_alloc_comp; - - if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp) - { - gfc_conv_expr_descriptor (se, expr); - /* Deallocate the allocatable components of structures that are - not variable. */ - if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS) - && expr->ts.u.derived->attr.alloc_comp - && expr->expr_type != EXPR_VARIABLE) - { - tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, se->expr, expr->rank); - - /* The components shall be deallocated before their containing entity. */ - gfc_prepend_expr_to_block (&se->post, tmp); - } - if (expr->ts.type == BT_CHARACTER && expr->expr_type != EXPR_FUNCTION) - se->string_length = expr->ts.u.cl->backend_decl; - if (size) - array_parameter_size (&se->pre, se->expr, expr, size); - se->expr = gfc_conv_array_data (se->expr); - return; - } - - if (this_array_result) - { - /* Result of the enclosing function. */ - gfc_conv_expr_descriptor (se, expr); - if (size) - array_parameter_size (&se->pre, se->expr, expr, size); - se->expr = gfc_build_addr_expr (NULL_TREE, se->expr); - - if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE - && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr)))) - se->expr = gfc_conv_array_data (build_fold_indirect_ref_loc (input_location, - se->expr)); - - return; - } - else - { - /* Every other type of array. */ - se->want_pointer = 1; - gfc_conv_expr_descriptor (se, expr); - - if (size) - array_parameter_size (&se->pre, - build_fold_indirect_ref_loc (input_location, - se->expr), - expr, size); - } - - /* Deallocate the allocatable components of structures that are - not variable, for descriptorless arguments. - Arguments with a descriptor are handled in gfc_conv_procedure_call. */ - if (g77 && (expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS) - && expr->ts.u.derived->attr.alloc_comp - && expr->expr_type != EXPR_VARIABLE) - { - tmp = build_fold_indirect_ref_loc (input_location, se->expr); - tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank); - - /* The components shall be deallocated before their containing entity. */ - gfc_prepend_expr_to_block (&se->post, tmp); - } - - if (g77 || (fsym && fsym->attr.contiguous - && !gfc_is_simply_contiguous (expr, false, true))) - { - tree origptr = NULL_TREE; - - desc = se->expr; - - /* For contiguous arrays, save the original value of the descriptor. */ - if (!g77) - { - origptr = gfc_create_var (pvoid_type_node, "origptr"); - tmp = build_fold_indirect_ref_loc (input_location, desc); - tmp = gfc_conv_array_data (tmp); - tmp = fold_build2_loc (input_location, MODIFY_EXPR, - TREE_TYPE (origptr), origptr, - fold_convert (TREE_TYPE (origptr), tmp)); - gfc_add_expr_to_block (&se->pre, tmp); - } - - /* Repack the array. */ - if (warn_array_temporaries) - { - if (fsym) - gfc_warning (OPT_Warray_temporaries, - "Creating array temporary at %L for argument %qs", - &expr->where, fsym->name); - else - gfc_warning (OPT_Warray_temporaries, - "Creating array temporary at %L", &expr->where); - } - - /* When optmizing, we can use gfc_conv_subref_array_arg for - making the packing and unpacking operation visible to the - optimizers. */ - - if (g77 && flag_inline_arg_packing && expr->expr_type == EXPR_VARIABLE - && !is_pointer (expr) && ! gfc_has_dimen_vector_ref (expr) - && !(expr->symtree->n.sym->as - && expr->symtree->n.sym->as->type == AS_ASSUMED_RANK) - && (fsym == NULL || fsym->ts.type != BT_ASSUMED)) - { - gfc_conv_subref_array_arg (se, expr, g77, - fsym ? fsym->attr.intent : INTENT_INOUT, - false, fsym, proc_name, sym, true); - return; - } - - ptr = build_call_expr_loc (input_location, - gfor_fndecl_in_pack, 1, desc); - - if (fsym && fsym->attr.optional && sym && sym->attr.optional) - { - tmp = gfc_conv_expr_present (sym); - ptr = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr), - tmp, fold_convert (TREE_TYPE (se->expr), ptr), - fold_convert (TREE_TYPE (se->expr), null_pointer_node)); - } - - ptr = gfc_evaluate_now (ptr, &se->pre); - - /* Use the packed data for the actual argument, except for contiguous arrays, - where the descriptor's data component is set. */ - if (g77) - se->expr = ptr; - else - { - tmp = build_fold_indirect_ref_loc (input_location, desc); - - gfc_ss * ss = gfc_walk_expr (expr); - if (!transposed_dims (ss)) - gfc_conv_descriptor_data_set (&se->pre, tmp, ptr); - else - { - tree old_field, new_field; - - /* The original descriptor has transposed dims so we can't reuse - it directly; we have to create a new one. */ - tree old_desc = tmp; - tree new_desc = gfc_create_var (TREE_TYPE (old_desc), "arg_desc"); - - old_field = gfc_conv_descriptor_dtype (old_desc); - new_field = gfc_conv_descriptor_dtype (new_desc); - gfc_add_modify (&se->pre, new_field, old_field); - - old_field = gfc_conv_descriptor_offset (old_desc); - new_field = gfc_conv_descriptor_offset (new_desc); - gfc_add_modify (&se->pre, new_field, old_field); - - for (int i = 0; i < expr->rank; i++) - { - old_field = gfc_conv_descriptor_dimension (old_desc, - gfc_rank_cst[get_array_ref_dim_for_loop_dim (ss, i)]); - new_field = gfc_conv_descriptor_dimension (new_desc, - gfc_rank_cst[i]); - gfc_add_modify (&se->pre, new_field, old_field); - } - - if (flag_coarray == GFC_FCOARRAY_LIB - && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (old_desc)) - && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (old_desc)) - == GFC_ARRAY_ALLOCATABLE) - { - old_field = gfc_conv_descriptor_token (old_desc); - new_field = gfc_conv_descriptor_token (new_desc); - gfc_add_modify (&se->pre, new_field, old_field); - } - - gfc_conv_descriptor_data_set (&se->pre, new_desc, ptr); - se->expr = gfc_build_addr_expr (NULL_TREE, new_desc); - } - gfc_free_ss (ss); - } - - if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS) - { - char * msg; - - if (fsym && proc_name) - msg = xasprintf ("An array temporary was created for argument " - "'%s' of procedure '%s'", fsym->name, proc_name); - else - msg = xasprintf ("An array temporary was created"); - - tmp = build_fold_indirect_ref_loc (input_location, - desc); - tmp = gfc_conv_array_data (tmp); - tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - fold_convert (TREE_TYPE (tmp), ptr), tmp); - - if (fsym && fsym->attr.optional && sym && sym->attr.optional) - tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, - logical_type_node, - gfc_conv_expr_present (sym), tmp); - - gfc_trans_runtime_check (false, true, tmp, &se->pre, - &expr->where, msg); - free (msg); - } - - gfc_start_block (&block); - - /* Copy the data back. */ - if (fsym == NULL || fsym->attr.intent != INTENT_IN) - { - tmp = build_call_expr_loc (input_location, - gfor_fndecl_in_unpack, 2, desc, ptr); - gfc_add_expr_to_block (&block, tmp); - } - - /* Free the temporary. */ - tmp = gfc_call_free (ptr); - gfc_add_expr_to_block (&block, tmp); - - stmt = gfc_finish_block (&block); - - gfc_init_block (&block); - /* Only if it was repacked. This code needs to be executed before the - loop cleanup code. */ - tmp = build_fold_indirect_ref_loc (input_location, - desc); - tmp = gfc_conv_array_data (tmp); - tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - fold_convert (TREE_TYPE (tmp), ptr), tmp); - - if (fsym && fsym->attr.optional && sym && sym->attr.optional) - tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, - logical_type_node, - gfc_conv_expr_present (sym), tmp); - - tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location)); - - gfc_add_expr_to_block (&block, tmp); - gfc_add_block_to_block (&block, &se->post); - - gfc_init_block (&se->post); - - /* Reset the descriptor pointer. */ - if (!g77) - { - tmp = build_fold_indirect_ref_loc (input_location, desc); - gfc_conv_descriptor_data_set (&se->post, tmp, origptr); - } - - gfc_add_block_to_block (&se->post, &block); - } -} - - -/* This helper function calculates the size in words of a full array. */ - -tree -gfc_full_array_size (stmtblock_t *block, tree decl, int rank) -{ - tree idx; - tree nelems; - tree tmp; - idx = gfc_rank_cst[rank - 1]; - nelems = gfc_conv_descriptor_ubound_get (decl, idx); - tmp = gfc_conv_descriptor_lbound_get (decl, idx); - tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, - nelems, tmp); - tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - tmp, gfc_index_one_node); - tmp = gfc_evaluate_now (tmp, block); - - nelems = gfc_conv_descriptor_stride_get (decl, idx); - tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - nelems, tmp); - return gfc_evaluate_now (tmp, block); -} - - -/* Allocate dest to the same size as src, and copy src -> dest. - If no_malloc is set, only the copy is done. */ - -static tree -duplicate_allocatable (tree dest, tree src, tree type, int rank, - bool no_malloc, bool no_memcpy, tree str_sz, - tree add_when_allocated) -{ - tree tmp; - tree size; - tree nelems; - tree null_cond; - tree null_data; - stmtblock_t block; - - /* If the source is null, set the destination to null. Then, - allocate memory to the destination. */ - gfc_init_block (&block); - - if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest))) - { - gfc_add_modify (&block, dest, fold_convert (type, null_pointer_node)); - null_data = gfc_finish_block (&block); - - gfc_init_block (&block); - if (str_sz != NULL_TREE) - size = str_sz; - else - size = TYPE_SIZE_UNIT (TREE_TYPE (type)); - - if (!no_malloc) - { - tmp = gfc_call_malloc (&block, type, size); - gfc_add_modify (&block, dest, fold_convert (type, tmp)); - } - - if (!no_memcpy) - { - tmp = builtin_decl_explicit (BUILT_IN_MEMCPY); - tmp = build_call_expr_loc (input_location, tmp, 3, dest, src, - fold_convert (size_type_node, size)); - gfc_add_expr_to_block (&block, tmp); - } - } - else - { - gfc_conv_descriptor_data_set (&block, dest, null_pointer_node); - null_data = gfc_finish_block (&block); - - gfc_init_block (&block); - if (rank) - nelems = gfc_full_array_size (&block, src, rank); - else - nelems = gfc_index_one_node; - - if (str_sz != NULL_TREE) - tmp = fold_convert (gfc_array_index_type, str_sz); - else - tmp = fold_convert (gfc_array_index_type, - TYPE_SIZE_UNIT (gfc_get_element_type (type))); - size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - nelems, tmp); - if (!no_malloc) - { - tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src)); - tmp = gfc_call_malloc (&block, tmp, size); - gfc_conv_descriptor_data_set (&block, dest, tmp); - } - - /* We know the temporary and the value will be the same length, - so can use memcpy. */ - if (!no_memcpy) - { - tmp = builtin_decl_explicit (BUILT_IN_MEMCPY); - tmp = build_call_expr_loc (input_location, tmp, 3, - gfc_conv_descriptor_data_get (dest), - gfc_conv_descriptor_data_get (src), - fold_convert (size_type_node, size)); - gfc_add_expr_to_block (&block, tmp); - } - } - - gfc_add_expr_to_block (&block, add_when_allocated); - tmp = gfc_finish_block (&block); - - /* Null the destination if the source is null; otherwise do - the allocate and copy. */ - if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src))) - null_cond = src; - else - null_cond = gfc_conv_descriptor_data_get (src); - - null_cond = convert (pvoid_type_node, null_cond); - null_cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - null_cond, null_pointer_node); - return build3_v (COND_EXPR, null_cond, tmp, null_data); -} - - -/* Allocate dest to the same size as src, and copy data src -> dest. */ - -tree -gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank, - tree add_when_allocated) -{ - return duplicate_allocatable (dest, src, type, rank, false, false, - NULL_TREE, add_when_allocated); -} - - -/* Copy data src -> dest. */ - -tree -gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank) -{ - return duplicate_allocatable (dest, src, type, rank, true, false, - NULL_TREE, NULL_TREE); -} - -/* Allocate dest to the same size as src, but don't copy anything. */ - -tree -gfc_duplicate_allocatable_nocopy (tree dest, tree src, tree type, int rank) -{ - return duplicate_allocatable (dest, src, type, rank, false, true, - NULL_TREE, NULL_TREE); -} - - -static tree -duplicate_allocatable_coarray (tree dest, tree dest_tok, tree src, - tree type, int rank) -{ - tree tmp; - tree size; - tree nelems; - tree null_cond; - tree null_data; - stmtblock_t block, globalblock; - - /* If the source is null, set the destination to null. Then, - allocate memory to the destination. */ - gfc_init_block (&block); - gfc_init_block (&globalblock); - - if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest))) - { - gfc_se se; - symbol_attribute attr; - tree dummy_desc; - - gfc_init_se (&se, NULL); - gfc_clear_attr (&attr); - attr.allocatable = 1; - dummy_desc = gfc_conv_scalar_to_descriptor (&se, dest, attr); - gfc_add_block_to_block (&globalblock, &se.pre); - size = TYPE_SIZE_UNIT (TREE_TYPE (type)); - - gfc_add_modify (&block, dest, fold_convert (type, null_pointer_node)); - gfc_allocate_using_caf_lib (&block, dummy_desc, size, - gfc_build_addr_expr (NULL_TREE, dest_tok), - NULL_TREE, NULL_TREE, NULL_TREE, - GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY); - null_data = gfc_finish_block (&block); - - gfc_init_block (&block); - - gfc_allocate_using_caf_lib (&block, dummy_desc, - fold_convert (size_type_node, size), - gfc_build_addr_expr (NULL_TREE, dest_tok), - NULL_TREE, NULL_TREE, NULL_TREE, - GFC_CAF_COARRAY_ALLOC); - - tmp = builtin_decl_explicit (BUILT_IN_MEMCPY); - tmp = build_call_expr_loc (input_location, tmp, 3, dest, src, - fold_convert (size_type_node, size)); - gfc_add_expr_to_block (&block, tmp); - } - else - { - /* Set the rank or unitialized memory access may be reported. */ - tmp = gfc_conv_descriptor_rank (dest); - gfc_add_modify (&globalblock, tmp, build_int_cst (TREE_TYPE (tmp), rank)); - - if (rank) - nelems = gfc_full_array_size (&block, src, rank); - else - nelems = integer_one_node; - - tmp = fold_convert (size_type_node, - TYPE_SIZE_UNIT (gfc_get_element_type (type))); - size = fold_build2_loc (input_location, MULT_EXPR, size_type_node, - fold_convert (size_type_node, nelems), tmp); - - gfc_conv_descriptor_data_set (&block, dest, null_pointer_node); - gfc_allocate_using_caf_lib (&block, dest, fold_convert (size_type_node, - size), - gfc_build_addr_expr (NULL_TREE, dest_tok), - NULL_TREE, NULL_TREE, NULL_TREE, - GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY); - null_data = gfc_finish_block (&block); - - gfc_init_block (&block); - gfc_allocate_using_caf_lib (&block, dest, - fold_convert (size_type_node, size), - gfc_build_addr_expr (NULL_TREE, dest_tok), - NULL_TREE, NULL_TREE, NULL_TREE, - GFC_CAF_COARRAY_ALLOC); - - tmp = builtin_decl_explicit (BUILT_IN_MEMCPY); - tmp = build_call_expr_loc (input_location, tmp, 3, - gfc_conv_descriptor_data_get (dest), - gfc_conv_descriptor_data_get (src), - fold_convert (size_type_node, size)); - gfc_add_expr_to_block (&block, tmp); - } - - tmp = gfc_finish_block (&block); - - /* Null the destination if the source is null; otherwise do - the register and copy. */ - if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src))) - null_cond = src; - else - null_cond = gfc_conv_descriptor_data_get (src); - - null_cond = convert (pvoid_type_node, null_cond); - null_cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - null_cond, null_pointer_node); - gfc_add_expr_to_block (&globalblock, build3_v (COND_EXPR, null_cond, tmp, - null_data)); - return gfc_finish_block (&globalblock); -} - - -/* Helper function to abstract whether coarray processing is enabled. */ - -static bool -caf_enabled (int caf_mode) -{ - return (caf_mode & GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY) - == GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY; -} - - -/* Helper function to abstract whether coarray processing is enabled - and we are in a derived type coarray. */ - -static bool -caf_in_coarray (int caf_mode) -{ - static const int pat = GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY - | GFC_STRUCTURE_CAF_MODE_IN_COARRAY; - return (caf_mode & pat) == pat; -} - - -/* Helper function to abstract whether coarray is to deallocate only. */ - -bool -gfc_caf_is_dealloc_only (int caf_mode) -{ - return (caf_mode & GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY) - == GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY; -} - - -/* Recursively traverse an object of derived type, generating code to - deallocate, nullify or copy allocatable components. This is the work horse - function for the functions named in this enum. */ - -enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, - COPY_ALLOC_COMP, COPY_ONLY_ALLOC_COMP, REASSIGN_CAF_COMP, - ALLOCATE_PDT_COMP, DEALLOCATE_PDT_COMP, CHECK_PDT_DUMMY, - BCAST_ALLOC_COMP}; - -static gfc_actual_arglist *pdt_param_list; - -static tree -structure_alloc_comps (gfc_symbol * der_type, tree decl, - tree dest, int rank, int purpose, int caf_mode, - gfc_co_subroutines_args *args) -{ - gfc_component *c; - gfc_loopinfo loop; - stmtblock_t fnblock; - stmtblock_t loopbody; - stmtblock_t tmpblock; - tree decl_type; - tree tmp; - tree comp; - tree dcmp; - tree nelems; - tree index; - tree var; - tree cdecl; - tree ctype; - tree vref, dref; - tree null_cond = NULL_TREE; - tree add_when_allocated; - tree dealloc_fndecl; - tree caf_token; - gfc_symbol *vtab; - int caf_dereg_mode; - symbol_attribute *attr; - bool deallocate_called; - - gfc_init_block (&fnblock); - - decl_type = TREE_TYPE (decl); - - if ((POINTER_TYPE_P (decl_type)) - || (TREE_CODE (decl_type) == REFERENCE_TYPE && rank == 0)) - { - decl = build_fold_indirect_ref_loc (input_location, decl); - /* Deref dest in sync with decl, but only when it is not NULL. */ - if (dest) - dest = build_fold_indirect_ref_loc (input_location, dest); - - /* Update the decl_type because it got dereferenced. */ - decl_type = TREE_TYPE (decl); - } - - /* If this is an array of derived types with allocatable components - build a loop and recursively call this function. */ - if (TREE_CODE (decl_type) == ARRAY_TYPE - || (GFC_DESCRIPTOR_TYPE_P (decl_type) && rank != 0)) - { - tmp = gfc_conv_array_data (decl); - var = build_fold_indirect_ref_loc (input_location, tmp); - - /* Get the number of elements - 1 and set the counter. */ - if (GFC_DESCRIPTOR_TYPE_P (decl_type)) - { - /* Use the descriptor for an allocatable array. Since this - is a full array reference, we only need the descriptor - information from dimension = rank. */ - tmp = gfc_full_array_size (&fnblock, decl, rank); - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, tmp, - gfc_index_one_node); - - null_cond = gfc_conv_descriptor_data_get (decl); - null_cond = fold_build2_loc (input_location, NE_EXPR, - logical_type_node, null_cond, - build_int_cst (TREE_TYPE (null_cond), 0)); - } - else - { - /* Otherwise use the TYPE_DOMAIN information. */ - tmp = array_type_nelts (decl_type); - tmp = fold_convert (gfc_array_index_type, tmp); - } - - /* Remember that this is, in fact, the no. of elements - 1. */ - nelems = gfc_evaluate_now (tmp, &fnblock); - index = gfc_create_var (gfc_array_index_type, "S"); - - /* Build the body of the loop. */ - gfc_init_block (&loopbody); - - vref = gfc_build_array_ref (var, index, NULL); - - if (purpose == COPY_ALLOC_COMP || purpose == COPY_ONLY_ALLOC_COMP) - { - tmp = build_fold_indirect_ref_loc (input_location, - gfc_conv_array_data (dest)); - dref = gfc_build_array_ref (tmp, index, NULL); - tmp = structure_alloc_comps (der_type, vref, dref, rank, - COPY_ALLOC_COMP, caf_mode, args); - } - else - tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose, - caf_mode, args); - - gfc_add_expr_to_block (&loopbody, tmp); - - /* Build the loop and return. */ - gfc_init_loopinfo (&loop); - loop.dimen = 1; - loop.from[0] = gfc_index_zero_node; - loop.loopvar[0] = index; - loop.to[0] = nelems; - gfc_trans_scalarizing_loops (&loop, &loopbody); - gfc_add_block_to_block (&fnblock, &loop.pre); - - tmp = gfc_finish_block (&fnblock); - /* When copying allocateable components, the above implements the - deep copy. Nevertheless is a deep copy only allowed, when the current - component is allocated, for which code will be generated in - gfc_duplicate_allocatable (), where the deep copy code is just added - into the if's body, by adding tmp (the deep copy code) as last - argument to gfc_duplicate_allocatable (). */ - if (purpose == COPY_ALLOC_COMP - && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest))) - tmp = gfc_duplicate_allocatable (dest, decl, decl_type, rank, - tmp); - else if (null_cond != NULL_TREE) - tmp = build3_v (COND_EXPR, null_cond, tmp, - build_empty_stmt (input_location)); - - return tmp; - } - - if (purpose == DEALLOCATE_ALLOC_COMP && der_type->attr.pdt_type) - { - tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank, - DEALLOCATE_PDT_COMP, 0, args); - gfc_add_expr_to_block (&fnblock, tmp); - } - else if (purpose == ALLOCATE_PDT_COMP && der_type->attr.alloc_comp) - { - tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank, - NULLIFY_ALLOC_COMP, 0, args); - gfc_add_expr_to_block (&fnblock, tmp); - } - - /* Otherwise, act on the components or recursively call self to - act on a chain of components. */ - for (c = der_type->components; c; c = c->next) - { - bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED - || c->ts.type == BT_CLASS) - && c->ts.u.derived->attr.alloc_comp; - bool same_type = (c->ts.type == BT_DERIVED && der_type == c->ts.u.derived) - || (c->ts.type == BT_CLASS && der_type == CLASS_DATA (c)->ts.u.derived); - - bool is_pdt_type = c->ts.type == BT_DERIVED - && c->ts.u.derived->attr.pdt_type; - - cdecl = c->backend_decl; - ctype = TREE_TYPE (cdecl); - - switch (purpose) - { - - case BCAST_ALLOC_COMP: - - tree ubound; - tree cdesc; - stmtblock_t derived_type_block; - - gfc_init_block (&tmpblock); - - comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, - decl, cdecl, NULL_TREE); - - /* Shortcut to get the attributes of the component. */ - if (c->ts.type == BT_CLASS) - { - attr = &CLASS_DATA (c)->attr; - if (attr->class_pointer) - continue; - } - else - { - attr = &c->attr; - if (attr->pointer) - continue; - } - - add_when_allocated = NULL_TREE; - if (cmp_has_alloc_comps - && !c->attr.pointer && !c->attr.proc_pointer) - { - if (c->ts.type == BT_CLASS) - { - rank = CLASS_DATA (c)->as ? CLASS_DATA (c)->as->rank : 0; - add_when_allocated - = structure_alloc_comps (CLASS_DATA (c)->ts.u.derived, - comp, NULL_TREE, rank, purpose, - caf_mode, args); - } - else - { - rank = c->as ? c->as->rank : 0; - add_when_allocated = structure_alloc_comps (c->ts.u.derived, - comp, NULL_TREE, - rank, purpose, - caf_mode, args); - } - } - - gfc_init_block (&derived_type_block); - if (add_when_allocated) - gfc_add_expr_to_block (&derived_type_block, add_when_allocated); - tmp = gfc_finish_block (&derived_type_block); - gfc_add_expr_to_block (&tmpblock, tmp); - - /* Convert the component into a rank 1 descriptor type. */ - if (attr->dimension) - { - tmp = gfc_get_element_type (TREE_TYPE (comp)); - ubound = gfc_full_array_size (&tmpblock, comp, - c->ts.type == BT_CLASS - ? CLASS_DATA (c)->as->rank - : c->as->rank); - } - else - { - tmp = TREE_TYPE (comp); - ubound = build_int_cst (gfc_array_index_type, 1); - } - - cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node, - &ubound, 1, - GFC_ARRAY_ALLOCATABLE, false); - - cdesc = gfc_create_var (cdesc, "cdesc"); - DECL_ARTIFICIAL (cdesc) = 1; - - gfc_add_modify (&tmpblock, gfc_conv_descriptor_dtype (cdesc), - gfc_get_dtype_rank_type (1, tmp)); - gfc_conv_descriptor_lbound_set (&tmpblock, cdesc, - gfc_index_zero_node, - gfc_index_one_node); - gfc_conv_descriptor_stride_set (&tmpblock, cdesc, - gfc_index_zero_node, - gfc_index_one_node); - gfc_conv_descriptor_ubound_set (&tmpblock, cdesc, - gfc_index_zero_node, ubound); - - if (attr->dimension) - comp = gfc_conv_descriptor_data_get (comp); - else - { - gfc_se se; - - gfc_init_se (&se, NULL); - - comp = gfc_conv_scalar_to_descriptor (&se, comp, - c->ts.type == BT_CLASS - ? CLASS_DATA (c)->attr - : c->attr); - comp = gfc_build_addr_expr (NULL_TREE, comp); - gfc_add_block_to_block (&tmpblock, &se.pre); - } - - gfc_conv_descriptor_data_set (&tmpblock, cdesc, comp); - - tree fndecl; - - fndecl = build_call_expr_loc (input_location, - gfor_fndecl_co_broadcast, 5, - gfc_build_addr_expr (pvoid_type_node,cdesc), - args->image_index, - null_pointer_node, null_pointer_node, - null_pointer_node); - - gfc_add_expr_to_block (&tmpblock, fndecl); - gfc_add_block_to_block (&fnblock, &tmpblock); - - break; - - case DEALLOCATE_ALLOC_COMP: - - gfc_init_block (&tmpblock); - - comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, - decl, cdecl, NULL_TREE); - - /* Shortcut to get the attributes of the component. */ - if (c->ts.type == BT_CLASS) - { - attr = &CLASS_DATA (c)->attr; - if (attr->class_pointer) - continue; - } - else - { - attr = &c->attr; - if (attr->pointer) - continue; - } - - if ((c->ts.type == BT_DERIVED && !c->attr.pointer) - || (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer)) - /* Call the finalizer, which will free the memory and nullify the - pointer of an array. */ - deallocate_called = gfc_add_comp_finalizer_call (&tmpblock, comp, c, - caf_enabled (caf_mode)) - && attr->dimension; - else - deallocate_called = false; - - /* Add the _class ref for classes. */ - if (c->ts.type == BT_CLASS && attr->allocatable) - comp = gfc_class_data_get (comp); - - add_when_allocated = NULL_TREE; - if (cmp_has_alloc_comps - && !c->attr.pointer && !c->attr.proc_pointer - && !same_type - && !deallocate_called) - { - /* Add checked deallocation of the components. This code is - obviously added because the finalizer is not trusted to free - all memory. */ - if (c->ts.type == BT_CLASS) - { - rank = CLASS_DATA (c)->as ? CLASS_DATA (c)->as->rank : 0; - add_when_allocated - = structure_alloc_comps (CLASS_DATA (c)->ts.u.derived, - comp, NULL_TREE, rank, purpose, - caf_mode, args); - } - else - { - rank = c->as ? c->as->rank : 0; - add_when_allocated = structure_alloc_comps (c->ts.u.derived, - comp, NULL_TREE, - rank, purpose, - caf_mode, args); - } - } - - if (attr->allocatable && !same_type - && (!attr->codimension || caf_enabled (caf_mode))) - { - /* Handle all types of components besides components of the - same_type as the current one, because those would create an - endless loop. */ - caf_dereg_mode - = (caf_in_coarray (caf_mode) || attr->codimension) - ? (gfc_caf_is_dealloc_only (caf_mode) - ? GFC_CAF_COARRAY_DEALLOCATE_ONLY - : GFC_CAF_COARRAY_DEREGISTER) - : GFC_CAF_COARRAY_NOCOARRAY; - - caf_token = NULL_TREE; - /* Coarray components are handled directly by - deallocate_with_status. */ - if (!attr->codimension - && caf_dereg_mode != GFC_CAF_COARRAY_NOCOARRAY) - { - if (c->caf_token) - caf_token = fold_build3_loc (input_location, COMPONENT_REF, - TREE_TYPE (c->caf_token), - decl, c->caf_token, NULL_TREE); - else if (attr->dimension && !attr->proc_pointer) - caf_token = gfc_conv_descriptor_token (comp); - } - if (attr->dimension && !attr->codimension && !attr->proc_pointer) - /* When this is an array but not in conjunction with a coarray - then add the data-ref. For coarray'ed arrays the data-ref - is added by deallocate_with_status. */ - comp = gfc_conv_descriptor_data_get (comp); - - tmp = gfc_deallocate_with_status (comp, NULL_TREE, NULL_TREE, - NULL_TREE, NULL_TREE, true, - NULL, caf_dereg_mode, - add_when_allocated, caf_token); - - gfc_add_expr_to_block (&tmpblock, tmp); - } - else if (attr->allocatable && !attr->codimension - && !deallocate_called) - { - /* Case of recursive allocatable derived types. */ - tree is_allocated; - tree ubound; - tree cdesc; - stmtblock_t dealloc_block; - - gfc_init_block (&dealloc_block); - if (add_when_allocated) - gfc_add_expr_to_block (&dealloc_block, add_when_allocated); - - /* Convert the component into a rank 1 descriptor type. */ - if (attr->dimension) - { - tmp = gfc_get_element_type (TREE_TYPE (comp)); - ubound = gfc_full_array_size (&dealloc_block, comp, - c->ts.type == BT_CLASS - ? CLASS_DATA (c)->as->rank - : c->as->rank); - } - else - { - tmp = TREE_TYPE (comp); - ubound = build_int_cst (gfc_array_index_type, 1); - } - - cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node, - &ubound, 1, - GFC_ARRAY_ALLOCATABLE, false); - - cdesc = gfc_create_var (cdesc, "cdesc"); - DECL_ARTIFICIAL (cdesc) = 1; - - gfc_add_modify (&dealloc_block, gfc_conv_descriptor_dtype (cdesc), - gfc_get_dtype_rank_type (1, tmp)); - gfc_conv_descriptor_lbound_set (&dealloc_block, cdesc, - gfc_index_zero_node, - gfc_index_one_node); - gfc_conv_descriptor_stride_set (&dealloc_block, cdesc, - gfc_index_zero_node, - gfc_index_one_node); - gfc_conv_descriptor_ubound_set (&dealloc_block, cdesc, - gfc_index_zero_node, ubound); - - if (attr->dimension) - comp = gfc_conv_descriptor_data_get (comp); - - gfc_conv_descriptor_data_set (&dealloc_block, cdesc, comp); - - /* Now call the deallocator. */ - vtab = gfc_find_vtab (&c->ts); - if (vtab->backend_decl == NULL) - gfc_get_symbol_decl (vtab); - tmp = gfc_build_addr_expr (NULL_TREE, vtab->backend_decl); - dealloc_fndecl = gfc_vptr_deallocate_get (tmp); - dealloc_fndecl = build_fold_indirect_ref_loc (input_location, - dealloc_fndecl); - tmp = build_int_cst (TREE_TYPE (comp), 0); - is_allocated = fold_build2_loc (input_location, NE_EXPR, - logical_type_node, tmp, - comp); - cdesc = gfc_build_addr_expr (NULL_TREE, cdesc); - - tmp = build_call_expr_loc (input_location, - dealloc_fndecl, 1, - cdesc); - gfc_add_expr_to_block (&dealloc_block, tmp); - - tmp = gfc_finish_block (&dealloc_block); - - tmp = fold_build3_loc (input_location, COND_EXPR, - void_type_node, is_allocated, tmp, - build_empty_stmt (input_location)); - - gfc_add_expr_to_block (&tmpblock, tmp); - } - else if (add_when_allocated) - gfc_add_expr_to_block (&tmpblock, add_when_allocated); - - if (c->ts.type == BT_CLASS && attr->allocatable - && (!attr->codimension || !caf_enabled (caf_mode))) - { - /* Finally, reset the vptr to the declared type vtable and, if - necessary reset the _len field. - - First recover the reference to the component and obtain - the vptr. */ - comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, - decl, cdecl, NULL_TREE); - tmp = gfc_class_vptr_get (comp); - - if (UNLIMITED_POLY (c)) - { - /* Both vptr and _len field should be nulled. */ - gfc_add_modify (&tmpblock, tmp, - build_int_cst (TREE_TYPE (tmp), 0)); - tmp = gfc_class_len_get (comp); - gfc_add_modify (&tmpblock, tmp, - build_int_cst (TREE_TYPE (tmp), 0)); - } - else - { - /* Build the vtable address and set the vptr with it. */ - tree vtab; - gfc_symbol *vtable; - vtable = gfc_find_derived_vtab (c->ts.u.derived); - vtab = vtable->backend_decl; - if (vtab == NULL_TREE) - vtab = gfc_get_symbol_decl (vtable); - vtab = gfc_build_addr_expr (NULL, vtab); - vtab = fold_convert (TREE_TYPE (tmp), vtab); - gfc_add_modify (&tmpblock, tmp, vtab); - } - } - - /* Now add the deallocation of this component. */ - gfc_add_block_to_block (&fnblock, &tmpblock); - break; - - case NULLIFY_ALLOC_COMP: - /* Nullify - - allocatable components (regular or in class) - - components that have allocatable components - - pointer components when in a coarray. - Skip everything else especially proc_pointers, which may come - coupled with the regular pointer attribute. */ - if (c->attr.proc_pointer - || !(c->attr.allocatable || (c->ts.type == BT_CLASS - && CLASS_DATA (c)->attr.allocatable) - || (cmp_has_alloc_comps - && ((c->ts.type == BT_DERIVED && !c->attr.pointer) - || (c->ts.type == BT_CLASS - && !CLASS_DATA (c)->attr.class_pointer))) - || (caf_in_coarray (caf_mode) && c->attr.pointer))) - continue; - - /* Process class components first, because they always have the - pointer-attribute set which would be caught wrong else. */ - if (c->ts.type == BT_CLASS - && (CLASS_DATA (c)->attr.allocatable - || CLASS_DATA (c)->attr.class_pointer)) - { - tree vptr_decl; - - /* Allocatable CLASS components. */ - comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, - decl, cdecl, NULL_TREE); - - vptr_decl = gfc_class_vptr_get (comp); - - comp = gfc_class_data_get (comp); - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp))) - gfc_conv_descriptor_data_set (&fnblock, comp, - null_pointer_node); - else - { - tmp = fold_build2_loc (input_location, MODIFY_EXPR, - void_type_node, comp, - build_int_cst (TREE_TYPE (comp), 0)); - gfc_add_expr_to_block (&fnblock, tmp); - } - - /* The dynamic type of a disassociated pointer or unallocated - allocatable variable is its declared type. An unlimited - polymorphic entity has no declared type. */ - if (!UNLIMITED_POLY (c)) - { - vtab = gfc_find_derived_vtab (c->ts.u.derived); - if (!vtab->backend_decl) - gfc_get_symbol_decl (vtab); - tmp = gfc_build_addr_expr (NULL_TREE, vtab->backend_decl); - } - else - tmp = build_int_cst (TREE_TYPE (vptr_decl), 0); - - tmp = fold_build2_loc (input_location, MODIFY_EXPR, - void_type_node, vptr_decl, tmp); - gfc_add_expr_to_block (&fnblock, tmp); - - cmp_has_alloc_comps = false; - } - /* Coarrays need the component to be nulled before the api-call - is made. */ - else if (c->attr.pointer || c->attr.allocatable) - { - comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, - decl, cdecl, NULL_TREE); - if (c->attr.dimension || c->attr.codimension) - gfc_conv_descriptor_data_set (&fnblock, comp, - null_pointer_node); - else - gfc_add_modify (&fnblock, comp, - build_int_cst (TREE_TYPE (comp), 0)); - if (gfc_deferred_strlen (c, &comp)) - { - comp = fold_build3_loc (input_location, COMPONENT_REF, - TREE_TYPE (comp), - decl, comp, NULL_TREE); - tmp = fold_build2_loc (input_location, MODIFY_EXPR, - TREE_TYPE (comp), comp, - build_int_cst (TREE_TYPE (comp), 0)); - gfc_add_expr_to_block (&fnblock, tmp); - } - cmp_has_alloc_comps = false; - } - - if (flag_coarray == GFC_FCOARRAY_LIB && caf_in_coarray (caf_mode)) - { - /* Register a component of a derived type coarray with the - coarray library. Do not register ultimate component - coarrays here. They are treated like regular coarrays and - are either allocated on all images or on none. */ - tree token; - - comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, - decl, cdecl, NULL_TREE); - if (c->attr.dimension) - { - /* Set the dtype, because caf_register needs it. */ - gfc_add_modify (&fnblock, gfc_conv_descriptor_dtype (comp), - gfc_get_dtype (TREE_TYPE (comp))); - tmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, - decl, cdecl, NULL_TREE); - token = gfc_conv_descriptor_token (tmp); - } - else - { - gfc_se se; - - gfc_init_se (&se, NULL); - token = fold_build3_loc (input_location, COMPONENT_REF, - pvoid_type_node, decl, c->caf_token, - NULL_TREE); - comp = gfc_conv_scalar_to_descriptor (&se, comp, - c->ts.type == BT_CLASS - ? CLASS_DATA (c)->attr - : c->attr); - gfc_add_block_to_block (&fnblock, &se.pre); - } - - gfc_allocate_using_caf_lib (&fnblock, comp, size_zero_node, - gfc_build_addr_expr (NULL_TREE, - token), - NULL_TREE, NULL_TREE, NULL_TREE, - GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY); - } - - if (cmp_has_alloc_comps) - { - comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, - decl, cdecl, NULL_TREE); - rank = c->as ? c->as->rank : 0; - tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE, - rank, purpose, caf_mode, args); - gfc_add_expr_to_block (&fnblock, tmp); - } - break; - - case REASSIGN_CAF_COMP: - if (caf_enabled (caf_mode) - && (c->attr.codimension - || (c->ts.type == BT_CLASS - && (CLASS_DATA (c)->attr.coarray_comp - || caf_in_coarray (caf_mode))) - || (c->ts.type == BT_DERIVED - && (c->ts.u.derived->attr.coarray_comp - || caf_in_coarray (caf_mode)))) - && !same_type) - { - comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, - decl, cdecl, NULL_TREE); - dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, - dest, cdecl, NULL_TREE); - - if (c->attr.codimension) - { - if (c->ts.type == BT_CLASS) - { - comp = gfc_class_data_get (comp); - dcmp = gfc_class_data_get (dcmp); - } - gfc_conv_descriptor_data_set (&fnblock, dcmp, - gfc_conv_descriptor_data_get (comp)); - } - else - { - tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp, - rank, purpose, caf_mode - | GFC_STRUCTURE_CAF_MODE_IN_COARRAY, - args); - gfc_add_expr_to_block (&fnblock, tmp); - } - } - break; - - case COPY_ALLOC_COMP: - if (c->attr.pointer || c->attr.proc_pointer) - continue; - - /* We need source and destination components. */ - comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl, - cdecl, NULL_TREE); - dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, dest, - cdecl, NULL_TREE); - dcmp = fold_convert (TREE_TYPE (comp), dcmp); - - if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable) - { - tree ftn_tree; - tree size; - tree dst_data; - tree src_data; - tree null_data; - - dst_data = gfc_class_data_get (dcmp); - src_data = gfc_class_data_get (comp); - size = fold_convert (size_type_node, - gfc_class_vtab_size_get (comp)); - - if (CLASS_DATA (c)->attr.dimension) - { - nelems = gfc_conv_descriptor_size (src_data, - CLASS_DATA (c)->as->rank); - size = fold_build2_loc (input_location, MULT_EXPR, - size_type_node, size, - fold_convert (size_type_node, - nelems)); - } - else - nelems = build_int_cst (size_type_node, 1); - - if (CLASS_DATA (c)->attr.dimension - || CLASS_DATA (c)->attr.codimension) - { - src_data = gfc_conv_descriptor_data_get (src_data); - dst_data = gfc_conv_descriptor_data_get (dst_data); - } - - gfc_init_block (&tmpblock); - - gfc_add_modify (&tmpblock, gfc_class_vptr_get (dcmp), - gfc_class_vptr_get (comp)); - - /* Copy the unlimited '_len' field. If it is greater than zero - (ie. a character(_len)), multiply it by size and use this - for the malloc call. */ - if (UNLIMITED_POLY (c)) - { - gfc_add_modify (&tmpblock, gfc_class_len_get (dcmp), - gfc_class_len_get (comp)); - size = gfc_resize_class_size_with_len (&tmpblock, comp, size); - } - - /* Coarray component have to have the same allocation status and - shape/type-parameter/effective-type on the LHS and RHS of an - intrinsic assignment. Hence, we did not deallocated them - and - do not allocate them here. */ - if (!CLASS_DATA (c)->attr.codimension) - { - ftn_tree = builtin_decl_explicit (BUILT_IN_MALLOC); - tmp = build_call_expr_loc (input_location, ftn_tree, 1, size); - gfc_add_modify (&tmpblock, dst_data, - fold_convert (TREE_TYPE (dst_data), tmp)); - } - - tmp = gfc_copy_class_to_class (comp, dcmp, nelems, - UNLIMITED_POLY (c)); - gfc_add_expr_to_block (&tmpblock, tmp); - tmp = gfc_finish_block (&tmpblock); - - gfc_init_block (&tmpblock); - gfc_add_modify (&tmpblock, dst_data, - fold_convert (TREE_TYPE (dst_data), - null_pointer_node)); - null_data = gfc_finish_block (&tmpblock); - - null_cond = fold_build2_loc (input_location, NE_EXPR, - logical_type_node, src_data, - null_pointer_node); - - gfc_add_expr_to_block (&fnblock, build3_v (COND_EXPR, null_cond, - tmp, null_data)); - continue; - } - - /* To implement guarded deep copy, i.e., deep copy only allocatable - components that are really allocated, the deep copy code has to - be generated first and then added to the if-block in - gfc_duplicate_allocatable (). */ - if (cmp_has_alloc_comps && !c->attr.proc_pointer && !same_type) - { - rank = c->as ? c->as->rank : 0; - tmp = fold_convert (TREE_TYPE (dcmp), comp); - gfc_add_modify (&fnblock, dcmp, tmp); - add_when_allocated = structure_alloc_comps (c->ts.u.derived, - comp, dcmp, - rank, purpose, - caf_mode, args); - } - else - add_when_allocated = NULL_TREE; - - if (gfc_deferred_strlen (c, &tmp)) - { - tree len, size; - len = tmp; - tmp = fold_build3_loc (input_location, COMPONENT_REF, - TREE_TYPE (len), - decl, len, NULL_TREE); - len = fold_build3_loc (input_location, COMPONENT_REF, - TREE_TYPE (len), - dest, len, NULL_TREE); - tmp = fold_build2_loc (input_location, MODIFY_EXPR, - TREE_TYPE (len), len, tmp); - gfc_add_expr_to_block (&fnblock, tmp); - size = size_of_string_in_bytes (c->ts.kind, len); - /* This component cannot have allocatable components, - therefore add_when_allocated of duplicate_allocatable () - is always NULL. */ - tmp = duplicate_allocatable (dcmp, comp, ctype, rank, - false, false, size, NULL_TREE); - gfc_add_expr_to_block (&fnblock, tmp); - } - else if (c->attr.pdt_array) - { - tmp = duplicate_allocatable (dcmp, comp, ctype, - c->as ? c->as->rank : 0, - false, false, NULL_TREE, NULL_TREE); - gfc_add_expr_to_block (&fnblock, tmp); - } - else if ((c->attr.allocatable) - && !c->attr.proc_pointer && !same_type - && (!(cmp_has_alloc_comps && c->as) || c->attr.codimension - || caf_in_coarray (caf_mode))) - { - rank = c->as ? c->as->rank : 0; - if (c->attr.codimension) - tmp = gfc_copy_allocatable_data (dcmp, comp, ctype, rank); - else if (flag_coarray == GFC_FCOARRAY_LIB - && caf_in_coarray (caf_mode)) - { - tree dst_tok; - if (c->as) - dst_tok = gfc_conv_descriptor_token (dcmp); - else - { - /* For a scalar allocatable component the caf_token is - the next component. */ - if (!c->caf_token) - c->caf_token = c->next->backend_decl; - dst_tok = fold_build3_loc (input_location, - COMPONENT_REF, - pvoid_type_node, dest, - c->caf_token, - NULL_TREE); - } - tmp = duplicate_allocatable_coarray (dcmp, dst_tok, comp, - ctype, rank); - } - else - tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank, - add_when_allocated); - gfc_add_expr_to_block (&fnblock, tmp); - } - else - if (cmp_has_alloc_comps || is_pdt_type) - gfc_add_expr_to_block (&fnblock, add_when_allocated); - - break; - - case ALLOCATE_PDT_COMP: - - comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, - decl, cdecl, NULL_TREE); - - /* Set the PDT KIND and LEN fields. */ - if (c->attr.pdt_kind || c->attr.pdt_len) - { - gfc_se tse; - gfc_expr *c_expr = NULL; - gfc_actual_arglist *param = pdt_param_list; - gfc_init_se (&tse, NULL); - for (; param; param = param->next) - if (param->name && !strcmp (c->name, param->name)) - c_expr = param->expr; - - if (!c_expr) - c_expr = c->initializer; - - if (c_expr) - { - gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp)); - gfc_add_modify (&fnblock, comp, tse.expr); - } - } - - if (c->attr.pdt_string) - { - gfc_se tse; - gfc_init_se (&tse, NULL); - tree strlen = NULL_TREE; - gfc_expr *e = gfc_copy_expr (c->ts.u.cl->length); - /* Convert the parameterized string length to its value. The - string length is stored in a hidden field in the same way as - deferred string lengths. */ - gfc_insert_parameter_exprs (e, pdt_param_list); - if (gfc_deferred_strlen (c, &strlen) && strlen != NULL_TREE) - { - gfc_conv_expr_type (&tse, e, - TREE_TYPE (strlen)); - strlen = fold_build3_loc (input_location, COMPONENT_REF, - TREE_TYPE (strlen), - decl, strlen, NULL_TREE); - gfc_add_modify (&fnblock, strlen, tse.expr); - c->ts.u.cl->backend_decl = strlen; - } - gfc_free_expr (e); - - /* Scalar parameterized strings can be allocated now. */ - if (!c->as) - { - tmp = fold_convert (gfc_array_index_type, strlen); - tmp = size_of_string_in_bytes (c->ts.kind, tmp); - tmp = gfc_evaluate_now (tmp, &fnblock); - tmp = gfc_call_malloc (&fnblock, TREE_TYPE (comp), tmp); - gfc_add_modify (&fnblock, comp, tmp); - } - } - - /* Allocate parameterized arrays of parameterized derived types. */ - if (!(c->attr.pdt_array && c->as && c->as->type == AS_EXPLICIT) - && !((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) - && (c->ts.u.derived && c->ts.u.derived->attr.pdt_type))) - continue; - - if (c->ts.type == BT_CLASS) - comp = gfc_class_data_get (comp); - - if (c->attr.pdt_array) - { - gfc_se tse; - int i; - tree size = gfc_index_one_node; - tree offset = gfc_index_zero_node; - tree lower, upper; - gfc_expr *e; - - /* This chunk takes the expressions for 'lower' and 'upper' - in the arrayspec and substitutes in the expressions for - the parameters from 'pdt_param_list'. The descriptor - fields can then be filled from the values so obtained. */ - gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp))); - for (i = 0; i < c->as->rank; i++) - { - gfc_init_se (&tse, NULL); - e = gfc_copy_expr (c->as->lower[i]); - gfc_insert_parameter_exprs (e, pdt_param_list); - gfc_conv_expr_type (&tse, e, gfc_array_index_type); - gfc_free_expr (e); - lower = tse.expr; - gfc_conv_descriptor_lbound_set (&fnblock, comp, - gfc_rank_cst[i], - lower); - e = gfc_copy_expr (c->as->upper[i]); - gfc_insert_parameter_exprs (e, pdt_param_list); - gfc_conv_expr_type (&tse, e, gfc_array_index_type); - gfc_free_expr (e); - upper = tse.expr; - gfc_conv_descriptor_ubound_set (&fnblock, comp, - gfc_rank_cst[i], - upper); - gfc_conv_descriptor_stride_set (&fnblock, comp, - gfc_rank_cst[i], - size); - size = gfc_evaluate_now (size, &fnblock); - offset = fold_build2_loc (input_location, - MINUS_EXPR, - gfc_array_index_type, - offset, size); - offset = gfc_evaluate_now (offset, &fnblock); - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - upper, lower); - tmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, - tmp, gfc_index_one_node); - size = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, size, tmp); - } - gfc_conv_descriptor_offset_set (&fnblock, comp, offset); - if (c->ts.type == BT_CLASS) - { - tmp = gfc_get_vptr_from_expr (comp); - if (POINTER_TYPE_P (TREE_TYPE (tmp))) - tmp = build_fold_indirect_ref_loc (input_location, tmp); - tmp = gfc_vptr_size_get (tmp); - } - else - tmp = TYPE_SIZE_UNIT (gfc_get_element_type (ctype)); - tmp = fold_convert (gfc_array_index_type, tmp); - size = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, size, tmp); - size = gfc_evaluate_now (size, &fnblock); - tmp = gfc_call_malloc (&fnblock, NULL, size); - gfc_conv_descriptor_data_set (&fnblock, comp, tmp); - tmp = gfc_conv_descriptor_dtype (comp); - gfc_add_modify (&fnblock, tmp, gfc_get_dtype (ctype)); - - if (c->initializer && c->initializer->rank) - { - gfc_init_se (&tse, NULL); - e = gfc_copy_expr (c->initializer); - gfc_insert_parameter_exprs (e, pdt_param_list); - gfc_conv_expr_descriptor (&tse, e); - gfc_add_block_to_block (&fnblock, &tse.pre); - gfc_free_expr (e); - tmp = builtin_decl_explicit (BUILT_IN_MEMCPY); - tmp = build_call_expr_loc (input_location, tmp, 3, - gfc_conv_descriptor_data_get (comp), - gfc_conv_descriptor_data_get (tse.expr), - fold_convert (size_type_node, size)); - gfc_add_expr_to_block (&fnblock, tmp); - gfc_add_block_to_block (&fnblock, &tse.post); - } - } - - /* Recurse in to PDT components. */ - if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) - && c->ts.u.derived && c->ts.u.derived->attr.pdt_type - && !(c->attr.pointer || c->attr.allocatable)) - { - bool is_deferred = false; - gfc_actual_arglist *tail = c->param_list; - - for (; tail; tail = tail->next) - if (!tail->expr) - is_deferred = true; - - tail = is_deferred ? pdt_param_list : c->param_list; - tmp = gfc_allocate_pdt_comp (c->ts.u.derived, comp, - c->as ? c->as->rank : 0, - tail); - gfc_add_expr_to_block (&fnblock, tmp); - } - - break; - - case DEALLOCATE_PDT_COMP: - /* Deallocate array or parameterized string length components - of parameterized derived types. */ - if (!(c->attr.pdt_array && c->as && c->as->type == AS_EXPLICIT) - && !c->attr.pdt_string - && !((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) - && (c->ts.u.derived && c->ts.u.derived->attr.pdt_type))) - continue; - - comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, - decl, cdecl, NULL_TREE); - if (c->ts.type == BT_CLASS) - comp = gfc_class_data_get (comp); - - /* Recurse in to PDT components. */ - if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) - && c->ts.u.derived && c->ts.u.derived->attr.pdt_type - && (!c->attr.pointer && !c->attr.allocatable)) - { - tmp = gfc_deallocate_pdt_comp (c->ts.u.derived, comp, - c->as ? c->as->rank : 0); - gfc_add_expr_to_block (&fnblock, tmp); - } - - if (c->attr.pdt_array) - { - tmp = gfc_conv_descriptor_data_get (comp); - null_cond = fold_build2_loc (input_location, NE_EXPR, - logical_type_node, tmp, - build_int_cst (TREE_TYPE (tmp), 0)); - tmp = gfc_call_free (tmp); - tmp = build3_v (COND_EXPR, null_cond, tmp, - build_empty_stmt (input_location)); - gfc_add_expr_to_block (&fnblock, tmp); - gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node); - } - else if (c->attr.pdt_string) - { - null_cond = fold_build2_loc (input_location, NE_EXPR, - logical_type_node, comp, - build_int_cst (TREE_TYPE (comp), 0)); - tmp = gfc_call_free (comp); - tmp = build3_v (COND_EXPR, null_cond, tmp, - build_empty_stmt (input_location)); - gfc_add_expr_to_block (&fnblock, tmp); - tmp = fold_convert (TREE_TYPE (comp), null_pointer_node); - gfc_add_modify (&fnblock, comp, tmp); - } - - break; - - case CHECK_PDT_DUMMY: - - comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, - decl, cdecl, NULL_TREE); - if (c->ts.type == BT_CLASS) - comp = gfc_class_data_get (comp); - - /* Recurse in to PDT components. */ - if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) - && c->ts.u.derived && c->ts.u.derived->attr.pdt_type) - { - tmp = gfc_check_pdt_dummy (c->ts.u.derived, comp, - c->as ? c->as->rank : 0, - pdt_param_list); - gfc_add_expr_to_block (&fnblock, tmp); - } - - if (!c->attr.pdt_len) - continue; - else - { - gfc_se tse; - gfc_expr *c_expr = NULL; - gfc_actual_arglist *param = pdt_param_list; - - gfc_init_se (&tse, NULL); - for (; param; param = param->next) - if (!strcmp (c->name, param->name) - && param->spec_type == SPEC_EXPLICIT) - c_expr = param->expr; - - if (c_expr) - { - tree error, cond, cname; - gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp)); - cond = fold_build2_loc (input_location, NE_EXPR, - logical_type_node, - comp, tse.expr); - cname = gfc_build_cstring_const (c->name); - cname = gfc_build_addr_expr (pchar_type_node, cname); - error = gfc_trans_runtime_error (true, NULL, - "The value of the PDT LEN " - "parameter '%s' does not " - "agree with that in the " - "dummy declaration", - cname); - tmp = fold_build3_loc (input_location, COND_EXPR, - void_type_node, cond, error, - build_empty_stmt (input_location)); - gfc_add_expr_to_block (&fnblock, tmp); - } - } - break; - - default: - gcc_unreachable (); - break; - } - } - - return gfc_finish_block (&fnblock); -} - -/* Recursively traverse an object of derived type, generating code to - nullify allocatable components. */ - -tree -gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank, - int caf_mode) -{ - return structure_alloc_comps (der_type, decl, NULL_TREE, rank, - NULLIFY_ALLOC_COMP, - GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode, NULL); -} - - -/* Recursively traverse an object of derived type, generating code to - deallocate allocatable components. */ - -tree -gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank, - int caf_mode) -{ - return structure_alloc_comps (der_type, decl, NULL_TREE, rank, - DEALLOCATE_ALLOC_COMP, - GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode, NULL); -} - -tree -gfc_bcast_alloc_comp (gfc_symbol *derived, gfc_expr *expr, int rank, - tree image_index, tree stat, tree errmsg, - tree errmsg_len) -{ - tree tmp, array; - gfc_se argse; - stmtblock_t block, post_block; - gfc_co_subroutines_args args; - - args.image_index = image_index; - args.stat = stat; - args.errmsg = errmsg; - args.errmsg_len = errmsg_len; - - if (rank == 0) - { - gfc_start_block (&block); - gfc_init_block (&post_block); - gfc_init_se (&argse, NULL); - gfc_conv_expr (&argse, expr); - gfc_add_block_to_block (&block, &argse.pre); - gfc_add_block_to_block (&post_block, &argse.post); - array = argse.expr; - } - else - { - gfc_init_se (&argse, NULL); - argse.want_pointer = 1; - gfc_conv_expr_descriptor (&argse, expr); - array = argse.expr; - } - - tmp = structure_alloc_comps (derived, array, NULL_TREE, rank, - BCAST_ALLOC_COMP, - GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY, &args); - return tmp; -} - -/* Recursively traverse an object of derived type, generating code to - deallocate allocatable components. But do not deallocate coarrays. - To be used for intrinsic assignment, which may not change the allocation - status of coarrays. */ - -tree -gfc_deallocate_alloc_comp_no_caf (gfc_symbol * der_type, tree decl, int rank) -{ - return structure_alloc_comps (der_type, decl, NULL_TREE, rank, - DEALLOCATE_ALLOC_COMP, 0, NULL); -} - - -tree -gfc_reassign_alloc_comp_caf (gfc_symbol *der_type, tree decl, tree dest) -{ - return structure_alloc_comps (der_type, decl, dest, 0, REASSIGN_CAF_COMP, - GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY, NULL); -} - - -/* Recursively traverse an object of derived type, generating code to - copy it and its allocatable components. */ - -tree -gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank, - int caf_mode) -{ - return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP, - caf_mode, NULL); -} - - -/* Recursively traverse an object of derived type, generating code to - copy only its allocatable components. */ - -tree -gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank) -{ - return structure_alloc_comps (der_type, decl, dest, rank, - COPY_ONLY_ALLOC_COMP, 0, NULL); -} - - -/* Recursively traverse an object of parameterized derived type, generating - code to allocate parameterized components. */ - -tree -gfc_allocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank, - gfc_actual_arglist *param_list) -{ - tree res; - gfc_actual_arglist *old_param_list = pdt_param_list; - pdt_param_list = param_list; - res = structure_alloc_comps (der_type, decl, NULL_TREE, rank, - ALLOCATE_PDT_COMP, 0, NULL); - pdt_param_list = old_param_list; - return res; -} - -/* Recursively traverse an object of parameterized derived type, generating - code to deallocate parameterized components. */ - -tree -gfc_deallocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank) -{ - return structure_alloc_comps (der_type, decl, NULL_TREE, rank, - DEALLOCATE_PDT_COMP, 0, NULL); -} - - -/* Recursively traverse a dummy of parameterized derived type to check the - values of LEN parameters. */ - -tree -gfc_check_pdt_dummy (gfc_symbol * der_type, tree decl, int rank, - gfc_actual_arglist *param_list) -{ - tree res; - gfc_actual_arglist *old_param_list = pdt_param_list; - pdt_param_list = param_list; - res = structure_alloc_comps (der_type, decl, NULL_TREE, rank, - CHECK_PDT_DUMMY, 0, NULL); - pdt_param_list = old_param_list; - return res; -} - - -/* Returns the value of LBOUND for an expression. This could be broken out - from gfc_conv_intrinsic_bound but this seemed to be simpler. This is - called by gfc_alloc_allocatable_for_assignment. */ -static tree -get_std_lbound (gfc_expr *expr, tree desc, int dim, bool assumed_size) -{ - tree lbound; - tree ubound; - tree stride; - tree cond, cond1, cond3, cond4; - tree tmp; - gfc_ref *ref; - - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))) - { - tmp = gfc_rank_cst[dim]; - lbound = gfc_conv_descriptor_lbound_get (desc, tmp); - ubound = gfc_conv_descriptor_ubound_get (desc, tmp); - stride = gfc_conv_descriptor_stride_get (desc, tmp); - cond1 = fold_build2_loc (input_location, GE_EXPR, logical_type_node, - ubound, lbound); - cond3 = fold_build2_loc (input_location, GE_EXPR, logical_type_node, - stride, gfc_index_zero_node); - cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR, - logical_type_node, cond3, cond1); - cond4 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, - stride, gfc_index_zero_node); - if (assumed_size) - cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, - tmp, build_int_cst (gfc_array_index_type, - expr->rank - 1)); - else - cond = logical_false_node; - - cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR, - logical_type_node, cond3, cond4); - cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, - logical_type_node, cond, cond1); - - return fold_build3_loc (input_location, COND_EXPR, - gfc_array_index_type, cond, - lbound, gfc_index_one_node); - } - - if (expr->expr_type == EXPR_FUNCTION) - { - /* A conversion function, so use the argument. */ - gcc_assert (expr->value.function.isym - && expr->value.function.isym->conversion); - expr = expr->value.function.actual->expr; - } - - if (expr->expr_type == EXPR_VARIABLE) - { - tmp = TREE_TYPE (expr->symtree->n.sym->backend_decl); - for (ref = expr->ref; ref; ref = ref->next) - { - if (ref->type == REF_COMPONENT - && ref->u.c.component->as - && ref->next - && ref->next->u.ar.type == AR_FULL) - tmp = TREE_TYPE (ref->u.c.component->backend_decl); - } - return GFC_TYPE_ARRAY_LBOUND(tmp, dim); - } - - return gfc_index_one_node; -} - - -/* Returns true if an expression represents an lhs that can be reallocated - on assignment. */ - -bool -gfc_is_reallocatable_lhs (gfc_expr *expr) -{ - gfc_ref * ref; - gfc_symbol *sym; - - if (!expr->ref) - return false; - - sym = expr->symtree->n.sym; - - if (sym->attr.associate_var && !expr->ref) - return false; - - /* An allocatable class variable with no reference. */ - if (sym->ts.type == BT_CLASS - && !sym->attr.associate_var - && CLASS_DATA (sym)->attr.allocatable - && expr->ref - && ((expr->ref->type == REF_ARRAY && expr->ref->u.ar.type == AR_FULL - && expr->ref->next == NULL) - || (expr->ref->type == REF_COMPONENT - && strcmp (expr->ref->u.c.component->name, "_data") == 0 - && (expr->ref->next == NULL - || (expr->ref->next->type == REF_ARRAY - && expr->ref->next->u.ar.type == AR_FULL - && expr->ref->next->next == NULL))))) - return true; - - /* An allocatable variable. */ - if (sym->attr.allocatable - && !sym->attr.associate_var - && expr->ref - && expr->ref->type == REF_ARRAY - && expr->ref->u.ar.type == AR_FULL) - return true; - - /* All that can be left are allocatable components. */ - if ((sym->ts.type != BT_DERIVED - && sym->ts.type != BT_CLASS) - || !sym->ts.u.derived->attr.alloc_comp) - return false; - - /* Find a component ref followed by an array reference. */ - for (ref = expr->ref; ref; ref = ref->next) - if (ref->next - && ref->type == REF_COMPONENT - && ref->next->type == REF_ARRAY - && !ref->next->next) - break; - - if (!ref) - return false; - - /* Return true if valid reallocatable lhs. */ - if (ref->u.c.component->attr.allocatable - && ref->next->u.ar.type == AR_FULL) - return true; - - return false; -} - - -static tree -concat_str_length (gfc_expr* expr) -{ - tree type; - tree len1; - tree len2; - gfc_se se; - - type = gfc_typenode_for_spec (&expr->value.op.op1->ts); - len1 = TYPE_MAX_VALUE (TYPE_DOMAIN (type)); - if (len1 == NULL_TREE) - { - if (expr->value.op.op1->expr_type == EXPR_OP) - len1 = concat_str_length (expr->value.op.op1); - else if (expr->value.op.op1->expr_type == EXPR_CONSTANT) - len1 = build_int_cst (gfc_charlen_type_node, - expr->value.op.op1->value.character.length); - else if (expr->value.op.op1->ts.u.cl->length) - { - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, expr->value.op.op1->ts.u.cl->length); - len1 = se.expr; - } - else - { - /* Last resort! */ - gfc_init_se (&se, NULL); - se.want_pointer = 1; - se.descriptor_only = 1; - gfc_conv_expr (&se, expr->value.op.op1); - len1 = se.string_length; - } - } - - type = gfc_typenode_for_spec (&expr->value.op.op2->ts); - len2 = TYPE_MAX_VALUE (TYPE_DOMAIN (type)); - if (len2 == NULL_TREE) - { - if (expr->value.op.op2->expr_type == EXPR_OP) - len2 = concat_str_length (expr->value.op.op2); - else if (expr->value.op.op2->expr_type == EXPR_CONSTANT) - len2 = build_int_cst (gfc_charlen_type_node, - expr->value.op.op2->value.character.length); - else if (expr->value.op.op2->ts.u.cl->length) - { - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, expr->value.op.op2->ts.u.cl->length); - len2 = se.expr; - } - else - { - /* Last resort! */ - gfc_init_se (&se, NULL); - se.want_pointer = 1; - se.descriptor_only = 1; - gfc_conv_expr (&se, expr->value.op.op2); - len2 = se.string_length; - } - } - - gcc_assert(len1 && len2); - len1 = fold_convert (gfc_charlen_type_node, len1); - len2 = fold_convert (gfc_charlen_type_node, len2); - - return fold_build2_loc (input_location, PLUS_EXPR, - gfc_charlen_type_node, len1, len2); -} - - -/* Allocate the lhs of an assignment to an allocatable array, otherwise - reallocate it. */ - -tree -gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, - gfc_expr *expr1, - gfc_expr *expr2) -{ - stmtblock_t realloc_block; - stmtblock_t alloc_block; - stmtblock_t fblock; - gfc_ss *rss; - gfc_ss *lss; - gfc_array_info *linfo; - tree realloc_expr; - tree alloc_expr; - tree size1; - tree size2; - tree elemsize1; - tree elemsize2; - tree array1; - tree cond_null; - tree cond; - tree tmp; - tree tmp2; - tree lbound; - tree ubound; - tree desc; - tree old_desc; - tree desc2; - tree offset; - tree jump_label1; - tree jump_label2; - tree neq_size; - tree lbd; - tree class_expr2 = NULL_TREE; - int n; - int dim; - gfc_array_spec * as; - bool coarray = (flag_coarray == GFC_FCOARRAY_LIB - && gfc_caf_attr (expr1, true).codimension); - tree token; - gfc_se caf_se; - - /* x = f(...) with x allocatable. In this case, expr1 is the rhs. - Find the lhs expression in the loop chain and set expr1 and - expr2 accordingly. */ - if (expr1->expr_type == EXPR_FUNCTION && expr2 == NULL) - { - expr2 = expr1; - /* Find the ss for the lhs. */ - lss = loop->ss; - for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain) - if (lss->info->expr && lss->info->expr->expr_type == EXPR_VARIABLE) - break; - if (lss == gfc_ss_terminator) - return NULL_TREE; - expr1 = lss->info->expr; - } - - /* Bail out if this is not a valid allocate on assignment. */ - if (!gfc_is_reallocatable_lhs (expr1) - || (expr2 && !expr2->rank)) - return NULL_TREE; - - /* Find the ss for the lhs. */ - lss = loop->ss; - for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain) - if (lss->info->expr == expr1) - break; - - if (lss == gfc_ss_terminator) - return NULL_TREE; - - linfo = &lss->info->data.array; - - /* Find an ss for the rhs. For operator expressions, we see the - ss's for the operands. Any one of these will do. */ - rss = loop->ss; - for (; rss && rss != gfc_ss_terminator; rss = rss->loop_chain) - if (rss->info->expr != expr1 && rss != loop->temp_ss) - break; - - if (expr2 && rss == gfc_ss_terminator) - return NULL_TREE; - - /* Ensure that the string length from the current scope is used. */ - if (expr2->ts.type == BT_CHARACTER - && expr2->expr_type == EXPR_FUNCTION - && !expr2->value.function.isym) - expr2->ts.u.cl->backend_decl = rss->info->string_length; - - gfc_start_block (&fblock); - - /* Since the lhs is allocatable, this must be a descriptor type. - Get the data and array size. */ - desc = linfo->descriptor; - gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))); - array1 = gfc_conv_descriptor_data_get (desc); - - if (expr2) - desc2 = rss->info->data.array.descriptor; - else - desc2 = NULL_TREE; - - /* Get the old lhs element size for deferred character and class expr1. */ - if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred) - { - if (expr1->ts.u.cl->backend_decl - && VAR_P (expr1->ts.u.cl->backend_decl)) - elemsize1 = expr1->ts.u.cl->backend_decl; - else - elemsize1 = lss->info->string_length; - } - else if (expr1->ts.type == BT_CLASS) - { - /* Unfortunately, the lhs vptr is set too early in many cases. - Play it safe by using the descriptor element length. */ - tmp = gfc_conv_descriptor_elem_len (desc); - elemsize1 = fold_convert (gfc_array_index_type, tmp); - } - else - elemsize1 = NULL_TREE; - if (elemsize1 != NULL_TREE) - elemsize1 = gfc_evaluate_now (elemsize1, &fblock); - - /* Get the new lhs size in bytes. */ - if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred) - { - if (expr2->ts.deferred) - { - if (expr2->ts.u.cl->backend_decl - && VAR_P (expr2->ts.u.cl->backend_decl)) - tmp = expr2->ts.u.cl->backend_decl; - else - tmp = rss->info->string_length; - } - else - { - tmp = expr2->ts.u.cl->backend_decl; - if (!tmp && expr2->expr_type == EXPR_OP - && expr2->value.op.op == INTRINSIC_CONCAT) - { - tmp = concat_str_length (expr2); - expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock); - } - else if (!tmp && expr2->ts.u.cl->length) - { - gfc_se tmpse; - gfc_init_se (&tmpse, NULL); - gfc_conv_expr_type (&tmpse, expr2->ts.u.cl->length, - gfc_charlen_type_node); - tmp = tmpse.expr; - expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock); - } - tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp); - } - - if (expr1->ts.u.cl->backend_decl - && VAR_P (expr1->ts.u.cl->backend_decl)) - gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp); - else - gfc_add_modify (&fblock, lss->info->string_length, tmp); - - if (expr1->ts.kind > 1) - tmp = fold_build2_loc (input_location, MULT_EXPR, - TREE_TYPE (tmp), - tmp, build_int_cst (TREE_TYPE (tmp), - expr1->ts.kind)); - } - else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl) - { - tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts))); - tmp = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, tmp, - expr1->ts.u.cl->backend_decl); - } - else if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS) - tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts)); - else if (expr1->ts.type == BT_CLASS && expr2->ts.type == BT_CLASS) - { - tmp = expr2->rank ? gfc_get_class_from_expr (desc2) : NULL_TREE; - if (tmp == NULL_TREE && expr2->expr_type == EXPR_VARIABLE) - tmp = class_expr2 = gfc_get_class_from_gfc_expr (expr2); - - if (tmp != NULL_TREE) - tmp = gfc_class_vtab_size_get (tmp); - else - tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&CLASS_DATA (expr2)->ts)); - } - else - tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts)); - elemsize2 = fold_convert (gfc_array_index_type, tmp); - elemsize2 = gfc_evaluate_now (elemsize2, &fblock); - - /* 7.4.1.3 "If variable is an allocated allocatable variable, it is - deallocated if expr is an array of different shape or any of the - corresponding length type parameter values of variable and expr - differ." This assures F95 compatibility. */ - jump_label1 = gfc_build_label_decl (NULL_TREE); - jump_label2 = gfc_build_label_decl (NULL_TREE); - - /* Allocate if data is NULL. */ - cond_null = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, - array1, build_int_cst (TREE_TYPE (array1), 0)); - - if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred) - { - tmp = fold_build2_loc (input_location, NE_EXPR, - logical_type_node, - lss->info->string_length, - rss->info->string_length); - cond_null = fold_build2_loc (input_location, TRUTH_OR_EXPR, - logical_type_node, tmp, cond_null); - cond_null= gfc_evaluate_now (cond_null, &fblock); - } - else - cond_null= gfc_evaluate_now (cond_null, &fblock); - - tmp = build3_v (COND_EXPR, cond_null, - build1_v (GOTO_EXPR, jump_label1), - build_empty_stmt (input_location)); - gfc_add_expr_to_block (&fblock, tmp); - - /* Get arrayspec if expr is a full array. */ - if (expr2 && expr2->expr_type == EXPR_FUNCTION - && expr2->value.function.isym - && expr2->value.function.isym->conversion) - { - /* For conversion functions, take the arg. */ - gfc_expr *arg = expr2->value.function.actual->expr; - as = gfc_get_full_arrayspec_from_expr (arg); - } - else if (expr2) - as = gfc_get_full_arrayspec_from_expr (expr2); - else - as = NULL; - - /* If the lhs shape is not the same as the rhs jump to setting the - bounds and doing the reallocation....... */ - for (n = 0; n < expr1->rank; n++) - { - /* Check the shape. */ - lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]); - ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]); - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - loop->to[n], loop->from[n]); - tmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, - tmp, lbound); - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - tmp, ubound); - cond = fold_build2_loc (input_location, NE_EXPR, - logical_type_node, - tmp, gfc_index_zero_node); - tmp = build3_v (COND_EXPR, cond, - build1_v (GOTO_EXPR, jump_label1), - build_empty_stmt (input_location)); - gfc_add_expr_to_block (&fblock, tmp); - } - - /* ...else if the element lengths are not the same also go to - setting the bounds and doing the reallocation.... */ - if (elemsize1 != NULL_TREE) - { - cond = fold_build2_loc (input_location, NE_EXPR, - logical_type_node, - elemsize1, elemsize2); - tmp = build3_v (COND_EXPR, cond, - build1_v (GOTO_EXPR, jump_label1), - build_empty_stmt (input_location)); - gfc_add_expr_to_block (&fblock, tmp); - } - - /* ....else jump past the (re)alloc code. */ - tmp = build1_v (GOTO_EXPR, jump_label2); - gfc_add_expr_to_block (&fblock, tmp); - - /* Add the label to start automatic (re)allocation. */ - tmp = build1_v (LABEL_EXPR, jump_label1); - gfc_add_expr_to_block (&fblock, tmp); - - /* If the lhs has not been allocated, its bounds will not have been - initialized and so its size is set to zero. */ - size1 = gfc_create_var (gfc_array_index_type, NULL); - gfc_init_block (&alloc_block); - gfc_add_modify (&alloc_block, size1, gfc_index_zero_node); - gfc_init_block (&realloc_block); - gfc_add_modify (&realloc_block, size1, - gfc_conv_descriptor_size (desc, expr1->rank)); - tmp = build3_v (COND_EXPR, cond_null, - gfc_finish_block (&alloc_block), - gfc_finish_block (&realloc_block)); - gfc_add_expr_to_block (&fblock, tmp); - - /* Get the rhs size and fix it. */ - size2 = gfc_index_one_node; - for (n = 0; n < expr2->rank; n++) - { - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - loop->to[n], loop->from[n]); - tmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, - tmp, gfc_index_one_node); - size2 = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, - tmp, size2); - } - size2 = gfc_evaluate_now (size2, &fblock); - - cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - size1, size2); - - /* If the lhs is deferred length, assume that the element size - changes and force a reallocation. */ - if (expr1->ts.deferred) - neq_size = gfc_evaluate_now (logical_true_node, &fblock); - else - neq_size = gfc_evaluate_now (cond, &fblock); - - /* Deallocation of allocatable components will have to occur on - reallocation. Fix the old descriptor now. */ - if ((expr1->ts.type == BT_DERIVED) - && expr1->ts.u.derived->attr.alloc_comp) - old_desc = gfc_evaluate_now (desc, &fblock); - else - old_desc = NULL_TREE; - - /* Now modify the lhs descriptor and the associated scalarizer - variables. F2003 7.4.1.3: "If variable is or becomes an - unallocated allocatable variable, then it is allocated with each - deferred type parameter equal to the corresponding type parameters - of expr , with the shape of expr , and with each lower bound equal - to the corresponding element of LBOUND(expr)." - Reuse size1 to keep a dimension-by-dimension track of the - stride of the new array. */ - size1 = gfc_index_one_node; - offset = gfc_index_zero_node; - - for (n = 0; n < expr2->rank; n++) - { - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - loop->to[n], loop->from[n]); - tmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, - tmp, gfc_index_one_node); - - lbound = gfc_index_one_node; - ubound = tmp; - - if (as) - { - lbd = get_std_lbound (expr2, desc2, n, - as->type == AS_ASSUMED_SIZE); - ubound = fold_build2_loc (input_location, - MINUS_EXPR, - gfc_array_index_type, - ubound, lbound); - ubound = fold_build2_loc (input_location, - PLUS_EXPR, - gfc_array_index_type, - ubound, lbd); - lbound = lbd; - } - - gfc_conv_descriptor_lbound_set (&fblock, desc, - gfc_rank_cst[n], - lbound); - gfc_conv_descriptor_ubound_set (&fblock, desc, - gfc_rank_cst[n], - ubound); - gfc_conv_descriptor_stride_set (&fblock, desc, - gfc_rank_cst[n], - size1); - lbound = gfc_conv_descriptor_lbound_get (desc, - gfc_rank_cst[n]); - tmp2 = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, - lbound, size1); - offset = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - offset, tmp2); - size1 = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, - tmp, size1); - } - - /* Set the lhs descriptor and scalarizer offsets. For rank > 1, - the array offset is saved and the info.offset is used for a - running offset. Use the saved_offset instead. */ - tmp = gfc_conv_descriptor_offset (desc); - gfc_add_modify (&fblock, tmp, offset); - if (linfo->saved_offset - && VAR_P (linfo->saved_offset)) - gfc_add_modify (&fblock, linfo->saved_offset, tmp); - - /* Now set the deltas for the lhs. */ - for (n = 0; n < expr1->rank; n++) - { - tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]); - dim = lss->dim[n]; - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, tmp, - loop->from[dim]); - if (linfo->delta[dim] && VAR_P (linfo->delta[dim])) - gfc_add_modify (&fblock, linfo->delta[dim], tmp); - } - - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))) - gfc_conv_descriptor_span_set (&fblock, desc, elemsize2); - - size2 = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, - elemsize2, size2); - size2 = fold_convert (size_type_node, size2); - size2 = fold_build2_loc (input_location, MAX_EXPR, size_type_node, - size2, size_one_node); - size2 = gfc_evaluate_now (size2, &fblock); - - /* For deferred character length, the 'size' field of the dtype might - have changed so set the dtype. */ - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)) - && expr1->ts.type == BT_CHARACTER && expr1->ts.deferred) - { - tree type; - tmp = gfc_conv_descriptor_dtype (desc); - if (expr2->ts.u.cl->backend_decl) - type = gfc_typenode_for_spec (&expr2->ts); - else - type = gfc_typenode_for_spec (&expr1->ts); - - gfc_add_modify (&fblock, tmp, - gfc_get_dtype_rank_type (expr1->rank,type)); - } - else if (expr1->ts.type == BT_CLASS) - { - tree type; - tmp = gfc_conv_descriptor_dtype (desc); - - if (expr2->ts.type != BT_CLASS) - type = gfc_typenode_for_spec (&expr2->ts); - else - type = gfc_get_character_type_len (1, elemsize2); - - gfc_add_modify (&fblock, tmp, - gfc_get_dtype_rank_type (expr2->rank,type)); - /* Set the _len field as well... */ - if (UNLIMITED_POLY (expr1)) - { - tmp = gfc_class_len_get (TREE_OPERAND (desc, 0)); - if (expr2->ts.type == BT_CHARACTER) - gfc_add_modify (&fblock, tmp, - fold_convert (TREE_TYPE (tmp), - TYPE_SIZE_UNIT (type))); - else - gfc_add_modify (&fblock, tmp, - build_int_cst (TREE_TYPE (tmp), 0)); - } - /* ...and the vptr. */ - tmp = gfc_class_vptr_get (TREE_OPERAND (desc, 0)); - if (expr2->ts.type == BT_CLASS && !VAR_P (desc2) - && TREE_CODE (desc2) == COMPONENT_REF) - { - tmp2 = gfc_get_class_from_expr (desc2); - tmp2 = gfc_class_vptr_get (tmp2); - } - else if (expr2->ts.type == BT_CLASS && class_expr2 != NULL_TREE) - tmp2 = gfc_class_vptr_get (class_expr2); - else - { - tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts)); - tmp2 = gfc_build_addr_expr (TREE_TYPE (tmp), tmp2); - } - - gfc_add_modify (&fblock, tmp, fold_convert (TREE_TYPE (tmp), tmp2)); - } - else if (coarray && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))) - { - gfc_add_modify (&fblock, gfc_conv_descriptor_dtype (desc), - gfc_get_dtype (TREE_TYPE (desc))); - } - - /* Realloc expression. Note that the scalarizer uses desc.data - in the array reference - (*desc.data)[]. */ - gfc_init_block (&realloc_block); - gfc_init_se (&caf_se, NULL); - - if (coarray) - { - token = gfc_get_ultimate_alloc_ptr_comps_caf_token (&caf_se, expr1); - if (token == NULL_TREE) - { - tmp = gfc_get_tree_for_caf_expr (expr1); - if (POINTER_TYPE_P (TREE_TYPE (tmp))) - tmp = build_fold_indirect_ref (tmp); - gfc_get_caf_token_offset (&caf_se, &token, NULL, tmp, NULL_TREE, - expr1); - token = gfc_build_addr_expr (NULL_TREE, token); - } - - gfc_add_block_to_block (&realloc_block, &caf_se.pre); - } - if ((expr1->ts.type == BT_DERIVED) - && expr1->ts.u.derived->attr.alloc_comp) - { - tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, old_desc, - expr1->rank); - gfc_add_expr_to_block (&realloc_block, tmp); - } - - if (!coarray) - { - tmp = build_call_expr_loc (input_location, - builtin_decl_explicit (BUILT_IN_REALLOC), 2, - fold_convert (pvoid_type_node, array1), - size2); - gfc_conv_descriptor_data_set (&realloc_block, - desc, tmp); - } - else - { - tmp = build_call_expr_loc (input_location, - gfor_fndecl_caf_deregister, 5, token, - build_int_cst (integer_type_node, - GFC_CAF_COARRAY_DEALLOCATE_ONLY), - null_pointer_node, null_pointer_node, - integer_zero_node); - gfc_add_expr_to_block (&realloc_block, tmp); - tmp = build_call_expr_loc (input_location, - gfor_fndecl_caf_register, - 7, size2, - build_int_cst (integer_type_node, - GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY), - token, gfc_build_addr_expr (NULL_TREE, desc), - null_pointer_node, null_pointer_node, - integer_zero_node); - gfc_add_expr_to_block (&realloc_block, tmp); - } - - if ((expr1->ts.type == BT_DERIVED) - && expr1->ts.u.derived->attr.alloc_comp) - { - tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc, - expr1->rank); - gfc_add_expr_to_block (&realloc_block, tmp); - } - - gfc_add_block_to_block (&realloc_block, &caf_se.post); - realloc_expr = gfc_finish_block (&realloc_block); - - /* Reallocate if sizes or dynamic types are different. */ - if (elemsize1) - { - tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - elemsize1, elemsize2); - tmp = gfc_evaluate_now (tmp, &fblock); - neq_size = fold_build2_loc (input_location, TRUTH_OR_EXPR, - logical_type_node, neq_size, tmp); - } - tmp = build3_v (COND_EXPR, neq_size, realloc_expr, - build_empty_stmt (input_location)); - - realloc_expr = tmp; - - /* Malloc expression. */ - gfc_init_block (&alloc_block); - if (!coarray) - { - tmp = build_call_expr_loc (input_location, - builtin_decl_explicit (BUILT_IN_MALLOC), - 1, size2); - gfc_conv_descriptor_data_set (&alloc_block, - desc, tmp); - } - else - { - tmp = build_call_expr_loc (input_location, - gfor_fndecl_caf_register, - 7, size2, - build_int_cst (integer_type_node, - GFC_CAF_COARRAY_ALLOC), - token, gfc_build_addr_expr (NULL_TREE, desc), - null_pointer_node, null_pointer_node, - integer_zero_node); - gfc_add_expr_to_block (&alloc_block, tmp); - } - - - /* We already set the dtype in the case of deferred character - length arrays and class lvalues. */ - if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)) - && ((expr1->ts.type == BT_CHARACTER && expr1->ts.deferred) - || coarray)) - && expr1->ts.type != BT_CLASS) - { - tmp = gfc_conv_descriptor_dtype (desc); - gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc))); - } - - if ((expr1->ts.type == BT_DERIVED) - && expr1->ts.u.derived->attr.alloc_comp) - { - tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc, - expr1->rank); - gfc_add_expr_to_block (&alloc_block, tmp); - } - alloc_expr = gfc_finish_block (&alloc_block); - - /* Malloc if not allocated; realloc otherwise. */ - tmp = build3_v (COND_EXPR, cond_null, alloc_expr, realloc_expr); - gfc_add_expr_to_block (&fblock, tmp); - - /* Make sure that the scalarizer data pointer is updated. */ - if (linfo->data && VAR_P (linfo->data)) - { - tmp = gfc_conv_descriptor_data_get (desc); - gfc_add_modify (&fblock, linfo->data, tmp); - } - - /* Add the label for same shape lhs and rhs. */ - tmp = build1_v (LABEL_EXPR, jump_label2); - gfc_add_expr_to_block (&fblock, tmp); - - return gfc_finish_block (&fblock); -} - - -/* NULLIFY an allocatable/pointer array on function entry, free it on exit. - Do likewise, recursively if necessary, with the allocatable components of - derived types. This function is also called for assumed-rank arrays, which - are always dummy arguments. */ - -void -gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block) -{ - tree type; - tree tmp; - tree descriptor; - stmtblock_t init; - stmtblock_t cleanup; - locus loc; - int rank; - bool sym_has_alloc_comp, has_finalizer; - - sym_has_alloc_comp = (sym->ts.type == BT_DERIVED - || sym->ts.type == BT_CLASS) - && sym->ts.u.derived->attr.alloc_comp; - has_finalizer = sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED - ? gfc_is_finalizable (sym->ts.u.derived, NULL) : false; - - /* Make sure the frontend gets these right. */ - gcc_assert (sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp - || has_finalizer - || (sym->as->type == AS_ASSUMED_RANK && sym->attr.dummy)); - - gfc_save_backend_locus (&loc); - gfc_set_backend_locus (&sym->declared_at); - gfc_init_block (&init); - - gcc_assert (VAR_P (sym->backend_decl) - || TREE_CODE (sym->backend_decl) == PARM_DECL); - - if (sym->ts.type == BT_CHARACTER - && !INTEGER_CST_P (sym->ts.u.cl->backend_decl)) - { - gfc_conv_string_length (sym->ts.u.cl, NULL, &init); - gfc_trans_vla_type_sizes (sym, &init); - } - - /* Dummy, use associated and result variables don't need anything special. */ - if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result) - { - gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); - gfc_restore_backend_locus (&loc); - return; - } - - descriptor = sym->backend_decl; - - /* Although static, derived types with default initializers and - allocatable components must not be nulled wholesale; instead they - are treated component by component. */ - if (TREE_STATIC (descriptor) && !sym_has_alloc_comp && !has_finalizer) - { - /* SAVEd variables are not freed on exit. */ - gfc_trans_static_array_pointer (sym); - - gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); - gfc_restore_backend_locus (&loc); - return; - } - - /* Get the descriptor type. */ - type = TREE_TYPE (sym->backend_decl); - - if ((sym_has_alloc_comp || (has_finalizer && sym->ts.type != BT_CLASS)) - && !(sym->attr.pointer || sym->attr.allocatable)) - { - if (!sym->attr.save - && !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program)) - { - if (sym->value == NULL - || !gfc_has_default_initializer (sym->ts.u.derived)) - { - rank = sym->as ? sym->as->rank : 0; - tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, - descriptor, rank); - gfc_add_expr_to_block (&init, tmp); - } - else - gfc_init_default_dt (sym, &init, false); - } - } - else if (!GFC_DESCRIPTOR_TYPE_P (type)) - { - /* If the backend_decl is not a descriptor, we must have a pointer - to one. */ - descriptor = build_fold_indirect_ref_loc (input_location, - sym->backend_decl); - type = TREE_TYPE (descriptor); - } - - /* NULLIFY the data pointer, for non-saved allocatables. */ - if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save && sym->attr.allocatable) - { - gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node); - if (flag_coarray == GFC_FCOARRAY_LIB && sym->attr.codimension) - { - /* Declare the variable static so its array descriptor stays present - after leaving the scope. It may still be accessed through another - image. This may happen, for example, with the caf_mpi - implementation. */ - TREE_STATIC (descriptor) = 1; - tmp = gfc_conv_descriptor_token (descriptor); - gfc_add_modify (&init, tmp, fold_convert (TREE_TYPE (tmp), - null_pointer_node)); - } - } - - /* Set initial TKR for pointers and allocatables */ - if (GFC_DESCRIPTOR_TYPE_P (type) - && (sym->attr.pointer || sym->attr.allocatable)) - { - tree etype; - - gcc_assert (sym->as && sym->as->rank>=0); - tmp = gfc_conv_descriptor_dtype (descriptor); - etype = gfc_get_element_type (type); - tmp = fold_build2_loc (input_location, MODIFY_EXPR, - TREE_TYPE (tmp), tmp, - gfc_get_dtype_rank_type (sym->as->rank, etype)); - gfc_add_expr_to_block (&init, tmp); - } - gfc_restore_backend_locus (&loc); - gfc_init_block (&cleanup); - - /* Allocatable arrays need to be freed when they go out of scope. - The allocatable components of pointers must not be touched. */ - if (!sym->attr.allocatable && has_finalizer && sym->ts.type != BT_CLASS - && !sym->attr.pointer && !sym->attr.artificial && !sym->attr.save - && !sym->ns->proc_name->attr.is_main_program) - { - gfc_expr *e; - sym->attr.referenced = 1; - e = gfc_lval_expr_from_sym (sym); - gfc_add_finalizer_call (&cleanup, e); - gfc_free_expr (e); - } - else if ((!sym->attr.allocatable || !has_finalizer) - && sym_has_alloc_comp && !(sym->attr.function || sym->attr.result) - && !sym->attr.pointer && !sym->attr.save - && !sym->ns->proc_name->attr.is_main_program) - { - int rank; - rank = sym->as ? sym->as->rank : 0; - tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank); - gfc_add_expr_to_block (&cleanup, tmp); - } - - if (sym->attr.allocatable && (sym->attr.dimension || sym->attr.codimension) - && !sym->attr.save && !sym->attr.result - && !sym->ns->proc_name->attr.is_main_program) - { - gfc_expr *e; - e = has_finalizer ? gfc_lval_expr_from_sym (sym) : NULL; - tmp = gfc_deallocate_with_status (sym->backend_decl, NULL_TREE, NULL_TREE, - NULL_TREE, NULL_TREE, true, e, - sym->attr.codimension - ? GFC_CAF_COARRAY_DEREGISTER - : GFC_CAF_COARRAY_NOCOARRAY); - if (e) - gfc_free_expr (e); - gfc_add_expr_to_block (&cleanup, tmp); - } - - gfc_add_init_cleanup (block, gfc_finish_block (&init), - gfc_finish_block (&cleanup)); -} - -/************ Expression Walking Functions ******************/ - -/* Walk a variable reference. - - Possible extension - multiple component subscripts. - x(:,:) = foo%a(:)%b(:) - Transforms to - forall (i=..., j=...) - x(i,j) = foo%a(j)%b(i) - end forall - This adds a fair amount of complexity because you need to deal with more - than one ref. Maybe handle in a similar manner to vector subscripts. - Maybe not worth the effort. */ - - -static gfc_ss * -gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr) -{ - gfc_ref *ref; - - gfc_fix_class_refs (expr); - - for (ref = expr->ref; ref; ref = ref->next) - if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT) - break; - - return gfc_walk_array_ref (ss, expr, ref); -} - - -gfc_ss * -gfc_walk_array_ref (gfc_ss * ss, gfc_expr * expr, gfc_ref * ref) -{ - gfc_array_ref *ar; - gfc_ss *newss; - int n; - - for (; ref; ref = ref->next) - { - if (ref->type == REF_SUBSTRING) - { - ss = gfc_get_scalar_ss (ss, ref->u.ss.start); - if (ref->u.ss.end) - ss = gfc_get_scalar_ss (ss, ref->u.ss.end); - } - - /* We're only interested in array sections from now on. */ - if (ref->type != REF_ARRAY) - continue; - - ar = &ref->u.ar; - - switch (ar->type) - { - case AR_ELEMENT: - for (n = ar->dimen - 1; n >= 0; n--) - ss = gfc_get_scalar_ss (ss, ar->start[n]); - break; - - case AR_FULL: - newss = gfc_get_array_ss (ss, expr, ar->as->rank, GFC_SS_SECTION); - newss->info->data.array.ref = ref; - - /* Make sure array is the same as array(:,:), this way - we don't need to special case all the time. */ - ar->dimen = ar->as->rank; - for (n = 0; n < ar->dimen; n++) - { - ar->dimen_type[n] = DIMEN_RANGE; - - gcc_assert (ar->start[n] == NULL); - gcc_assert (ar->end[n] == NULL); - gcc_assert (ar->stride[n] == NULL); - } - ss = newss; - break; - - case AR_SECTION: - newss = gfc_get_array_ss (ss, expr, 0, GFC_SS_SECTION); - newss->info->data.array.ref = ref; - - /* We add SS chains for all the subscripts in the section. */ - for (n = 0; n < ar->dimen; n++) - { - gfc_ss *indexss; - - switch (ar->dimen_type[n]) - { - case DIMEN_ELEMENT: - /* Add SS for elemental (scalar) subscripts. */ - gcc_assert (ar->start[n]); - indexss = gfc_get_scalar_ss (gfc_ss_terminator, ar->start[n]); - indexss->loop_chain = gfc_ss_terminator; - newss->info->data.array.subscript[n] = indexss; - break; - - case DIMEN_RANGE: - /* We don't add anything for sections, just remember this - dimension for later. */ - newss->dim[newss->dimen] = n; - newss->dimen++; - break; - - case DIMEN_VECTOR: - /* Create a GFC_SS_VECTOR index in which we can store - the vector's descriptor. */ - indexss = gfc_get_array_ss (gfc_ss_terminator, ar->start[n], - 1, GFC_SS_VECTOR); - indexss->loop_chain = gfc_ss_terminator; - newss->info->data.array.subscript[n] = indexss; - newss->dim[newss->dimen] = n; - newss->dimen++; - break; - - default: - /* We should know what sort of section it is by now. */ - gcc_unreachable (); - } - } - /* We should have at least one non-elemental dimension, - unless we are creating a descriptor for a (scalar) coarray. */ - gcc_assert (newss->dimen > 0 - || newss->info->data.array.ref->u.ar.as->corank > 0); - ss = newss; - break; - - default: - /* We should know what sort of section it is by now. */ - gcc_unreachable (); - } - - } - return ss; -} - - -/* Walk an expression operator. If only one operand of a binary expression is - scalar, we must also add the scalar term to the SS chain. */ - -static gfc_ss * -gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr) -{ - gfc_ss *head; - gfc_ss *head2; - - head = gfc_walk_subexpr (ss, expr->value.op.op1); - if (expr->value.op.op2 == NULL) - head2 = head; - else - head2 = gfc_walk_subexpr (head, expr->value.op.op2); - - /* All operands are scalar. Pass back and let the caller deal with it. */ - if (head2 == ss) - return head2; - - /* All operands require scalarization. */ - if (head != ss && (expr->value.op.op2 == NULL || head2 != head)) - return head2; - - /* One of the operands needs scalarization, the other is scalar. - Create a gfc_ss for the scalar expression. */ - if (head == ss) - { - /* First operand is scalar. We build the chain in reverse order, so - add the scalar SS after the second operand. */ - head = head2; - while (head && head->next != ss) - head = head->next; - /* Check we haven't somehow broken the chain. */ - gcc_assert (head); - head->next = gfc_get_scalar_ss (ss, expr->value.op.op1); - } - else /* head2 == head */ - { - gcc_assert (head2 == head); - /* Second operand is scalar. */ - head2 = gfc_get_scalar_ss (head2, expr->value.op.op2); - } - - return head2; -} - - -/* Reverse a SS chain. */ - -gfc_ss * -gfc_reverse_ss (gfc_ss * ss) -{ - gfc_ss *next; - gfc_ss *head; - - gcc_assert (ss != NULL); - - head = gfc_ss_terminator; - while (ss != gfc_ss_terminator) - { - next = ss->next; - /* Check we didn't somehow break the chain. */ - gcc_assert (next != NULL); - ss->next = head; - head = ss; - ss = next; - } - - return (head); -} - - -/* Given an expression referring to a procedure, return the symbol of its - interface. We can't get the procedure symbol directly as we have to handle - the case of (deferred) type-bound procedures. */ - -gfc_symbol * -gfc_get_proc_ifc_for_expr (gfc_expr *procedure_ref) -{ - gfc_symbol *sym; - gfc_ref *ref; - - if (procedure_ref == NULL) - return NULL; - - /* Normal procedure case. */ - if (procedure_ref->expr_type == EXPR_FUNCTION - && procedure_ref->value.function.esym) - sym = procedure_ref->value.function.esym; - else - sym = procedure_ref->symtree->n.sym; - - /* Typebound procedure case. */ - for (ref = procedure_ref->ref; ref; ref = ref->next) - { - if (ref->type == REF_COMPONENT - && ref->u.c.component->attr.proc_pointer) - sym = ref->u.c.component->ts.interface; - else - sym = NULL; - } - - return sym; -} - - -/* Given an expression referring to an intrinsic function call, - return the intrinsic symbol. */ - -gfc_intrinsic_sym * -gfc_get_intrinsic_for_expr (gfc_expr *call) -{ - if (call == NULL) - return NULL; - - /* Normal procedure case. */ - if (call->expr_type == EXPR_FUNCTION) - return call->value.function.isym; - else - return NULL; -} - - -/* Indicates whether an argument to an intrinsic function should be used in - scalarization. It is usually the case, except for some intrinsics - requiring the value to be constant, and using the value at compile time only. - As the value is not used at runtime in those cases, we don’t produce code - for it, and it should not be visible to the scalarizer. - FUNCTION is the intrinsic function being called, ACTUAL_ARG is the actual - argument being examined in that call, and ARG_NUM the index number - of ACTUAL_ARG in the list of arguments. - The intrinsic procedure’s dummy argument associated with ACTUAL_ARG is - identified using the name in ACTUAL_ARG if it is present (that is: if it’s - a keyword argument), otherwise using ARG_NUM. */ - -static bool -arg_evaluated_for_scalarization (gfc_intrinsic_sym *function, - gfc_dummy_arg *dummy_arg) -{ - if (function != NULL && dummy_arg != NULL) - { - switch (function->id) - { - case GFC_ISYM_INDEX: - case GFC_ISYM_LEN_TRIM: - case GFC_ISYM_MASKL: - case GFC_ISYM_MASKR: - case GFC_ISYM_SCAN: - case GFC_ISYM_VERIFY: - if (strcmp ("kind", gfc_dummy_arg_get_name (*dummy_arg)) == 0) - return false; - /* Fallthrough. */ - - default: - break; - } - } - - return true; -} - - -/* Walk the arguments of an elemental function. - PROC_EXPR is used to check whether an argument is permitted to be absent. If - it is NULL, we don't do the check and the argument is assumed to be present. -*/ - -gfc_ss * -gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg, - gfc_intrinsic_sym *intrinsic_sym, - gfc_ss_type type) -{ - int scalar; - gfc_ss *head; - gfc_ss *tail; - gfc_ss *newss; - - head = gfc_ss_terminator; - tail = NULL; - - scalar = 1; - for (; arg; arg = arg->next) - { - gfc_dummy_arg * const dummy_arg = arg->associated_dummy; - if (!arg->expr - || arg->expr->expr_type == EXPR_NULL - || !arg_evaluated_for_scalarization (intrinsic_sym, dummy_arg)) - continue; - - newss = gfc_walk_subexpr (head, arg->expr); - if (newss == head) - { - /* Scalar argument. */ - gcc_assert (type == GFC_SS_SCALAR || type == GFC_SS_REFERENCE); - newss = gfc_get_scalar_ss (head, arg->expr); - newss->info->type = type; - if (dummy_arg) - newss->info->data.scalar.dummy_arg = dummy_arg; - } - else - scalar = 0; - - if (dummy_arg != NULL - && gfc_dummy_arg_is_optional (*dummy_arg) - && arg->expr->expr_type == EXPR_VARIABLE - && (gfc_expr_attr (arg->expr).optional - || gfc_expr_attr (arg->expr).allocatable - || gfc_expr_attr (arg->expr).pointer)) - newss->info->can_be_null_ref = true; - - head = newss; - if (!tail) - { - tail = head; - while (tail->next != gfc_ss_terminator) - tail = tail->next; - } - } - - if (scalar) - { - /* If all the arguments are scalar we don't need the argument SS. */ - gfc_free_ss_chain (head); - /* Pass it back. */ - return ss; - } - - /* Add it onto the existing chain. */ - tail->next = ss; - return head; -} - - -/* Walk a function call. Scalar functions are passed back, and taken out of - scalarization loops. For elemental functions we walk their arguments. - The result of functions returning arrays is stored in a temporary outside - the loop, so that the function is only called once. Hence we do not need - to walk their arguments. */ - -static gfc_ss * -gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr) -{ - gfc_intrinsic_sym *isym; - gfc_symbol *sym; - gfc_component *comp = NULL; - - isym = expr->value.function.isym; - - /* Handle intrinsic functions separately. */ - if (isym) - return gfc_walk_intrinsic_function (ss, expr, isym); - - sym = expr->value.function.esym; - if (!sym) - sym = expr->symtree->n.sym; - - if (gfc_is_class_array_function (expr)) - return gfc_get_array_ss (ss, expr, - CLASS_DATA (expr->value.function.esym->result)->as->rank, - GFC_SS_FUNCTION); - - /* A function that returns arrays. */ - comp = gfc_get_proc_ptr_comp (expr); - if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension) - || (comp && comp->attr.dimension)) - return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION); - - /* Walk the parameters of an elemental function. For now we always pass - by reference. */ - if (sym->attr.elemental || (comp && comp->attr.elemental)) - { - gfc_ss *old_ss = ss; - - ss = gfc_walk_elemental_function_args (old_ss, - expr->value.function.actual, - gfc_get_intrinsic_for_expr (expr), - GFC_SS_REFERENCE); - if (ss != old_ss - && (comp - || sym->attr.proc_pointer - || sym->attr.if_source != IFSRC_DECL - || sym->attr.array_outer_dependency)) - ss->info->array_outer_dependency = 1; - } - - /* Scalar functions are OK as these are evaluated outside the scalarization - loop. Pass back and let the caller deal with it. */ - return ss; -} - - -/* An array temporary is constructed for array constructors. */ - -static gfc_ss * -gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr) -{ - return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_CONSTRUCTOR); -} - - -/* Walk an expression. Add walked expressions to the head of the SS chain. - A wholly scalar expression will not be added. */ - -gfc_ss * -gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr) -{ - gfc_ss *head; - - switch (expr->expr_type) - { - case EXPR_VARIABLE: - head = gfc_walk_variable_expr (ss, expr); - return head; - - case EXPR_OP: - head = gfc_walk_op_expr (ss, expr); - return head; - - case EXPR_FUNCTION: - head = gfc_walk_function_expr (ss, expr); - return head; - - case EXPR_CONSTANT: - case EXPR_NULL: - case EXPR_STRUCTURE: - /* Pass back and let the caller deal with it. */ - break; - - case EXPR_ARRAY: - head = gfc_walk_array_constructor (ss, expr); - return head; - - case EXPR_SUBSTRING: - /* Pass back and let the caller deal with it. */ - break; - - default: - gfc_internal_error ("bad expression type during walk (%d)", - expr->expr_type); - } - return ss; -} - - -/* Entry point for expression walking. - A return value equal to the passed chain means this is - a scalar expression. It is up to the caller to take whatever action is - necessary to translate these. */ - -gfc_ss * -gfc_walk_expr (gfc_expr * expr) -{ - gfc_ss *res; - - res = gfc_walk_subexpr (gfc_ss_terminator, expr); - return gfc_reverse_ss (res); -} -- cgit v1.1