Bug Summary

File:build/gcc/fortran/trans-array.cc
Warning:line 2983, column 27
The left operand of '!=' is a garbage value

Annotated Source Code

Press '?' to see keyboard shortcuts

clang -cc1 -cc1 -triple x86_64-suse-linux -analyze -disable-free -clear-ast-before-backend -disable-llvm-verifier -discard-value-names -main-file-name trans-array.cc -analyzer-checker=core -analyzer-checker=apiModeling -analyzer-checker=unix -analyzer-checker=deadcode -analyzer-checker=cplusplus -analyzer-checker=security.insecureAPI.UncheckedReturn -analyzer-checker=security.insecureAPI.getpw -analyzer-checker=security.insecureAPI.gets -analyzer-checker=security.insecureAPI.mktemp -analyzer-checker=security.insecureAPI.mkstemp -analyzer-checker=security.insecureAPI.vfork -analyzer-checker=nullability.NullPassedToNonnull -analyzer-checker=nullability.NullReturnedFromNonnull -analyzer-output plist -w -setup-static-analyzer -analyzer-config-compatibility-mode=true -mrelocation-model static -mframe-pointer=none -fmath-errno -ffp-contract=on -fno-rounding-math -mconstructor-aliases -funwind-tables=2 -target-cpu x86-64 -tune-cpu generic -debugger-tuning=gdb -fcoverage-compilation-dir=/buildworker/marxinbox-gcc-clang-static-analyzer/objdir/gcc -resource-dir /usr/lib64/clang/15.0.7 -D IN_GCC_FRONTEND -D IN_GCC -D HAVE_CONFIG_H -I . -I fortran -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../include -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libcpp/include -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libcody -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libdecnumber -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libdecnumber/bid -I ../libdecnumber -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libbacktrace -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/13/../../../../include/c++/13 -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/13/../../../../include/c++/13/x86_64-suse-linux -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/13/../../../../include/c++/13/backward -internal-isystem /usr/lib64/clang/15.0.7/include -internal-isystem /usr/local/include -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/13/../../../../x86_64-suse-linux/include -internal-externc-isystem /include -internal-externc-isystem /usr/include -O2 -Wno-narrowing -Wwrite-strings -Wno-long-long -Wno-variadic-macros -Wno-overlength-strings -fdeprecated-macro -fdebug-compilation-dir=/buildworker/marxinbox-gcc-clang-static-analyzer/objdir/gcc -ferror-limit 19 -fno-rtti -fgnuc-version=4.2.1 -vectorize-loops -vectorize-slp -analyzer-output=plist-html -analyzer-config silence-checkers=core.NullDereference -faddrsig -D__GCC_HAVE_DWARF2_CFI_ASM=1 -o /buildworker/marxinbox-gcc-clang-static-analyzer/objdir/clang-static-analyzer/2023-03-27-141847-20772-1/report-Z2LYPj.plist -x c++ /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc
1/* Array translation routines
2 Copyright (C) 2002-2023 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
5
6This file is part of GCC.
7
8GCC is free software; you can redistribute it and/or modify it under
9the terms of the GNU General Public License as published by the Free
10Software Foundation; either version 3, or (at your option) any later
11version.
12
13GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14WARRANTY; without even the implied warranty of MERCHANTABILITY or
15FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
16for more details.
17
18You should have received a copy of the GNU General Public License
19along with GCC; see the file COPYING3. If not see
20<http://www.gnu.org/licenses/>. */
21
22/* trans-array.cc-- Various array related code, including scalarization,
23 allocation, initialization and other support routines. */
24
25/* How the scalarizer works.
26 In gfortran, array expressions use the same core routines as scalar
27 expressions.
28 First, a Scalarization State (SS) chain is built. This is done by walking
29 the expression tree, and building a linear list of the terms in the
30 expression. As the tree is walked, scalar subexpressions are translated.
31
32 The scalarization parameters are stored in a gfc_loopinfo structure.
33 First the start and stride of each term is calculated by
34 gfc_conv_ss_startstride. During this process the expressions for the array
35 descriptors and data pointers are also translated.
36
37 If the expression is an assignment, we must then resolve any dependencies.
38 In Fortran all the rhs values of an assignment must be evaluated before
39 any assignments take place. This can require a temporary array to store the
40 values. We also require a temporary when we are passing array expressions
41 or vector subscripts as procedure parameters.
42
43 Array sections are passed without copying to a temporary. These use the
44 scalarizer to determine the shape of the section. The flag
45 loop->array_parameter tells the scalarizer that the actual values and loop
46 variables will not be required.
47
48 The function gfc_conv_loop_setup generates the scalarization setup code.
49 It determines the range of the scalarizing loop variables. If a temporary
50 is required, this is created and initialized. Code for scalar expressions
51 taken outside the loop is also generated at this time. Next the offset and
52 scaling required to translate from loop variables to array indices for each
53 term is calculated.
54
55 A call to gfc_start_scalarized_body marks the start of the scalarized
56 expression. This creates a scope and declares the loop variables. Before
57 calling this gfc_make_ss_chain_used must be used to indicate which terms
58 will be used inside this loop.
59
60 The scalar gfc_conv_* functions are then used to build the main body of the
61 scalarization loop. Scalarization loop variables and precalculated scalar
62 values are automatically substituted. Note that gfc_advance_se_ss_chain
63 must be used, rather than changing the se->ss directly.
64
65 For assignment expressions requiring a temporary two sub loops are
66 generated. The first stores the result of the expression in the temporary,
67 the second copies it to the result. A call to
68 gfc_trans_scalarized_loop_boundary marks the end of the main loop code and
69 the start of the copying loop. The temporary may be less than full rank.
70
71 Finally gfc_trans_scalarizing_loops is called to generate the implicit do
72 loops. The loops are added to the pre chain of the loopinfo. The post
73 chain may still contain cleanup code.
74
75 After the loop code has been added into its parent scope gfc_cleanup_loop
76 is called to free all the SS allocated by the scalarizer. */
77
78#include "config.h"
79#include "system.h"
80#include "coretypes.h"
81#include "options.h"
82#include "tree.h"
83#include "gfortran.h"
84#include "gimple-expr.h"
85#include "trans.h"
86#include "fold-const.h"
87#include "constructor.h"
88#include "trans-types.h"
89#include "trans-array.h"
90#include "trans-const.h"
91#include "dependency.h"
92
93static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor_base);
94
95/* The contents of this structure aren't actually used, just the address. */
96static gfc_ss gfc_ss_terminator_var;
97gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var;
98
99
100static tree
101gfc_array_dataptr_type (tree desc)
102{
103 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc))(((tree_class_check ((((contains_struct_check ((desc), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 103, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 103, __FUNCTION__))->type_with_lang_specific.lang_specific
)->dataptr_type));
104}
105
106/* Build expressions to access members of the CFI descriptor. */
107#define CFI_FIELD_BASE_ADDR 0
108#define CFI_FIELD_ELEM_LEN 1
109#define CFI_FIELD_VERSION 2
110#define CFI_FIELD_RANK 3
111#define CFI_FIELD_ATTRIBUTE 4
112#define CFI_FIELD_TYPE 5
113#define CFI_FIELD_DIM 6
114
115#define CFI_DIM_FIELD_LOWER_BOUND 0
116#define CFI_DIM_FIELD_EXTENT 1
117#define CFI_DIM_FIELD_SM 2
118
119static tree
120gfc_get_cfi_descriptor_field (tree desc, unsigned field_idx)
121{
122 tree type = TREE_TYPE (desc)((contains_struct_check ((desc), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 122, __FUNCTION__))->typed.type);
123 gcc_assert (TREE_CODE (type) == RECORD_TYPE((void)(!(((enum tree_code) (type)->base.code) == RECORD_TYPE
&& ((tree_check3 ((type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 124, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values) && (strcmp ("base_addr"
, ((const char *) (tree_check ((((contains_struct_check ((((tree_check3
((type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 126, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values)), (TS_DECL_MINIMAL), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 126, __FUNCTION__))->decl_minimal.name)), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 126, __FUNCTION__, (IDENTIFIER_NODE)))->identifier.id.str
)) == 0)) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 127, __FUNCTION__), 0 : 0))
124 && TYPE_FIELDS (type)((void)(!(((enum tree_code) (type)->base.code) == RECORD_TYPE
&& ((tree_check3 ((type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 124, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values) && (strcmp ("base_addr"
, ((const char *) (tree_check ((((contains_struct_check ((((tree_check3
((type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 126, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values)), (TS_DECL_MINIMAL), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 126, __FUNCTION__))->decl_minimal.name)), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 126, __FUNCTION__, (IDENTIFIER_NODE)))->identifier.id.str
)) == 0)) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 127, __FUNCTION__), 0 : 0))
125 && (strcmp ("base_addr",((void)(!(((enum tree_code) (type)->base.code) == RECORD_TYPE
&& ((tree_check3 ((type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 124, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values) && (strcmp ("base_addr"
, ((const char *) (tree_check ((((contains_struct_check ((((tree_check3
((type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 126, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values)), (TS_DECL_MINIMAL), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 126, __FUNCTION__))->decl_minimal.name)), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 126, __FUNCTION__, (IDENTIFIER_NODE)))->identifier.id.str
)) == 0)) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 127, __FUNCTION__), 0 : 0))
126 IDENTIFIER_POINTER (DECL_NAME (TYPE_FIELDS (type))))((void)(!(((enum tree_code) (type)->base.code) == RECORD_TYPE
&& ((tree_check3 ((type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 124, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values) && (strcmp ("base_addr"
, ((const char *) (tree_check ((((contains_struct_check ((((tree_check3
((type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 126, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values)), (TS_DECL_MINIMAL), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 126, __FUNCTION__))->decl_minimal.name)), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 126, __FUNCTION__, (IDENTIFIER_NODE)))->identifier.id.str
)) == 0)) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 127, __FUNCTION__), 0 : 0))
127 == 0))((void)(!(((enum tree_code) (type)->base.code) == RECORD_TYPE
&& ((tree_check3 ((type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 124, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values) && (strcmp ("base_addr"
, ((const char *) (tree_check ((((contains_struct_check ((((tree_check3
((type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 126, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values)), (TS_DECL_MINIMAL), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 126, __FUNCTION__))->decl_minimal.name)), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 126, __FUNCTION__, (IDENTIFIER_NODE)))->identifier.id.str
)) == 0)) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 127, __FUNCTION__), 0 : 0));
128 tree field = gfc_advance_chain (TYPE_FIELDS (type)((tree_check3 ((type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 128, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values), field_idx);
129 gcc_assert (field != NULL_TREE)((void)(!(field != (tree) __null) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 129, __FUNCTION__), 0 : 0));
130
131 return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field)((contains_struct_check ((field), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 131, __FUNCTION__))->typed.type),
132 desc, field, NULL_TREE(tree) __null);
133}
134
135tree
136gfc_get_cfi_desc_base_addr (tree desc)
137{
138 return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_BASE_ADDR);
139}
140
141tree
142gfc_get_cfi_desc_elem_len (tree desc)
143{
144 return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_ELEM_LEN);
145}
146
147tree
148gfc_get_cfi_desc_version (tree desc)
149{
150 return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_VERSION);
151}
152
153tree
154gfc_get_cfi_desc_rank (tree desc)
155{
156 return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_RANK);
157}
158
159tree
160gfc_get_cfi_desc_type (tree desc)
161{
162 return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_TYPE);
163}
164
165tree
166gfc_get_cfi_desc_attribute (tree desc)
167{
168 return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_ATTRIBUTE);
169}
170
171static tree
172gfc_get_cfi_dim_item (tree desc, tree idx, unsigned field_idx)
173{
174 tree tmp = gfc_get_cfi_descriptor_field (desc, CFI_FIELD_DIM);
175 tmp = gfc_build_array_ref (tmp, idx, NULL_TREE(tree) __null, true);
176 tree field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp))((tree_check3 ((((contains_struct_check ((tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 176, __FUNCTION__))->typed.type)), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 176, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values), field_idx);
177 gcc_assert (field != NULL_TREE)((void)(!(field != (tree) __null) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 177, __FUNCTION__), 0 : 0));
178 return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field)((contains_struct_check ((field), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 178, __FUNCTION__))->typed.type),
179 tmp, field, NULL_TREE(tree) __null);
180}
181
182tree
183gfc_get_cfi_dim_lbound (tree desc, tree idx)
184{
185 return gfc_get_cfi_dim_item (desc, idx, CFI_DIM_FIELD_LOWER_BOUND);
186}
187
188tree
189gfc_get_cfi_dim_extent (tree desc, tree idx)
190{
191 return gfc_get_cfi_dim_item (desc, idx, CFI_DIM_FIELD_EXTENT);
192}
193
194tree
195gfc_get_cfi_dim_sm (tree desc, tree idx)
196{
197 return gfc_get_cfi_dim_item (desc, idx, CFI_DIM_FIELD_SM);
198}
199
200#undef CFI_FIELD_BASE_ADDR
201#undef CFI_FIELD_ELEM_LEN
202#undef CFI_FIELD_VERSION
203#undef CFI_FIELD_RANK
204#undef CFI_FIELD_ATTRIBUTE
205#undef CFI_FIELD_TYPE
206#undef CFI_FIELD_DIM
207
208#undef CFI_DIM_FIELD_LOWER_BOUND
209#undef CFI_DIM_FIELD_EXTENT
210#undef CFI_DIM_FIELD_SM
211
212/* Build expressions to access the members of an array descriptor.
213 It's surprisingly easy to mess up here, so never access
214 an array descriptor by "brute force", always use these
215 functions. This also avoids problems if we change the format
216 of an array descriptor.
217
218 To understand these magic numbers, look at the comments
219 before gfc_build_array_type() in trans-types.cc.
220
221 The code within these defines should be the only code which knows the format
222 of an array descriptor.
223
224 Any code just needing to read obtain the bounds of an array should use
225 gfc_conv_array_* rather than the following functions as these will return
226 know constant values, and work with arrays which do not have descriptors.
227
228 Don't forget to #undef these! */
229
230#define DATA_FIELD 0
231#define OFFSET_FIELD 1
232#define DTYPE_FIELD 2
233#define SPAN_FIELD 3
234#define DIMENSION_FIELD 4
235#define CAF_TOKEN_FIELD 5
236
237#define STRIDE_SUBFIELD 0
238#define LBOUND_SUBFIELD 1
239#define UBOUND_SUBFIELD 2
240
241static tree
242gfc_get_descriptor_field (tree desc, unsigned field_idx)
243{
244 tree type = TREE_TYPE (desc)((contains_struct_check ((desc), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 244, __FUNCTION__))->typed.type);
245 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type))((void)(!(((tree_class_check ((type), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 245, __FUNCTION__))->type_common.lang_flag_1)) ? fancy_abort
("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 245, __FUNCTION__), 0 : 0));
246
247 tree field = gfc_advance_chain (TYPE_FIELDS (type)((tree_check3 ((type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 247, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values), field_idx);
248 gcc_assert (field != NULL_TREE)((void)(!(field != (tree) __null) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 248, __FUNCTION__), 0 : 0));
249
250 return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field)((contains_struct_check ((field), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 250, __FUNCTION__))->typed.type),
251 desc, field, NULL_TREE(tree) __null);
252}
253
254/* This provides READ-ONLY access to the data field. The field itself
255 doesn't have the proper type. */
256
257tree
258gfc_conv_descriptor_data_get (tree desc)
259{
260 tree type = TREE_TYPE (desc)((contains_struct_check ((desc), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 260, __FUNCTION__))->typed.type);
261 if (TREE_CODE (type)((enum tree_code) (type)->base.code) == REFERENCE_TYPE)
262 gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 262, __FUNCTION__));
263
264 tree field = gfc_get_descriptor_field (desc, DATA_FIELD);
265 return fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), field)fold_convert_loc (((location_t) 0), (((tree_class_check ((type
), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 265, __FUNCTION__))->type_with_lang_specific.lang_specific
)->dataptr_type), field);
266}
267
268/* This provides WRITE access to the data field.
269
270 TUPLES_P is true if we are generating tuples.
271
272 This function gets called through the following macros:
273 gfc_conv_descriptor_data_set
274 gfc_conv_descriptor_data_set. */
275
276void
277gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
278{
279 tree field = gfc_get_descriptor_field (desc, DATA_FIELD);
280 gfc_add_modify (block, field, fold_convert (TREE_TYPE (field), value)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(field), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 280, __FUNCTION__))->typed.type), value));
281}
282
283
284/* This provides address access to the data field. This should only be
285 used by array allocation, passing this on to the runtime. */
286
287tree
288gfc_conv_descriptor_data_addr (tree desc)
289{
290 tree field = gfc_get_descriptor_field (desc, DATA_FIELD);
291 return gfc_build_addr_expr (NULL_TREE(tree) __null, field);
292}
293
294static tree
295gfc_conv_descriptor_offset (tree desc)
296{
297 tree field = gfc_get_descriptor_field (desc, OFFSET_FIELD);
298 gcc_assert (TREE_TYPE (field) == gfc_array_index_type)((void)(!(((contains_struct_check ((field), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 298, __FUNCTION__))->typed.type) == gfc_array_index_type
) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 298, __FUNCTION__), 0 : 0));
299 return field;
300}
301
302tree
303gfc_conv_descriptor_offset_get (tree desc)
304{
305 return gfc_conv_descriptor_offset (desc);
306}
307
308void
309gfc_conv_descriptor_offset_set (stmtblock_t *block, tree desc,
310 tree value)
311{
312 tree t = gfc_conv_descriptor_offset (desc);
313 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(t), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 313, __FUNCTION__))->typed.type), value));
314}
315
316
317tree
318gfc_conv_descriptor_dtype (tree desc)
319{
320 tree field = gfc_get_descriptor_field (desc, DTYPE_FIELD);
321 gcc_assert (TREE_TYPE (field) == get_dtype_type_node ())((void)(!(((contains_struct_check ((field), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 321, __FUNCTION__))->typed.type) == get_dtype_type_node (
)) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 321, __FUNCTION__), 0 : 0));
322 return field;
323}
324
325static tree
326gfc_conv_descriptor_span (tree desc)
327{
328 tree field = gfc_get_descriptor_field (desc, SPAN_FIELD);
329 gcc_assert (TREE_TYPE (field) == gfc_array_index_type)((void)(!(((contains_struct_check ((field), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 329, __FUNCTION__))->typed.type) == gfc_array_index_type
) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 329, __FUNCTION__), 0 : 0));
330 return field;
331}
332
333tree
334gfc_conv_descriptor_span_get (tree desc)
335{
336 return gfc_conv_descriptor_span (desc);
337}
338
339void
340gfc_conv_descriptor_span_set (stmtblock_t *block, tree desc,
341 tree value)
342{
343 tree t = gfc_conv_descriptor_span (desc);
344 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(t), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 344, __FUNCTION__))->typed.type), value));
345}
346
347
348tree
349gfc_conv_descriptor_rank (tree desc)
350{
351 tree tmp;
352 tree dtype;
353
354 dtype = gfc_conv_descriptor_dtype (desc);
355 tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype))((tree_check3 ((((contains_struct_check ((dtype), (TS_TYPED),
"/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 355, __FUNCTION__))->typed.type)), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 355, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values), GFC_DTYPE_RANK2);
356 gcc_assert (tmp != NULL_TREE((void)(!(tmp != (tree) __null && ((contains_struct_check
((tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 357, __FUNCTION__))->typed.type) == integer_types[itk_signed_char
]) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 357, __FUNCTION__), 0 : 0))
357 && TREE_TYPE (tmp) == signed_char_type_node)((void)(!(tmp != (tree) __null && ((contains_struct_check
((tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 357, __FUNCTION__))->typed.type) == integer_types[itk_signed_char
]) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 357, __FUNCTION__), 0 : 0));
358 return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp)((contains_struct_check ((tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 358, __FUNCTION__))->typed.type),
359 dtype, tmp, NULL_TREE(tree) __null);
360}
361
362
363/* Return the element length from the descriptor dtype field. */
364
365tree
366gfc_conv_descriptor_elem_len (tree desc)
367{
368 tree tmp;
369 tree dtype;
370
371 dtype = gfc_conv_descriptor_dtype (desc);
372 tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype))((tree_check3 ((((contains_struct_check ((dtype), (TS_TYPED),
"/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 372, __FUNCTION__))->typed.type)), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 372, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values),
373 GFC_DTYPE_ELEM_LEN0);
374 gcc_assert (tmp != NULL_TREE((void)(!(tmp != (tree) __null && ((contains_struct_check
((tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 375, __FUNCTION__))->typed.type) == global_trees[TI_SIZE_TYPE
]) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 375, __FUNCTION__), 0 : 0))
375 && TREE_TYPE (tmp) == size_type_node)((void)(!(tmp != (tree) __null && ((contains_struct_check
((tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 375, __FUNCTION__))->typed.type) == global_trees[TI_SIZE_TYPE
]) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 375, __FUNCTION__), 0 : 0));
376 return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp)((contains_struct_check ((tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 376, __FUNCTION__))->typed.type),
377 dtype, tmp, NULL_TREE(tree) __null);
378}
379
380
381tree
382gfc_conv_descriptor_attribute (tree desc)
383{
384 tree tmp;
385 tree dtype;
386
387 dtype = gfc_conv_descriptor_dtype (desc);
388 tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype))((tree_check3 ((((contains_struct_check ((dtype), (TS_TYPED),
"/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 388, __FUNCTION__))->typed.type)), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 388, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values),
389 GFC_DTYPE_ATTRIBUTE4);
390 gcc_assert (tmp!= NULL_TREE((void)(!(tmp!= (tree) __null && ((contains_struct_check
((tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 391, __FUNCTION__))->typed.type) == integer_types[itk_short
]) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 391, __FUNCTION__), 0 : 0))
391 && TREE_TYPE (tmp) == short_integer_type_node)((void)(!(tmp!= (tree) __null && ((contains_struct_check
((tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 391, __FUNCTION__))->typed.type) == integer_types[itk_short
]) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 391, __FUNCTION__), 0 : 0));
392 return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp)((contains_struct_check ((tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 392, __FUNCTION__))->typed.type),
393 dtype, tmp, NULL_TREE(tree) __null);
394}
395
396tree
397gfc_conv_descriptor_type (tree desc)
398{
399 tree tmp;
400 tree dtype;
401
402 dtype = gfc_conv_descriptor_dtype (desc);
403 tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype))((tree_check3 ((((contains_struct_check ((dtype), (TS_TYPED),
"/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 403, __FUNCTION__))->typed.type)), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 403, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values), GFC_DTYPE_TYPE3);
404 gcc_assert (tmp!= NULL_TREE((void)(!(tmp!= (tree) __null && ((contains_struct_check
((tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 405, __FUNCTION__))->typed.type) == integer_types[itk_signed_char
]) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 405, __FUNCTION__), 0 : 0))
405 && TREE_TYPE (tmp) == signed_char_type_node)((void)(!(tmp!= (tree) __null && ((contains_struct_check
((tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 405, __FUNCTION__))->typed.type) == integer_types[itk_signed_char
]) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 405, __FUNCTION__), 0 : 0));
406 return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp)((contains_struct_check ((tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 406, __FUNCTION__))->typed.type),
407 dtype, tmp, NULL_TREE(tree) __null);
408}
409
410tree
411gfc_get_descriptor_dimension (tree desc)
412{
413 tree field = gfc_get_descriptor_field (desc, DIMENSION_FIELD);
414 gcc_assert (TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE((void)(!(((enum tree_code) (((contains_struct_check ((field)
, (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 414, __FUNCTION__))->typed.type))->base.code) == ARRAY_TYPE
&& ((enum tree_code) (((contains_struct_check ((((contains_struct_check
((field), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 415, __FUNCTION__))->typed.type)), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 415, __FUNCTION__))->typed.type))->base.code) == RECORD_TYPE
) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 415, __FUNCTION__), 0 : 0))
415 && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE)((void)(!(((enum tree_code) (((contains_struct_check ((field)
, (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 414, __FUNCTION__))->typed.type))->base.code) == ARRAY_TYPE
&& ((enum tree_code) (((contains_struct_check ((((contains_struct_check
((field), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 415, __FUNCTION__))->typed.type)), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 415, __FUNCTION__))->typed.type))->base.code) == RECORD_TYPE
) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 415, __FUNCTION__), 0 : 0));
416 return field;
417}
418
419
420static tree
421gfc_conv_descriptor_dimension (tree desc, tree dim)
422{
423 tree tmp;
424
425 tmp = gfc_get_descriptor_dimension (desc);
426
427 return gfc_build_array_ref (tmp, dim, NULL_TREE(tree) __null, true);
428}
429
430
431tree
432gfc_conv_descriptor_token (tree desc)
433{
434 gcc_assert (flag_coarray == GFC_FCOARRAY_LIB)((void)(!(global_options.x_flag_coarray == GFC_FCOARRAY_LIB) ?
fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 434, __FUNCTION__), 0 : 0));
435 tree field = gfc_get_descriptor_field (desc, CAF_TOKEN_FIELD);
436 /* Should be a restricted pointer - except in the finalization wrapper. */
437 gcc_assert (TREE_TYPE (field) == prvoid_type_node((void)(!(((contains_struct_check ((field), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 437, __FUNCTION__))->typed.type) == prvoid_type_node || (
(contains_struct_check ((field), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 438, __FUNCTION__))->typed.type) == pvoid_type_node) ? fancy_abort
("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 438, __FUNCTION__), 0 : 0))
438 || TREE_TYPE (field) == pvoid_type_node)((void)(!(((contains_struct_check ((field), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 437, __FUNCTION__))->typed.type) == prvoid_type_node || (
(contains_struct_check ((field), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 438, __FUNCTION__))->typed.type) == pvoid_type_node) ? fancy_abort
("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 438, __FUNCTION__), 0 : 0));
439 return field;
440}
441
442static tree
443gfc_conv_descriptor_subfield (tree desc, tree dim, unsigned field_idx)
444{
445 tree tmp = gfc_conv_descriptor_dimension (desc, dim);
446 tree field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp))((tree_check3 ((((contains_struct_check ((tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 446, __FUNCTION__))->typed.type)), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 446, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values), field_idx);
447 gcc_assert (field != NULL_TREE)((void)(!(field != (tree) __null) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 447, __FUNCTION__), 0 : 0));
448
449 return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field)((contains_struct_check ((field), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 449, __FUNCTION__))->typed.type),
450 tmp, field, NULL_TREE(tree) __null);
451}
452
453static tree
454gfc_conv_descriptor_stride (tree desc, tree dim)
455{
456 tree field = gfc_conv_descriptor_subfield (desc, dim, STRIDE_SUBFIELD);
457 gcc_assert (TREE_TYPE (field) == gfc_array_index_type)((void)(!(((contains_struct_check ((field), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 457, __FUNCTION__))->typed.type) == gfc_array_index_type
) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 457, __FUNCTION__), 0 : 0));
458 return field;
459}
460
461tree
462gfc_conv_descriptor_stride_get (tree desc, tree dim)
463{
464 tree type = TREE_TYPE (desc)((contains_struct_check ((desc), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 464, __FUNCTION__))->typed.type);
465 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type))((void)(!(((tree_class_check ((type), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 465, __FUNCTION__))->type_common.lang_flag_1)) ? fancy_abort
("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 465, __FUNCTION__), 0 : 0));
466 if (integer_zerop (dim)
467 && (GFC_TYPE_ARRAY_AKIND (type)(((tree_class_check ((type), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 467, __FUNCTION__))->type_with_lang_specific.lang_specific
)->akind) == GFC_ARRAY_ALLOCATABLE
468 ||GFC_TYPE_ARRAY_AKIND (type)(((tree_class_check ((type), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 468, __FUNCTION__))->type_with_lang_specific.lang_specific
)->akind) == GFC_ARRAY_ASSUMED_SHAPE_CONT
469 ||GFC_TYPE_ARRAY_AKIND (type)(((tree_class_check ((type), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 469, __FUNCTION__))->type_with_lang_specific.lang_specific
)->akind) == GFC_ARRAY_ASSUMED_RANK_CONT
470 ||GFC_TYPE_ARRAY_AKIND (type)(((tree_class_check ((type), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 470, __FUNCTION__))->type_with_lang_specific.lang_specific
)->akind) == GFC_ARRAY_POINTER_CONT))
471 return gfc_index_one_nodegfc_rank_cst[1];
472
473 return gfc_conv_descriptor_stride (desc, dim);
474}
475
476void
477gfc_conv_descriptor_stride_set (stmtblock_t *block, tree desc,
478 tree dim, tree value)
479{
480 tree t = gfc_conv_descriptor_stride (desc, dim);
481 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(t), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 481, __FUNCTION__))->typed.type), value));
482}
483
484static tree
485gfc_conv_descriptor_lbound (tree desc, tree dim)
486{
487 tree field = gfc_conv_descriptor_subfield (desc, dim, LBOUND_SUBFIELD);
488 gcc_assert (TREE_TYPE (field) == gfc_array_index_type)((void)(!(((contains_struct_check ((field), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 488, __FUNCTION__))->typed.type) == gfc_array_index_type
) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 488, __FUNCTION__), 0 : 0));
489 return field;
490}
491
492tree
493gfc_conv_descriptor_lbound_get (tree desc, tree dim)
494{
495 return gfc_conv_descriptor_lbound (desc, dim);
496}
497
498void
499gfc_conv_descriptor_lbound_set (stmtblock_t *block, tree desc,
500 tree dim, tree value)
501{
502 tree t = gfc_conv_descriptor_lbound (desc, dim);
503 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(t), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 503, __FUNCTION__))->typed.type), value));
504}
505
506static tree
507gfc_conv_descriptor_ubound (tree desc, tree dim)
508{
509 tree field = gfc_conv_descriptor_subfield (desc, dim, UBOUND_SUBFIELD);
510 gcc_assert (TREE_TYPE (field) == gfc_array_index_type)((void)(!(((contains_struct_check ((field), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 510, __FUNCTION__))->typed.type) == gfc_array_index_type
) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 510, __FUNCTION__), 0 : 0));
511 return field;
512}
513
514tree
515gfc_conv_descriptor_ubound_get (tree desc, tree dim)
516{
517 return gfc_conv_descriptor_ubound (desc, dim);
518}
519
520void
521gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree desc,
522 tree dim, tree value)
523{
524 tree t = gfc_conv_descriptor_ubound (desc, dim);
525 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(t), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 525, __FUNCTION__))->typed.type), value));
526}
527
528/* Build a null array descriptor constructor. */
529
530tree
531gfc_build_null_descriptor (tree type)
532{
533 tree field;
534 tree tmp;
535
536 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type))((void)(!(((tree_class_check ((type), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 536, __FUNCTION__))->type_common.lang_flag_1)) ? fancy_abort
("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 536, __FUNCTION__), 0 : 0));
537 gcc_assert (DATA_FIELD == 0)((void)(!(DATA_FIELD == 0) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 537, __FUNCTION__), 0 : 0));
538 field = TYPE_FIELDS (type)((tree_check3 ((type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 538, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values);
539
540 /* Set a NULL data pointer. */
541 tmp = build_constructor_single (type, field, null_pointer_nodeglobal_trees[TI_NULL_POINTER]);
542 TREE_CONSTANT (tmp)((non_type_check ((tmp), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 542, __FUNCTION__))->base.constant_flag) = 1;
543 /* All other fields are ignored. */
544
545 return tmp;
546}
547
548
549/* Modify a descriptor such that the lbound of a given dimension is the value
550 specified. This also updates ubound and offset accordingly. */
551
552void
553gfc_conv_shift_descriptor_lbound (stmtblock_t* block, tree desc,
554 int dim, tree new_lbound)
555{
556 tree offs, ubound, lbound, stride;
557 tree diff, offs_diff;
558
559 new_lbound = fold_convert (gfc_array_index_type, new_lbound)fold_convert_loc (((location_t) 0), gfc_array_index_type, new_lbound
);
560
561 offs = gfc_conv_descriptor_offset_get (desc);
562 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
563 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
564 stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[dim]);
565
566 /* Get difference (new - old) by which to shift stuff. */
567 diff = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
568 new_lbound, lbound);
569
570 /* Shift ubound and offset accordingly. This has to be done before
571 updating the lbound, as they depend on the lbound expression! */
572 ubound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
573 ubound, diff);
574 gfc_conv_descriptor_ubound_set (block, desc, gfc_rank_cst[dim], ubound);
575 offs_diff = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
576 diff, stride);
577 offs = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
578 offs, offs_diff);
579 gfc_conv_descriptor_offset_set (block, desc, offs);
580
581 /* Finally set lbound to value we want. */
582 gfc_conv_descriptor_lbound_set (block, desc, gfc_rank_cst[dim], new_lbound);
583}
584
585
586/* Obtain offsets for trans-types.cc(gfc_get_array_descr_info). */
587
588void
589gfc_get_descriptor_offsets_for_info (const_tree desc_type, tree *data_off,
590 tree *dtype_off, tree *span_off,
591 tree *dim_off, tree *dim_size,
592 tree *stride_suboff, tree *lower_suboff,
593 tree *upper_suboff)
594{
595 tree field;
596 tree type;
597
598 type = TYPE_MAIN_VARIANT (desc_type)((tree_class_check ((desc_type), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 598, __FUNCTION__))->type_common.main_variant);
599 field = gfc_advance_chain (TYPE_FIELDS (type)((tree_check3 ((type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 599, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values), DATA_FIELD);
600 *data_off = byte_position (field);
601 field = gfc_advance_chain (TYPE_FIELDS (type)((tree_check3 ((type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 601, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values), DTYPE_FIELD);
602 *dtype_off = byte_position (field);
603 field = gfc_advance_chain (TYPE_FIELDS (type)((tree_check3 ((type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 603, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values), SPAN_FIELD);
604 *span_off = byte_position (field);
605 field = gfc_advance_chain (TYPE_FIELDS (type)((tree_check3 ((type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 605, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values), DIMENSION_FIELD);
606 *dim_off = byte_position (field);
607 type = TREE_TYPE (TREE_TYPE (field))((contains_struct_check ((((contains_struct_check ((field), (
TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 607, __FUNCTION__))->typed.type)), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 607, __FUNCTION__))->typed.type);
608 *dim_size = TYPE_SIZE_UNIT (type)((tree_class_check ((type), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 608, __FUNCTION__))->type_common.size_unit);
609 field = gfc_advance_chain (TYPE_FIELDS (type)((tree_check3 ((type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 609, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values), STRIDE_SUBFIELD);
610 *stride_suboff = byte_position (field);
611 field = gfc_advance_chain (TYPE_FIELDS (type)((tree_check3 ((type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 611, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values), LBOUND_SUBFIELD);
612 *lower_suboff = byte_position (field);
613 field = gfc_advance_chain (TYPE_FIELDS (type)((tree_check3 ((type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 613, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values), UBOUND_SUBFIELD);
614 *upper_suboff = byte_position (field);
615}
616
617
618/* Cleanup those #defines. */
619
620#undef DATA_FIELD
621#undef OFFSET_FIELD
622#undef DTYPE_FIELD
623#undef SPAN_FIELD
624#undef DIMENSION_FIELD
625#undef CAF_TOKEN_FIELD
626#undef STRIDE_SUBFIELD
627#undef LBOUND_SUBFIELD
628#undef UBOUND_SUBFIELD
629
630
631/* Mark a SS chain as used. Flags specifies in which loops the SS is used.
632 flags & 1 = Main loop body.
633 flags & 2 = temp copy loop. */
634
635void
636gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
637{
638 for (; ss != gfc_ss_terminator; ss = ss->next)
639 ss->info->useflags = flags;
640}
641
642
643/* Free a gfc_ss chain. */
644
645void
646gfc_free_ss_chain (gfc_ss * ss)
647{
648 gfc_ss *next;
649
650 while (ss != gfc_ss_terminator)
651 {
652 gcc_assert (ss != NULL)((void)(!(ss != __null) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 652, __FUNCTION__), 0 : 0));
653 next = ss->next;
654 gfc_free_ss (ss);
655 ss = next;
656 }
657}
658
659
660static void
661free_ss_info (gfc_ss_info *ss_info)
662{
663 int n;
664
665 ss_info->refcount--;
666 if (ss_info->refcount > 0)
667 return;
668
669 gcc_assert (ss_info->refcount == 0)((void)(!(ss_info->refcount == 0) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 669, __FUNCTION__), 0 : 0));
670
671 switch (ss_info->type)
672 {
673 case GFC_SS_SECTION:
674 for (n = 0; n < GFC_MAX_DIMENSIONS15; n++)
675 if (ss_info->data.array.subscript[n])
676 gfc_free_ss_chain (ss_info->data.array.subscript[n]);
677 break;
678
679 default:
680 break;
681 }
682
683 free (ss_info);
684}
685
686
687/* Free a SS. */
688
689void
690gfc_free_ss (gfc_ss * ss)
691{
692 free_ss_info (ss->info);
693 free (ss);
694}
695
696
697/* Creates and initializes an array type gfc_ss struct. */
698
699gfc_ss *
700gfc_get_array_ss (gfc_ss *next, gfc_expr *expr, int dimen, gfc_ss_type type)
701{
702 gfc_ss *ss;
703 gfc_ss_info *ss_info;
704 int i;
705
706 ss_info = gfc_get_ss_info ()((gfc_ss_info *) xcalloc (1, sizeof (gfc_ss_info)));
707 ss_info->refcount++;
708 ss_info->type = type;
709 ss_info->expr = expr;
710
711 ss = gfc_get_ss ()((gfc_ss *) xcalloc (1, sizeof (gfc_ss)));
712 ss->info = ss_info;
713 ss->next = next;
714 ss->dimen = dimen;
715 for (i = 0; i < ss->dimen; i++)
716 ss->dim[i] = i;
717
718 return ss;
719}
720
721
722/* Creates and initializes a temporary type gfc_ss struct. */
723
724gfc_ss *
725gfc_get_temp_ss (tree type, tree string_length, int dimen)
726{
727 gfc_ss *ss;
728 gfc_ss_info *ss_info;
729 int i;
730
731 ss_info = gfc_get_ss_info ()((gfc_ss_info *) xcalloc (1, sizeof (gfc_ss_info)));
732 ss_info->refcount++;
733 ss_info->type = GFC_SS_TEMP;
734 ss_info->string_length = string_length;
735 ss_info->data.temp.type = type;
736
737 ss = gfc_get_ss ()((gfc_ss *) xcalloc (1, sizeof (gfc_ss)));
738 ss->info = ss_info;
739 ss->next = gfc_ss_terminator;
740 ss->dimen = dimen;
741 for (i = 0; i < ss->dimen; i++)
742 ss->dim[i] = i;
743
744 return ss;
745}
746
747
748/* Creates and initializes a scalar type gfc_ss struct. */
749
750gfc_ss *
751gfc_get_scalar_ss (gfc_ss *next, gfc_expr *expr)
752{
753 gfc_ss *ss;
754 gfc_ss_info *ss_info;
755
756 ss_info = gfc_get_ss_info ()((gfc_ss_info *) xcalloc (1, sizeof (gfc_ss_info)));
757 ss_info->refcount++;
758 ss_info->type = GFC_SS_SCALAR;
759 ss_info->expr = expr;
760
761 ss = gfc_get_ss ()((gfc_ss *) xcalloc (1, sizeof (gfc_ss)));
762 ss->info = ss_info;
763 ss->next = next;
764
765 return ss;
766}
767
768
769/* Free all the SS associated with a loop. */
770
771void
772gfc_cleanup_loop (gfc_loopinfo * loop)
773{
774 gfc_loopinfo *loop_next, **ploop;
775 gfc_ss *ss;
776 gfc_ss *next;
777
778 ss = loop->ss;
779 while (ss != gfc_ss_terminator)
780 {
781 gcc_assert (ss != NULL)((void)(!(ss != __null) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 781, __FUNCTION__), 0 : 0));
782 next = ss->loop_chain;
783 gfc_free_ss (ss);
784 ss = next;
785 }
786
787 /* Remove reference to self in the parent loop. */
788 if (loop->parent)
789 for (ploop = &loop->parent->nested; *ploop; ploop = &(*ploop)->next)
790 if (*ploop == loop)
791 {
792 *ploop = loop->next;
793 break;
794 }
795
796 /* Free non-freed nested loops. */
797 for (loop = loop->nested; loop; loop = loop_next)
798 {
799 loop_next = loop->next;
800 gfc_cleanup_loop (loop);
801 free (loop);
802 }
803}
804
805
806static void
807set_ss_loop (gfc_ss *ss, gfc_loopinfo *loop)
808{
809 int n;
810
811 for (; ss != gfc_ss_terminator; ss = ss->next)
812 {
813 ss->loop = loop;
814
815 if (ss->info->type == GFC_SS_SCALAR
816 || ss->info->type == GFC_SS_REFERENCE
817 || ss->info->type == GFC_SS_TEMP)
818 continue;
819
820 for (n = 0; n < GFC_MAX_DIMENSIONS15; n++)
821 if (ss->info->data.array.subscript[n] != NULL__null)
822 set_ss_loop (ss->info->data.array.subscript[n], loop);
823 }
824}
825
826
827/* Associate a SS chain with a loop. */
828
829void
830gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
831{
832 gfc_ss *ss;
833 gfc_loopinfo *nested_loop;
834
835 if (head == gfc_ss_terminator)
836 return;
837
838 set_ss_loop (head, loop);
839
840 ss = head;
841 for (; ss && ss != gfc_ss_terminator; ss = ss->next)
842 {
843 if (ss->nested_ss)
844 {
845 nested_loop = ss->nested_ss->loop;
846
847 /* More than one ss can belong to the same loop. Hence, we add the
848 loop to the chain only if it is different from the previously
849 added one, to avoid duplicate nested loops. */
850 if (nested_loop != loop->nested)
851 {
852 gcc_assert (nested_loop->parent == NULL)((void)(!(nested_loop->parent == __null) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 852, __FUNCTION__), 0 : 0));
853 nested_loop->parent = loop;
854
855 gcc_assert (nested_loop->next == NULL)((void)(!(nested_loop->next == __null) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 855, __FUNCTION__), 0 : 0));
856 nested_loop->next = loop->nested;
857 loop->nested = nested_loop;
858 }
859 else
860 gcc_assert (nested_loop->parent == loop)((void)(!(nested_loop->parent == loop) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 860, __FUNCTION__), 0 : 0));
861 }
862
863 if (ss->next == gfc_ss_terminator)
864 ss->loop_chain = loop->ss;
865 else
866 ss->loop_chain = ss->next;
867 }
868 gcc_assert (ss == gfc_ss_terminator)((void)(!(ss == gfc_ss_terminator) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 868, __FUNCTION__), 0 : 0));
869 loop->ss = head;
870}
871
872
873/* Returns true if the expression is an array pointer. */
874
875static bool
876is_pointer_array (tree expr)
877{
878 if (expr == NULL_TREE(tree) __null
879 || !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr))((tree_class_check ((((contains_struct_check ((expr), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 879, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 879, __FUNCTION__))->type_common.lang_flag_1)
880 || GFC_CLASS_TYPE_P (TREE_TYPE (expr))((tree_class_check ((((contains_struct_check ((expr), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 880, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 880, __FUNCTION__))->type_common.lang_flag_4))
881 return false;
882
883 if (TREE_CODE (expr)((enum tree_code) (expr)->base.code) == VAR_DECL
884 && GFC_DECL_PTR_ARRAY_P (expr)((contains_struct_check ((expr), (TS_DECL_COMMON), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 884, __FUNCTION__))->decl_common.lang_flag_6))
885 return true;
886
887 if (TREE_CODE (expr)((enum tree_code) (expr)->base.code) == PARM_DECL
888 && GFC_DECL_PTR_ARRAY_P (expr)((contains_struct_check ((expr), (TS_DECL_COMMON), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 888, __FUNCTION__))->decl_common.lang_flag_6))
889 return true;
890
891 if (TREE_CODE (expr)((enum tree_code) (expr)->base.code) == INDIRECT_REF
892 && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 0))((contains_struct_check (((*((const_cast<tree*> (tree_operand_check
((expr), (0), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 892, __FUNCTION__)))))), (TS_DECL_COMMON), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 892, __FUNCTION__))->decl_common.lang_flag_6))
893 return true;
894
895 /* The field declaration is marked as an pointer array. */
896 if (TREE_CODE (expr)((enum tree_code) (expr)->base.code) == COMPONENT_REF
897 && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 1))((contains_struct_check (((*((const_cast<tree*> (tree_operand_check
((expr), (1), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 897, __FUNCTION__)))))), (TS_DECL_COMMON), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 897, __FUNCTION__))->decl_common.lang_flag_6)
898 && !GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (expr, 1)))((tree_class_check ((((contains_struct_check (((*((const_cast
<tree*> (tree_operand_check ((expr), (1), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 898, __FUNCTION__)))))), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 898, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 898, __FUNCTION__))->type_common.lang_flag_4))
899 return true;
900
901 return false;
902}
903
904
905/* If the symbol or expression reference a CFI descriptor, return the
906 pointer to the converted gfc descriptor. If an array reference is
907 present as the last argument, check that it is the one applied to
908 the CFI descriptor in the expression. Note that the CFI object is
909 always the symbol in the expression! */
910
911static bool
912get_CFI_desc (gfc_symbol *sym, gfc_expr *expr,
913 tree *desc, gfc_array_ref *ar)
914{
915 tree tmp;
916
917 if (!is_CFI_desc (sym, expr))
918 return false;
919
920 if (expr && ar)
921 {
922 if (!(expr->ref && expr->ref->type == REF_ARRAY)
923 || (&expr->ref->u.ar != ar))
924 return false;
925 }
926
927 if (sym == NULL__null)
928 tmp = expr->symtree->n.sym->backend_decl;
929 else
930 tmp = sym->backend_decl;
931
932 if (tmp && DECL_LANG_SPECIFIC (tmp)((contains_struct_check ((tmp), (TS_DECL_COMMON), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 932, __FUNCTION__))->decl_common.lang_specific) && GFC_DECL_SAVED_DESCRIPTOR (tmp)(((contains_struct_check ((tmp), (TS_DECL_COMMON), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 932, __FUNCTION__))->decl_common.lang_specific)->saved_descriptor
))
933 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp)(((contains_struct_check ((tmp), (TS_DECL_COMMON), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 933, __FUNCTION__))->decl_common.lang_specific)->saved_descriptor
);
934
935 *desc = tmp;
936 return true;
937}
938
939
940/* Return the span of an array. */
941
942tree
943gfc_get_array_span (tree desc, gfc_expr *expr)
944{
945 tree tmp;
946
947 if (is_pointer_array (desc)
948 || (get_CFI_desc (NULL__null, expr, &desc, NULL__null)
949 && (POINTER_TYPE_P (TREE_TYPE (desc))(((enum tree_code) (((contains_struct_check ((desc), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 949, __FUNCTION__))->typed.type))->base.code) == POINTER_TYPE
|| ((enum tree_code) (((contains_struct_check ((desc), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 949, __FUNCTION__))->typed.type))->base.code) == REFERENCE_TYPE
)
950 ? GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (desc)))((tree_class_check ((((contains_struct_check ((((contains_struct_check
((desc), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 950, __FUNCTION__))->typed.type)), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 950, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 950, __FUNCTION__))->type_common.lang_flag_1)
951 : GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))((tree_class_check ((((contains_struct_check ((desc), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 951, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 951, __FUNCTION__))->type_common.lang_flag_1))))
952 {
953 if (POINTER_TYPE_P (TREE_TYPE (desc))(((enum tree_code) (((contains_struct_check ((desc), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 953, __FUNCTION__))->typed.type))->base.code) == POINTER_TYPE
|| ((enum tree_code) (((contains_struct_check ((desc), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 953, __FUNCTION__))->typed.type))->base.code) == REFERENCE_TYPE
))
954 desc = build_fold_indirect_ref_loc (input_location, desc);
955
956 /* This will have the span field set. */
957 tmp = gfc_conv_descriptor_span_get (desc);
958 }
959 else if (expr->ts.type == BT_ASSUMED)
960 {
961 if (DECL_LANG_SPECIFIC (desc)((contains_struct_check ((desc), (TS_DECL_COMMON), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 961, __FUNCTION__))->decl_common.lang_specific) && GFC_DECL_SAVED_DESCRIPTOR (desc)(((contains_struct_check ((desc), (TS_DECL_COMMON), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 961, __FUNCTION__))->decl_common.lang_specific)->saved_descriptor
))
962 desc = GFC_DECL_SAVED_DESCRIPTOR (desc)(((contains_struct_check ((desc), (TS_DECL_COMMON), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 962, __FUNCTION__))->decl_common.lang_specific)->saved_descriptor
);
963 if (POINTER_TYPE_P (TREE_TYPE (desc))(((enum tree_code) (((contains_struct_check ((desc), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 963, __FUNCTION__))->typed.type))->base.code) == POINTER_TYPE
|| ((enum tree_code) (((contains_struct_check ((desc), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 963, __FUNCTION__))->typed.type))->base.code) == REFERENCE_TYPE
))
964 desc = build_fold_indirect_ref_loc (input_location, desc);
965 tmp = gfc_conv_descriptor_span_get (desc);
966 }
967 else if (TREE_CODE (desc)((enum tree_code) (desc)->base.code) == COMPONENT_REF
968 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))((tree_class_check ((((contains_struct_check ((desc), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 968, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 968, __FUNCTION__))->type_common.lang_flag_1)
969 && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (desc, 0)))((tree_class_check ((((contains_struct_check (((*((const_cast
<tree*> (tree_operand_check ((desc), (0), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 969, __FUNCTION__)))))), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 969, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 969, __FUNCTION__))->type_common.lang_flag_4))
970 {
971 /* The descriptor is a class _data field and so use the vtable
972 size for the receiving span field. */
973 tmp = gfc_get_vptr_from_expr (desc);
974 tmp = gfc_vptr_size_get (tmp);
975 }
976 else if (expr && expr->expr_type == EXPR_VARIABLE
977 && expr->symtree->n.sym->ts.type == BT_CLASS
978 && expr->ref->type == REF_COMPONENT
979 && expr->ref->next->type == REF_ARRAY
980 && expr->ref->next->next == NULL__null
981 && CLASS_DATA (expr->symtree->n.sym)expr->symtree->n.sym->ts.u.derived->components->attr.dimension)
982 {
983 /* Dummys come in sometimes with the descriptor detached from
984 the class field or declaration. */
985 tmp = gfc_class_vptr_get (expr->symtree->n.sym->backend_decl);
986 tmp = gfc_vptr_size_get (tmp);
987 }
988 else
989 {
990 /* If none of the fancy stuff works, the span is the element
991 size of the array. Attempt to deal with unbounded character
992 types if possible. Otherwise, return NULL_TREE. */
993 tmp = gfc_get_element_type (TREE_TYPE (desc)((contains_struct_check ((desc), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 993, __FUNCTION__))->typed.type));
994 if (tmp && TREE_CODE (tmp)((enum tree_code) (tmp)->base.code) == ARRAY_TYPE && TYPE_STRING_FLAG (tmp)((tree_check2 ((tmp), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 994, __FUNCTION__, (ARRAY_TYPE), (INTEGER_TYPE)))->type_common
.string_flag))
995 {
996 gcc_assert (expr->ts.type == BT_CHARACTER)((void)(!(expr->ts.type == BT_CHARACTER) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 996, __FUNCTION__), 0 : 0));
997
998 tmp = gfc_get_character_len_in_bytes (tmp);
999
1000 if (tmp == NULL_TREE(tree) __null || integer_zerop (tmp))
1001 {
1002 tree bs;
1003
1004 tmp = gfc_get_expr_charlen (expr);
1005 tmp = fold_convert (gfc_array_index_type, tmp)fold_convert_loc (((location_t) 0), gfc_array_index_type, tmp
);
1006 bs = build_int_cst (gfc_array_index_type, expr->ts.kind);
1007 tmp = fold_build2_loc (input_location, MULT_EXPR,
1008 gfc_array_index_type, tmp, bs);
1009 }
1010
1011 tmp = (tmp && !integer_zerop (tmp))
1012 ? (fold_convert (gfc_array_index_type, tmp)fold_convert_loc (((location_t) 0), gfc_array_index_type, tmp
)) : (NULL_TREE(tree) __null);
1013 }
1014 else
1015 tmp = fold_convert (gfc_array_index_type,fold_convert_loc (((location_t) 0), gfc_array_index_type, size_in_bytes
(tmp))
1016 size_in_bytes (tmp))fold_convert_loc (((location_t) 0), gfc_array_index_type, size_in_bytes
(tmp));
1017 }
1018 return tmp;
1019}
1020
1021
1022/* Generate an initializer for a static pointer or allocatable array. */
1023
1024void
1025gfc_trans_static_array_pointer (gfc_symbol * sym)
1026{
1027 tree type;
1028
1029 gcc_assert (TREE_STATIC (sym->backend_decl))((void)(!(((sym->backend_decl)->base.static_flag)) ? fancy_abort
("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1029, __FUNCTION__), 0 : 0));
1030 /* Just zero the data member. */
1031 type = TREE_TYPE (sym->backend_decl)((contains_struct_check ((sym->backend_decl), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1031, __FUNCTION__))->typed.type);
1032 DECL_INITIAL (sym->backend_decl)((contains_struct_check ((sym->backend_decl), (TS_DECL_COMMON
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1032, __FUNCTION__))->decl_common.initial) = gfc_build_null_descriptor (type);
1033}
1034
1035
1036/* If the bounds of SE's loop have not yet been set, see if they can be
1037 determined from array spec AS, which is the array spec of a called
1038 function. MAPPING maps the callee's dummy arguments to the values
1039 that the caller is passing. Add any initialization and finalization
1040 code to SE. */
1041
1042void
1043gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
1044 gfc_se * se, gfc_array_spec * as)
1045{
1046 int n, dim, total_dim;
1047 gfc_se tmpse;
1048 gfc_ss *ss;
1049 tree lower;
1050 tree upper;
1051 tree tmp;
1052
1053 total_dim = 0;
1054
1055 if (!as || as->type != AS_EXPLICIT)
1056 return;
1057
1058 for (ss = se->ss; ss; ss = ss->parent)
1059 {
1060 total_dim += ss->loop->dimen;
1061 for (n = 0; n < ss->loop->dimen; n++)
1062 {
1063 /* The bound is known, nothing to do. */
1064 if (ss->loop->to[n] != NULL_TREE(tree) __null)
1065 continue;
1066
1067 dim = ss->dim[n];
1068 gcc_assert (dim < as->rank)((void)(!(dim < as->rank) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1068, __FUNCTION__), 0 : 0));
1069 gcc_assert (ss->loop->dimen <= as->rank)((void)(!(ss->loop->dimen <= as->rank) ? fancy_abort
("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1069, __FUNCTION__), 0 : 0));
1070
1071 /* Evaluate the lower bound. */
1072 gfc_init_se (&tmpse, NULL__null);
1073 gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
1074 gfc_add_block_to_block (&se->pre, &tmpse.pre);
1075 gfc_add_block_to_block (&se->post, &tmpse.post);
1076 lower = fold_convert (gfc_array_index_type, tmpse.expr)fold_convert_loc (((location_t) 0), gfc_array_index_type, tmpse
.expr);
1077
1078 /* ...and the upper bound. */
1079 gfc_init_se (&tmpse, NULL__null);
1080 gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
1081 gfc_add_block_to_block (&se->pre, &tmpse.pre);
1082 gfc_add_block_to_block (&se->post, &tmpse.post);
1083 upper = fold_convert (gfc_array_index_type, tmpse.expr)fold_convert_loc (((location_t) 0), gfc_array_index_type, tmpse
.expr);
1084
1085 /* Set the upper bound of the loop to UPPER - LOWER. */
1086 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1087 gfc_array_index_type, upper, lower);
1088 tmp = gfc_evaluate_now (tmp, &se->pre);
1089 ss->loop->to[n] = tmp;
1090 }
1091 }
1092
1093 gcc_assert (total_dim == as->rank)((void)(!(total_dim == as->rank) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1093, __FUNCTION__), 0 : 0));
1094}
1095
1096
1097/* Generate code to allocate an array temporary, or create a variable to
1098 hold the data. If size is NULL, zero the descriptor so that the
1099 callee will allocate the array. If DEALLOC is true, also generate code to
1100 free the array afterwards.
1101
1102 If INITIAL is not NULL, it is packed using internal_pack and the result used
1103 as data instead of allocating a fresh, unitialized area of memory.
1104
1105 Initialization code is added to PRE and finalization code to POST.
1106 DYNAMIC is true if the caller may want to extend the array later
1107 using realloc. This prevents us from putting the array on the stack. */
1108
1109static void
1110gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
1111 gfc_array_info * info, tree size, tree nelem,
1112 tree initial, bool dynamic, bool dealloc)
1113{
1114 tree tmp;
1115 tree desc;
1116 bool onstack;
1117
1118 desc = info->descriptor;
1119 info->offset = gfc_index_zero_nodegfc_rank_cst[0];
1120 if (size == NULL_TREE(tree) __null || integer_zerop (size))
1121 {
1122 /* A callee allocated array. */
1123 gfc_conv_descriptor_data_set (pre, desc, null_pointer_nodeglobal_trees[TI_NULL_POINTER]);
1124 onstack = FALSEfalse;
1125 }
1126 else
1127 {
1128 /* Allocate the temporary. */
1129 onstack = !dynamic && initial == NULL_TREE(tree) __null
1130 && (flag_stack_arraysglobal_options.x_flag_stack_arrays
1131 || gfc_can_put_var_on_stack (size));
1132
1133 if (onstack)
1134 {
1135 /* Make a temporary variable to hold the data. */
1136 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (nelem)((contains_struct_check ((nelem), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1136, __FUNCTION__))->typed.type),
1137 nelem, gfc_index_one_nodegfc_rank_cst[1]);
1138 tmp = gfc_evaluate_now (tmp, pre);
1139 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_nodegfc_rank_cst[0],
1140 tmp);
1141 tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)((contains_struct_check ((desc), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1141, __FUNCTION__))->typed.type)),
1142 tmp);
1143 tmp = gfc_create_var (tmp, "A");
1144 /* If we're here only because of -fstack-arrays we have to
1145 emit a DECL_EXPR to make the gimplifier emit alloca calls. */
1146 if (!gfc_can_put_var_on_stack (size))
1147 gfc_add_expr_to_block (pre,
1148 fold_build1_loc (input_location,
1149 DECL_EXPR, TREE_TYPE (tmp)((contains_struct_check ((tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1149, __FUNCTION__))->typed.type),
1150 tmp));
1151 tmp = gfc_build_addr_expr (NULL_TREE(tree) __null, tmp);
1152 gfc_conv_descriptor_data_set (pre, desc, tmp);
1153 }
1154 else
1155 {
1156 /* Allocate memory to hold the data or call internal_pack. */
1157 if (initial == NULL_TREE(tree) __null)
1158 {
1159 tmp = gfc_call_malloc (pre, NULL__null, size);
1160 tmp = gfc_evaluate_now (tmp, pre);
1161 }
1162 else
1163 {
1164 tree packed;
1165 tree source_data;
1166 tree was_packed;
1167 stmtblock_t do_copying;
1168
1169 tmp = TREE_TYPE (initial)((contains_struct_check ((initial), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1169, __FUNCTION__))->typed.type); /* Pointer to descriptor. */
1170 gcc_assert (TREE_CODE (tmp) == POINTER_TYPE)((void)(!(((enum tree_code) (tmp)->base.code) == POINTER_TYPE
) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1170, __FUNCTION__), 0 : 0));
1171 tmp = TREE_TYPE (tmp)((contains_struct_check ((tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1171, __FUNCTION__))->typed.type); /* The descriptor itself. */
1172 tmp = gfc_get_element_type (tmp);
1173 packed = gfc_create_var (build_pointer_type (tmp), "data");
1174
1175 tmp = build_call_expr_loc (input_location,
1176 gfor_fndecl_in_pack, 1, initial);
1177 tmp = fold_convert (TREE_TYPE (packed), tmp)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(packed), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1177, __FUNCTION__))->typed.type), tmp);
1178 gfc_add_modify (pre, packed, tmp);
1179
1180 tmp = build_fold_indirect_ref_loc (input_location,
1181 initial);
1182 source_data = gfc_conv_descriptor_data_get (tmp);
1183
1184 /* internal_pack may return source->data without any allocation
1185 or copying if it is already packed. If that's the case, we
1186 need to allocate and copy manually. */
1187
1188 gfc_start_block (&do_copying);
1189 tmp = gfc_call_malloc (&do_copying, NULL__null, size);
1190 tmp = fold_convert (TREE_TYPE (packed), tmp)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(packed), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1190, __FUNCTION__))->typed.type), tmp);
1191 gfc_add_modify (&do_copying, packed, tmp);
1192 tmp = gfc_build_memcpy_call (packed, source_data, size);
1193 gfc_add_expr_to_block (&do_copying, tmp);
1194
1195 was_packed = fold_build2_loc (input_location, EQ_EXPR,
1196 logical_type_node, packed,
1197 source_data);
1198 tmp = gfc_finish_block (&do_copying);
1199 tmp = build3_v (COND_EXPR, was_packed, tmp,fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], was_packed, tmp, build_empty_stmt (input_location))
1200 build_empty_stmt (input_location))fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], was_packed, tmp, build_empty_stmt (input_location));
1201 gfc_add_expr_to_block (pre, tmp);
1202
1203 tmp = fold_convert (pvoid_type_node, packed)fold_convert_loc (((location_t) 0), pvoid_type_node, packed);
1204 }
1205
1206 gfc_conv_descriptor_data_set (pre, desc, tmp);
1207 }
1208 }
1209 info->data = gfc_conv_descriptor_data_get (desc);
1210
1211 /* The offset is zero because we create temporaries with a zero
1212 lower bound. */
1213 gfc_conv_descriptor_offset_set (pre, desc, gfc_index_zero_nodegfc_rank_cst[0]);
1214
1215 if (dealloc && !onstack)
1216 {
1217 /* Free the temporary. */
1218 tmp = gfc_conv_descriptor_data_get (desc);
1219 tmp = gfc_call_free (tmp);
1220 gfc_add_expr_to_block (post, tmp);
1221 }
1222}
1223
1224
1225/* Get the scalarizer array dimension corresponding to actual array dimension
1226 given by ARRAY_DIM.
1227
1228 For example, if SS represents the array ref a(1,:,:,1), it is a
1229 bidimensional scalarizer array, and the result would be 0 for ARRAY_DIM=1,
1230 and 1 for ARRAY_DIM=2.
1231 If SS represents transpose(a(:,1,1,:)), it is again a bidimensional
1232 scalarizer array, and the result would be 1 for ARRAY_DIM=0 and 0 for
1233 ARRAY_DIM=3.
1234 If SS represents sum(a(:,:,:,1), dim=1), it is a 2+1-dimensional scalarizer
1235 array. If called on the inner ss, the result would be respectively 0,1,2 for
1236 ARRAY_DIM=0,1,2. If called on the outer ss, the result would be 0,1
1237 for ARRAY_DIM=1,2. */
1238
1239static int
1240get_scalarizer_dim_for_array_dim (gfc_ss *ss, int array_dim)
1241{
1242 int array_ref_dim;
1243 int n;
1244
1245 array_ref_dim = 0;
1246
1247 for (; ss; ss = ss->parent)
1248 for (n = 0; n < ss->dimen; n++)
1249 if (ss->dim[n] < array_dim)
1250 array_ref_dim++;
1251
1252 return array_ref_dim;
1253}
1254
1255
1256static gfc_ss *
1257innermost_ss (gfc_ss *ss)
1258{
1259 while (ss->nested_ss != NULL__null)
1260 ss = ss->nested_ss;
1261
1262 return ss;
1263}
1264
1265
1266
1267/* Get the array reference dimension corresponding to the given loop dimension.
1268 It is different from the true array dimension given by the dim array in
1269 the case of a partial array reference (i.e. a(:,:,1,:) for example)
1270 It is different from the loop dimension in the case of a transposed array.
1271 */
1272
1273static int
1274get_array_ref_dim_for_loop_dim (gfc_ss *ss, int loop_dim)
1275{
1276 return get_scalarizer_dim_for_array_dim (innermost_ss (ss),
1277 ss->dim[loop_dim]);
1278}
1279
1280
1281/* Use the information in the ss to obtain the required information about
1282 the type and size of an array temporary, when the lhs in an assignment
1283 is a class expression. */
1284
1285static tree
1286get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype)
1287{
1288 gfc_ss *lhs_ss;
1289 gfc_ss *rhs_ss;
1290 tree tmp;
1291 tree tmp2;
1292 tree vptr;
1293 tree rhs_class_expr = NULL_TREE(tree) __null;
1294 tree lhs_class_expr = NULL_TREE(tree) __null;
1295 bool unlimited_rhs = false;
1296 bool unlimited_lhs = false;
1297 bool rhs_function = false;
1298 gfc_symbol *vtab;
1299
1300 /* The second element in the loop chain contains the source for the
1301 temporary; ie. the rhs of the assignment. */
1302 rhs_ss = ss->loop->ss->loop_chain;
1303
1304 if (rhs_ss != gfc_ss_terminator
1305 && rhs_ss->info
1306 && rhs_ss->info->expr
1307 && rhs_ss->info->expr->ts.type == BT_CLASS
1308 && rhs_ss->info->data.array.descriptor)
1309 {
1310 if (rhs_ss->info->expr->expr_type != EXPR_VARIABLE)
1311 rhs_class_expr
1312 = gfc_get_class_from_expr (rhs_ss->info->data.array.descriptor);
1313 else
1314 rhs_class_expr = gfc_get_class_from_gfc_expr (rhs_ss->info->expr);
1315 unlimited_rhs = UNLIMITED_POLY (rhs_ss->info->expr)(rhs_ss->info->expr != __null && rhs_ss->info
->expr->ts.type == BT_CLASS && rhs_ss->info->
expr->ts.u.derived->components && rhs_ss->info
->expr->ts.u.derived->components->ts.u.derived &&
rhs_ss->info->expr->ts.u.derived->components->
ts.u.derived->attr.unlimited_polymorphic);
1316 if (rhs_ss->info->expr->expr_type == EXPR_FUNCTION)
1317 rhs_function = true;
1318 }
1319
1320 /* For an assignment the lhs is the next element in the loop chain.
1321 If we have a class rhs, this had better be a class variable
1322 expression! */
1323 lhs_ss = rhs_ss->loop_chain;
1324 if (lhs_ss != gfc_ss_terminator
1325 && lhs_ss->info
1326 && lhs_ss->info->expr
1327 && lhs_ss->info->expr->expr_type ==EXPR_VARIABLE
1328 && lhs_ss->info->expr->ts.type == BT_CLASS)
1329 {
1330 tmp = lhs_ss->info->data.array.descriptor;
1331 unlimited_lhs = UNLIMITED_POLY (rhs_ss->info->expr)(rhs_ss->info->expr != __null && rhs_ss->info
->expr->ts.type == BT_CLASS && rhs_ss->info->
expr->ts.u.derived->components && rhs_ss->info
->expr->ts.u.derived->components->ts.u.derived &&
rhs_ss->info->expr->ts.u.derived->components->
ts.u.derived->attr.unlimited_polymorphic);
1332 }
1333 else
1334 tmp = NULL_TREE(tree) __null;
1335
1336 /* Get the lhs class expression. */
1337 if (tmp != NULL_TREE(tree) __null && lhs_ss->loop_chain == gfc_ss_terminator)
1338 lhs_class_expr = gfc_get_class_from_expr (tmp);
1339 else
1340 return rhs_class_expr;
1341
1342 gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (lhs_class_expr)))((void)(!(((tree_class_check ((((contains_struct_check ((lhs_class_expr
), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1342, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1342, __FUNCTION__))->type_common.lang_flag_4)) ? fancy_abort
("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1342, __FUNCTION__), 0 : 0));
1343
1344 /* Set the lhs vptr and, if necessary, the _len field. */
1345 if (rhs_class_expr)
1346 {
1347 /* Both lhs and rhs are class expressions. */
1348 tmp = gfc_class_vptr_get (lhs_class_expr);
1349 gfc_add_modify (pre, tmp,
1350 fold_convert (TREE_TYPE (tmp),fold_convert_loc (((location_t) 0), ((contains_struct_check (
(tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1350, __FUNCTION__))->typed.type), gfc_class_vptr_get (rhs_class_expr
))
1351 gfc_class_vptr_get (rhs_class_expr))fold_convert_loc (((location_t) 0), ((contains_struct_check (
(tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1350, __FUNCTION__))->typed.type), gfc_class_vptr_get (rhs_class_expr
)));
1352 if (unlimited_lhs)
1353 {
1354 tmp = gfc_class_len_get (lhs_class_expr);
1355 if (unlimited_rhs)
1356 tmp2 = gfc_class_len_get (rhs_class_expr);
1357 else
1358 tmp2 = build_int_cst (TREE_TYPE (tmp)((contains_struct_check ((tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1358, __FUNCTION__))->typed.type), 0);
1359 gfc_add_modify (pre, tmp, tmp2);
1360 }
1361
1362 if (rhs_function)
1363 {
1364 tmp = gfc_class_data_get (rhs_class_expr);
1365 gfc_conv_descriptor_offset_set (pre, tmp, gfc_index_zero_nodegfc_rank_cst[0]);
1366 }
1367 }
1368 else
1369 {
1370 /* lhs is class and rhs is intrinsic or derived type. */
1371 *eltype = TREE_TYPE (rhs_ss->info->data.array.descriptor)((contains_struct_check ((rhs_ss->info->data.array.descriptor
), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1371, __FUNCTION__))->typed.type);
1372 *eltype = gfc_get_element_type (*eltype);
1373 vtab = gfc_find_vtab (&rhs_ss->info->expr->ts);
1374 vptr = vtab->backend_decl;
1375 if (vptr == NULL_TREE(tree) __null)
1376 vptr = gfc_get_symbol_decl (vtab);
1377 vptr = gfc_build_addr_expr (NULL_TREE(tree) __null, vptr);
1378 tmp = gfc_class_vptr_get (lhs_class_expr);
1379 gfc_add_modify (pre, tmp,
1380 fold_convert (TREE_TYPE (tmp), vptr)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1380, __FUNCTION__))->typed.type), vptr));
1381
1382 if (unlimited_lhs)
1383 {
1384 tmp = gfc_class_len_get (lhs_class_expr);
1385 if (rhs_ss->info
1386 && rhs_ss->info->expr
1387 && rhs_ss->info->expr->ts.type == BT_CHARACTER)
1388 tmp2 = build_int_cst (TREE_TYPE (tmp)((contains_struct_check ((tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1388, __FUNCTION__))->typed.type),
1389 rhs_ss->info->expr->ts.kind);
1390 else
1391 tmp2 = build_int_cst (TREE_TYPE (tmp)((contains_struct_check ((tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1391, __FUNCTION__))->typed.type), 0);
1392 gfc_add_modify (pre, tmp, tmp2);
1393 }
1394 }
1395
1396 return rhs_class_expr;
1397}
1398
1399
1400
1401/* Generate code to create and initialize the descriptor for a temporary
1402 array. This is used for both temporaries needed by the scalarizer, and
1403 functions returning arrays. Adjusts the loop variables to be
1404 zero-based, and calculates the loop bounds for callee allocated arrays.
1405 Allocate the array unless it's callee allocated (we have a callee
1406 allocated array if 'callee_alloc' is true, or if loop->to[n] is
1407 NULL_TREE for any n). Also fills in the descriptor, data and offset
1408 fields of info if known. Returns the size of the array, or NULL for a
1409 callee allocated array.
1410
1411 'eltype' == NULL signals that the temporary should be a class object.
1412 The 'initial' expression is used to obtain the size of the dynamic
1413 type; otherwise the allocation and initialization proceeds as for any
1414 other expression
1415
1416 PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
1417 gfc_trans_allocate_array_storage. */
1418
1419tree
1420gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
1421 tree eltype, tree initial, bool dynamic,
1422 bool dealloc, bool callee_alloc, locus * where)
1423{
1424 gfc_loopinfo *loop;
1425 gfc_ss *s;
1426 gfc_array_info *info;
1427 tree from[GFC_MAX_DIMENSIONS15], to[GFC_MAX_DIMENSIONS15];
1428 tree type;
1429 tree desc;
1430 tree tmp;
1431 tree size;
1432 tree nelem;
1433 tree cond;
1434 tree or_expr;
1435 tree elemsize;
1436 tree class_expr = NULL_TREE(tree) __null;
1437 int n, dim, tmp_dim;
1438 int total_dim = 0;
1439
1440 /* This signals a class array for which we need the size of the
1441 dynamic type. Generate an eltype and then the class expression. */
1442 if (eltype == NULL_TREE(tree) __null && initial)
1443 {
1444 gcc_assert (POINTER_TYPE_P (TREE_TYPE (initial)))((void)(!((((enum tree_code) (((contains_struct_check ((initial
), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1444, __FUNCTION__))->typed.type))->base.code) == POINTER_TYPE
|| ((enum tree_code) (((contains_struct_check ((initial), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1444, __FUNCTION__))->typed.type))->base.code) == REFERENCE_TYPE
)) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1444, __FUNCTION__), 0 : 0));
1445 class_expr = build_fold_indirect_ref_loc (input_location, initial);
1446 /* Obtain the structure (class) expression. */
1447 class_expr = gfc_get_class_from_expr (class_expr);
1448 gcc_assert (class_expr)((void)(!(class_expr) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1448, __FUNCTION__), 0 : 0));
1449 }
1450
1451 /* Otherwise, some expressions, such as class functions, arising from
1452 dependency checking in assignments come here with class element type.
1453 The descriptor can be obtained from the ss->info and then converted
1454 to the class object. */
1455 if (class_expr == NULL_TREE(tree) __null && GFC_CLASS_TYPE_P (eltype)((tree_class_check ((eltype), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1455, __FUNCTION__))->type_common.lang_flag_4))
1456 class_expr = get_class_info_from_ss (pre, ss, &eltype);
1457
1458 /* If the dynamic type is not available, use the declared type. */
1459 if (eltype && GFC_CLASS_TYPE_P (eltype)((tree_class_check ((eltype), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1459, __FUNCTION__))->type_common.lang_flag_4))
1460 eltype = gfc_get_element_type (TREE_TYPE (TYPE_FIELDS (eltype))((contains_struct_check ((((tree_check3 ((eltype), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1460, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values)), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1460, __FUNCTION__))->typed.type));
1461
1462 if (class_expr == NULL_TREE(tree) __null)
1463 elemsize = fold_convert (gfc_array_index_type,fold_convert_loc (((location_t) 0), gfc_array_index_type, ((tree_class_check
((eltype), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1464, __FUNCTION__))->type_common.size_unit))
1464 TYPE_SIZE_UNIT (eltype))fold_convert_loc (((location_t) 0), gfc_array_index_type, ((tree_class_check
((eltype), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1464, __FUNCTION__))->type_common.size_unit));
1465 else
1466 {
1467 /* Unlimited polymorphic entities are initialised with NULL vptr. They
1468 can be tested for by checking if the len field is present. If so
1469 test the vptr before using the vtable size. */
1470 tmp = gfc_class_vptr_get (class_expr);
1471 tmp = fold_build2_loc (input_location, NE_EXPR,
1472 logical_type_node,
1473 tmp, build_int_cst (TREE_TYPE (tmp)((contains_struct_check ((tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1473, __FUNCTION__))->typed.type), 0));
1474 elemsize = fold_build3_loc (input_location, COND_EXPR,
1475 gfc_array_index_type,
1476 tmp,
1477 gfc_class_vtab_size_get (class_expr),
1478 gfc_index_zero_nodegfc_rank_cst[0]);
1479 elemsize = gfc_evaluate_now (elemsize, pre);
1480 elemsize = gfc_resize_class_size_with_len (pre, class_expr, elemsize);
1481 /* Casting the data as a character of the dynamic length ensures that
1482 assignment of elements works when needed. */
1483 eltype = gfc_get_character_type_len (1, elemsize);
1484 }
1485
1486 memset (from, 0, sizeof (from));
1487 memset (to, 0, sizeof (to));
1488
1489 info = &ss->info->data.array;
1490
1491 gcc_assert (ss->dimen > 0)((void)(!(ss->dimen > 0) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1491, __FUNCTION__), 0 : 0));
1492 gcc_assert (ss->loop->dimen == ss->dimen)((void)(!(ss->loop->dimen == ss->dimen) ? fancy_abort
("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1492, __FUNCTION__), 0 : 0));
1493
1494 if (warn_array_temporariesglobal_options.x_warn_array_temporaries && where)
1495 gfc_warning (OPT_Warray_temporaries,
1496 "Creating array temporary at %L", where);
1497
1498 /* Set the lower bound to zero. */
1499 for (s = ss; s; s = s->parent)
1500 {
1501 loop = s->loop;
1502
1503 total_dim += loop->dimen;
1504 for (n = 0; n < loop->dimen; n++)
1505 {
1506 dim = s->dim[n];
1507
1508 /* Callee allocated arrays may not have a known bound yet. */
1509 if (loop->to[n])
1510 loop->to[n] = gfc_evaluate_now (
1511 fold_build2_loc (input_location, MINUS_EXPR,
1512 gfc_array_index_type,
1513 loop->to[n], loop->from[n]),
1514 pre);
1515 loop->from[n] = gfc_index_zero_nodegfc_rank_cst[0];
1516
1517 /* We have just changed the loop bounds, we must clear the
1518 corresponding specloop, so that delta calculation is not skipped
1519 later in gfc_set_delta. */
1520 loop->specloop[n] = NULL__null;
1521
1522 /* We are constructing the temporary's descriptor based on the loop
1523 dimensions. As the dimensions may be accessed in arbitrary order
1524 (think of transpose) the size taken from the n'th loop may not map
1525 to the n'th dimension of the array. We need to reconstruct loop
1526 infos in the right order before using it to set the descriptor
1527 bounds. */
1528 tmp_dim = get_scalarizer_dim_for_array_dim (ss, dim);
1529 from[tmp_dim] = loop->from[n];
1530 to[tmp_dim] = loop->to[n];
1531
1532 info->delta[dim] = gfc_index_zero_nodegfc_rank_cst[0];
1533 info->start[dim] = gfc_index_zero_nodegfc_rank_cst[0];
1534 info->end[dim] = gfc_index_zero_nodegfc_rank_cst[0];
1535 info->stride[dim] = gfc_index_one_nodegfc_rank_cst[1];
1536 }
1537 }
1538
1539 /* Initialize the descriptor. */
1540 type =
1541 gfc_get_array_type_bounds (eltype, total_dim, 0, from, to, 1,
1542 GFC_ARRAY_UNKNOWN, true);
1543 desc = gfc_create_var (type, "atmp");
1544 GFC_DECL_PACKED_ARRAY (desc)((contains_struct_check ((desc), (TS_DECL_COMMON), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1544, __FUNCTION__))->decl_common.lang_flag_0) = 1;
1545
1546 /* Emit a DECL_EXPR for the variable sized array type in
1547 GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
1548 sizes works correctly. */
1549 tree arraytype = TREE_TYPE (GFC_TYPE_ARRAY_DATAPTR_TYPE (type))((contains_struct_check (((((tree_class_check ((type), (tcc_type
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1549, __FUNCTION__))->type_with_lang_specific.lang_specific
)->dataptr_type)), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1549, __FUNCTION__))->typed.type);
1550 if (! TYPE_NAME (arraytype)((tree_class_check ((arraytype), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1550, __FUNCTION__))->type_common.name))
1551 TYPE_NAME (arraytype)((tree_class_check ((arraytype), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1551, __FUNCTION__))->type_common.name) = build_decl (UNKNOWN_LOCATION((location_t) 0), TYPE_DECL,
1552 NULL_TREE(tree) __null, arraytype);
1553 gfc_add_expr_to_block (pre, build1 (DECL_EXPR,
1554 arraytype, TYPE_NAME (arraytype)((tree_class_check ((arraytype), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1554, __FUNCTION__))->type_common.name)));
1555
1556 if (class_expr != NULL_TREE(tree) __null)
1557 {
1558 tree class_data;
1559 tree dtype;
1560
1561 /* Create a class temporary. */
1562 tmp = gfc_create_var (TREE_TYPE (class_expr)((contains_struct_check ((class_expr), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1562, __FUNCTION__))->typed.type), "ctmp");
1563 gfc_add_modify (pre, tmp, class_expr);
1564
1565 /* Assign the new descriptor to the _data field. This allows the
1566 vptr _copy to be used for scalarized assignment since the class
1567 temporary can be found from the descriptor. */
1568 class_data = gfc_class_data_get (tmp);
1569 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1570 TREE_TYPE (desc)((contains_struct_check ((desc), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1570, __FUNCTION__))->typed.type), desc);
1571 gfc_add_modify (pre, class_data, tmp);
1572
1573 /* Take the dtype from the class expression. */
1574 dtype = gfc_conv_descriptor_dtype (gfc_class_data_get (class_expr));
1575 tmp = gfc_conv_descriptor_dtype (class_data);
1576 gfc_add_modify (pre, tmp, dtype);
1577
1578 /* Point desc to the class _data field. */
1579 desc = class_data;
1580 }
1581 else
1582 {
1583 /* Fill in the array dtype. */
1584 tmp = gfc_conv_descriptor_dtype (desc);
1585 gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)((contains_struct_check ((desc), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1585, __FUNCTION__))->typed.type)));
1586 }
1587
1588 info->descriptor = desc;
1589 size = gfc_index_one_nodegfc_rank_cst[1];
1590
1591 /*
1592 Fill in the bounds and stride. This is a packed array, so:
1593
1594 size = 1;
1595 for (n = 0; n < rank; n++)
1596 {
1597 stride[n] = size
1598 delta = ubound[n] + 1 - lbound[n];
1599 size = size * delta;
1600 }
1601 size = size * sizeof(element);
1602 */
1603
1604 or_expr = NULL_TREE(tree) __null;
1605
1606 /* If there is at least one null loop->to[n], it is a callee allocated
1607 array. */
1608 for (n = 0; n < total_dim; n++)
1609 if (to[n] == NULL_TREE(tree) __null)
1610 {
1611 size = NULL_TREE(tree) __null;
1612 break;
1613 }
1614
1615 if (size == NULL_TREE(tree) __null)
1616 for (s = ss; s; s = s->parent)
1617 for (n = 0; n < s->loop->dimen; n++)
1618 {
1619 dim = get_scalarizer_dim_for_array_dim (ss, s->dim[n]);
1620
1621 /* For a callee allocated array express the loop bounds in terms
1622 of the descriptor fields. */
1623 tmp = fold_build2_loc (input_location,
1624 MINUS_EXPR, gfc_array_index_type,
1625 gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]),
1626 gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]));
1627 s->loop->to[n] = tmp;
1628 }
1629 else
1630 {
1631 for (n = 0; n < total_dim; n++)
1632 {
1633 /* Store the stride and bound components in the descriptor. */
1634 gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size);
1635
1636 gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n],
1637 gfc_index_zero_nodegfc_rank_cst[0]);
1638
1639 gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], to[n]);
1640
1641 tmp = fold_build2_loc (input_location, PLUS_EXPR,
1642 gfc_array_index_type,
1643 to[n], gfc_index_one_nodegfc_rank_cst[1]);
1644
1645 /* Check whether the size for this dimension is negative. */
1646 cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
1647 tmp, gfc_index_zero_nodegfc_rank_cst[0]);
1648 cond = gfc_evaluate_now (cond, pre);
1649
1650 if (n == 0)
1651 or_expr = cond;
1652 else
1653 or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1654 logical_type_node, or_expr, cond);
1655
1656 size = fold_build2_loc (input_location, MULT_EXPR,
1657 gfc_array_index_type, size, tmp);
1658 size = gfc_evaluate_now (size, pre);
1659 }
1660 }
1661
1662 /* Get the size of the array. */
1663 if (size && !callee_alloc)
1664 {
1665 /* If or_expr is true, then the extent in at least one
1666 dimension is zero and the size is set to zero. */
1667 size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
1668 or_expr, gfc_index_zero_nodegfc_rank_cst[0], size);
1669
1670 nelem = size;
1671 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
1672 size, elemsize);
1673 }
1674 else
1675 {
1676 nelem = size;
1677 size = NULL_TREE(tree) __null;
1678 }
1679
1680 /* Set the span. */
1681 tmp = fold_convert (gfc_array_index_type, elemsize)fold_convert_loc (((location_t) 0), gfc_array_index_type, elemsize
);
1682 gfc_conv_descriptor_span_set (pre, desc, tmp);
1683
1684 gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial,
1685 dynamic, dealloc);
1686
1687 while (ss->parent)
1688 ss = ss->parent;
1689
1690 if (ss->dimen > ss->loop->temp_dim)
1691 ss->loop->temp_dim = ss->dimen;
1692
1693 return size;
1694}
1695
1696
1697/* Return the number of iterations in a loop that starts at START,
1698 ends at END, and has step STEP. */
1699
1700static tree
1701gfc_get_iteration_count (tree start, tree end, tree step)
1702{
1703 tree tmp;
1704 tree type;
1705
1706 type = TREE_TYPE (step)((contains_struct_check ((step), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1706, __FUNCTION__))->typed.type);
1707 tmp = fold_build2_loc (input_location, MINUS_EXPR, type, end, start);
1708 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, type, tmp, step);
1709 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp,
1710 build_int_cst (type, 1));
1711 tmp = fold_build2_loc (input_location, MAX_EXPR, type, tmp,
1712 build_int_cst (type, 0));
1713 return fold_convert (gfc_array_index_type, tmp)fold_convert_loc (((location_t) 0), gfc_array_index_type, tmp
);
1714}
1715
1716
1717/* Extend the data in array DESC by EXTRA elements. */
1718
1719static void
1720gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
1721{
1722 tree arg0, arg1;
1723 tree tmp;
1724 tree size;
1725 tree ubound;
1726
1727 if (integer_zerop (extra))
1728 return;
1729
1730 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);
1731
1732 /* Add EXTRA to the upper bound. */
1733 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1734 ubound, extra);
1735 gfc_conv_descriptor_ubound_set (pblock, desc, gfc_rank_cst[0], tmp);
1736
1737 /* Get the value of the current data pointer. */
1738 arg0 = gfc_conv_descriptor_data_get (desc);
1739
1740 /* Calculate the new array size. */
1741 size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)))((tree_class_check ((gfc_get_element_type (((contains_struct_check
((desc), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1741, __FUNCTION__))->typed.type))), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1741, __FUNCTION__))->type_common.size_unit);
1742 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1743 ubound, gfc_index_one_nodegfc_rank_cst[1]);
1744 arg1 = fold_build2_loc (input_location, MULT_EXPR, size_type_nodeglobal_trees[TI_SIZE_TYPE],
1745 fold_convert (size_type_node, tmp)fold_convert_loc (((location_t) 0), global_trees[TI_SIZE_TYPE
], tmp),
1746 fold_convert (size_type_node, size)fold_convert_loc (((location_t) 0), global_trees[TI_SIZE_TYPE
], size));
1747
1748 /* Call the realloc() function. */
1749 tmp = gfc_call_realloc (pblock, arg0, arg1);
1750 gfc_conv_descriptor_data_set (pblock, desc, tmp);
1751}
1752
1753
1754/* Return true if the bounds of iterator I can only be determined
1755 at run time. */
1756
1757static inline bool
1758gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
1759{
1760 return (i->start->expr_type != EXPR_CONSTANT
1761 || i->end->expr_type != EXPR_CONSTANT
1762 || i->step->expr_type != EXPR_CONSTANT);
1763}
1764
1765
1766/* Split the size of constructor element EXPR into the sum of two terms,
1767 one of which can be determined at compile time and one of which must
1768 be calculated at run time. Set *SIZE to the former and return true
1769 if the latter might be nonzero. */
1770
1771static bool
1772gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
1773{
1774 if (expr->expr_type == EXPR_ARRAY)
1775 return gfc_get_array_constructor_size (size, expr->value.constructor);
1776 else if (expr->rank > 0)
1777 {
1778 /* Calculate everything at run time. */
1779 mpz_set_ui__gmpz_set_ui (*size, 0);
1780 return true;
1781 }
1782 else
1783 {
1784 /* A single element. */
1785 mpz_set_ui__gmpz_set_ui (*size, 1);
1786 return false;
1787 }
1788}
1789
1790
1791/* Like gfc_get_array_constructor_element_size, but applied to the whole
1792 of array constructor C. */
1793
1794static bool
1795gfc_get_array_constructor_size (mpz_t * size, gfc_constructor_base base)
1796{
1797 gfc_constructor *c;
1798 gfc_iterator *i;
1799 mpz_t val;
1800 mpz_t len;
1801 bool dynamic;
1802
1803 mpz_set_ui__gmpz_set_ui (*size, 0);
1804 mpz_init__gmpz_init (len);
1805 mpz_init__gmpz_init (val);
1806
1807 dynamic = false;
1808 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1809 {
1810 i = c->iterator;
1811 if (i && gfc_iterator_has_dynamic_bounds (i))
1812 dynamic = true;
1813 else
1814 {
1815 dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
1816 if (i)
1817 {
1818 /* Multiply the static part of the element size by the
1819 number of iterations. */
1820 mpz_sub__gmpz_sub (val, i->end->value.integer, i->start->value.integer);
1821 mpz_fdiv_q__gmpz_fdiv_q (val, val, i->step->value.integer);
1822 mpz_add_ui__gmpz_add_ui (val, val, 1);
1823 if (mpz_sgn (val)((val)->_mp_size < 0 ? -1 : (val)->_mp_size > 0) > 0)
1824 mpz_mul__gmpz_mul (len, len, val);
1825 else
1826 mpz_set_ui__gmpz_set_ui (len, 0);
1827 }
1828 mpz_add__gmpz_add (*size, *size, len);
1829 }
1830 }
1831 mpz_clear__gmpz_clear (len);
1832 mpz_clear__gmpz_clear (val);
1833 return dynamic;
1834}
1835
1836
1837/* Make sure offset is a variable. */
1838
1839static void
1840gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
1841 tree * offsetvar)
1842{
1843 /* We should have already created the offset variable. We cannot
1844 create it here because we may be in an inner scope. */
1845 gcc_assert (*offsetvar != NULL_TREE)((void)(!(*offsetvar != (tree) __null) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1845, __FUNCTION__), 0 : 0));
1846 gfc_add_modify (pblock, *offsetvar, *poffset);
1847 *poffset = *offsetvar;
1848 TREE_USED (*offsetvar)((*offsetvar)->base.used_flag) = 1;
1849}
1850
1851
1852/* Variables needed for bounds-checking. */
1853static bool first_len;
1854static tree first_len_val;
1855static bool typespec_chararray_ctor;
1856
1857static void
1858gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
1859 tree offset, gfc_se * se, gfc_expr * expr)
1860{
1861 tree tmp;
1862
1863 gfc_conv_expr (se, expr);
1864
1865 /* Store the value. */
1866 tmp = build_fold_indirect_ref_loc (input_location,
1867 gfc_conv_descriptor_data_get (desc));
1868 tmp = gfc_build_array_ref (tmp, offset, NULL__null);
1869
1870 if (expr->ts.type == BT_CHARACTER)
1871 {
1872 int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
1873 tree esize;
1874
1875 esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc)((contains_struct_check ((desc), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1875, __FUNCTION__))->typed.type)));
1876 esize = fold_convert (gfc_charlen_type_node, esize)fold_convert_loc (((location_t) 0), gfc_charlen_type_node, esize
);
1877 esize = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
1878 TREE_TYPE (esize)((contains_struct_check ((esize), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1878, __FUNCTION__))->typed.type), esize,
1879 build_int_cst (TREE_TYPE (esize)((contains_struct_check ((esize), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1879, __FUNCTION__))->typed.type),
1880 gfc_character_kinds[i].bit_size / 8));
1881
1882 gfc_conv_string_parameter (se);
1883 if (POINTER_TYPE_P (TREE_TYPE (tmp))(((enum tree_code) (((contains_struct_check ((tmp), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1883, __FUNCTION__))->typed.type))->base.code) == POINTER_TYPE
|| ((enum tree_code) (((contains_struct_check ((tmp), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1883, __FUNCTION__))->typed.type))->base.code) == REFERENCE_TYPE
))
1884 {
1885 /* The temporary is an array of pointers. */
1886 se->expr = fold_convert (TREE_TYPE (tmp), se->expr)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1886, __FUNCTION__))->typed.type), se->expr);
1887 gfc_add_modify (&se->pre, tmp, se->expr);
1888 }
1889 else
1890 {
1891 /* The temporary is an array of string values. */
1892 tmp = gfc_build_addr_expr (gfc_get_pchar_type (expr->ts.kind), tmp);
1893 /* We know the temporary and the value will be the same length,
1894 so can use memcpy. */
1895 gfc_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind,
1896 se->string_length, se->expr, expr->ts.kind);
1897 }
1898 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS(1<<0)) && !typespec_chararray_ctor)
1899 {
1900 if (first_len)
1901 {
1902 gfc_add_modify (&se->pre, first_len_val,
1903 fold_convert (TREE_TYPE (first_len_val),fold_convert_loc (((location_t) 0), ((contains_struct_check (
(first_len_val), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1903, __FUNCTION__))->typed.type), se->string_length)
1904 se->string_length)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(first_len_val), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1903, __FUNCTION__))->typed.type), se->string_length));
1905 first_len = false;
1906 }
1907 else
1908 {
1909 /* Verify that all constructor elements are of the same
1910 length. */
1911 tree rhs = fold_convert (TREE_TYPE (first_len_val),fold_convert_loc (((location_t) 0), ((contains_struct_check (
(first_len_val), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1911, __FUNCTION__))->typed.type), se->string_length)
1912 se->string_length)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(first_len_val), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1911, __FUNCTION__))->typed.type), se->string_length);
1913 tree cond = fold_build2_loc (input_location, NE_EXPR,
1914 logical_type_node, first_len_val,
1915 rhs);
1916 gfc_trans_runtime_check
1917 (true, false, cond, &se->pre, &expr->where,
1918 "Different CHARACTER lengths (%ld/%ld) in array constructor",
1919 fold_convert (long_integer_type_node, first_len_val)fold_convert_loc (((location_t) 0), integer_types[itk_long], first_len_val
),
1920 fold_convert (long_integer_type_node, se->string_length)fold_convert_loc (((location_t) 0), integer_types[itk_long], se
->string_length));
1921 }
1922 }
1923 }
1924 else if (GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))((tree_class_check ((((contains_struct_check ((se->expr), (
TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1924, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1924, __FUNCTION__))->type_common.lang_flag_4)
1925 && !GFC_CLASS_TYPE_P (gfc_get_element_type (TREE_TYPE (desc)))((tree_class_check ((gfc_get_element_type (((contains_struct_check
((desc), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1925, __FUNCTION__))->typed.type))), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1925, __FUNCTION__))->type_common.lang_flag_4))
1926 {
1927 /* Assignment of a CLASS array constructor to a derived type array. */
1928 if (expr->expr_type == EXPR_FUNCTION)
1929 se->expr = gfc_evaluate_now (se->expr, pblock);
1930 se->expr = gfc_class_data_get (se->expr);
1931 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
1932 se->expr = fold_convert (TREE_TYPE (tmp), se->expr)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1932, __FUNCTION__))->typed.type), se->expr);
1933 gfc_add_modify (&se->pre, tmp, se->expr);
1934 }
1935 else
1936 {
1937 /* TODO: Should the frontend already have done this conversion? */
1938 se->expr = fold_convert (TREE_TYPE (tmp), se->expr)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1938, __FUNCTION__))->typed.type), se->expr);
1939 gfc_add_modify (&se->pre, tmp, se->expr);
1940 }
1941
1942 gfc_add_block_to_block (pblock, &se->pre);
1943 gfc_add_block_to_block (pblock, &se->post);
1944}
1945
1946
1947/* Add the contents of an array to the constructor. DYNAMIC is as for
1948 gfc_trans_array_constructor_value. */
1949
1950static void
1951gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
1952 tree type ATTRIBUTE_UNUSED__attribute__ ((__unused__)),
1953 tree desc, gfc_expr * expr,
1954 tree * poffset, tree * offsetvar,
1955 bool dynamic)
1956{
1957 gfc_se se;
1958 gfc_ss *ss;
1959 gfc_loopinfo loop;
1960 stmtblock_t body;
1961 tree tmp;
1962 tree size;
1963 int n;
1964
1965 /* We need this to be a variable so we can increment it. */
1966 gfc_put_offset_into_var (pblock, poffset, offsetvar);
1967
1968 gfc_init_se (&se, NULL__null);
1969
1970 /* Walk the array expression. */
1971 ss = gfc_walk_expr (expr);
1972 gcc_assert (ss != gfc_ss_terminator)((void)(!(ss != gfc_ss_terminator) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 1972, __FUNCTION__), 0 : 0));
1
Assuming 'ss' is not equal to 'gfc_ss_terminator'
→
2
←
'?' condition is false
→
1973
1974 /* Initialize the scalarizer. */
1975 gfc_init_loopinfo (&loop);
1976 gfc_add_ss_to_loop (&loop, ss);
1977
1978 /* Initialize the loop. */
1979 gfc_conv_ss_startstride (&loop);
1980 gfc_conv_loop_setup (&loop, &expr->where);
3
←
Calling 'gfc_conv_loop_setup'
→
1981
1982 /* Make sure the constructed array has room for the new data. */
1983 if (dynamic)
1984 {
1985 /* Set SIZE to the total number of elements in the subarray. */
1986 size = gfc_index_one_nodegfc_rank_cst[1];
1987 for (n = 0; n < loop.dimen; n++)
1988 {
1989 tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
1990 gfc_index_one_nodegfc_rank_cst[1]);
1991 size = fold_build2_loc (input_location, MULT_EXPR,
1992 gfc_array_index_type, size, tmp);
1993 }
1994
1995 /* Grow the constructed array by SIZE elements. */
1996 gfc_grow_array (&loop.pre, desc, size);
1997 }
1998
1999 /* Make the loop body. */
2000 gfc_mark_ss_chain_used (ss, 1);
2001 gfc_start_scalarized_body (&loop, &body);
2002 gfc_copy_loopinfo_to_se (&se, &loop);
2003 se.ss = ss;
2004
2005 gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
2006 gcc_assert (se.ss == gfc_ss_terminator)((void)(!(se.ss == gfc_ss_terminator) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 2006, __FUNCTION__), 0 : 0));
2007
2008 /* Increment the offset. */
2009 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2010 *poffset, gfc_index_one_nodegfc_rank_cst[1]);
2011 gfc_add_modify (&body, *poffset, tmp);
2012
2013 /* Finish the loop. */
2014 gfc_trans_scalarizing_loops (&loop, &body);
2015 gfc_add_block_to_block (&loop.pre, &loop.post);
2016 tmp = gfc_finish_block (&loop.pre);
2017 gfc_add_expr_to_block (pblock, tmp);
2018
2019 gfc_cleanup_loop (&loop);
2020}
2021
2022
2023/* Assign the values to the elements of an array constructor. DYNAMIC
2024 is true if descriptor DESC only contains enough data for the static
2025 size calculated by gfc_get_array_constructor_size. When true, memory
2026 for the dynamic parts must be allocated using realloc. */
2027
2028static void
2029gfc_trans_array_constructor_value (stmtblock_t * pblock,
2030 stmtblock_t * finalblock,
2031 tree type, tree desc,
2032 gfc_constructor_base base, tree * poffset,
2033 tree * offsetvar, bool dynamic)
2034{
2035 tree tmp;
2036 tree start = NULL_TREE(tree) __null;
2037 tree end = NULL_TREE(tree) __null;
2038 tree step = NULL_TREE(tree) __null;
2039 stmtblock_t body;
2040 gfc_se se;
2041 mpz_t size;
2042 gfc_constructor *c;
2043 gfc_typespec ts;
2044 int ctr = 0;
2045
2046 tree shadow_loopvar = NULL_TREE(tree) __null;
2047 gfc_saved_var saved_loopvar;
2048
2049 ts.type = BT_UNKNOWN;
2050 mpz_init__gmpz_init (size);
2051 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
2052 {
2053 ctr++;
2054 /* If this is an iterator or an array, the offset must be a variable. */
2055 if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset)(((enum tree_code) (*poffset)->base.code) == INTEGER_CST))
2056 gfc_put_offset_into_var (pblock, poffset, offsetvar);
2057
2058 /* Shadowing the iterator avoids changing its value and saves us from
2059 keeping track of it. Further, it makes sure that there's always a
2060 backend-decl for the symbol, even if there wasn't one before,
2061 e.g. in the case of an iterator that appears in a specification
2062 expression in an interface mapping. */
2063 if (c->iterator)
2064 {
2065 gfc_symbol *sym;
2066 tree type;
2067
2068 /* Evaluate loop bounds before substituting the loop variable
2069 in case they depend on it. Such a case is invalid, but it is
2070 not more expensive to do the right thing here.
2071 See PR 44354. */
2072 gfc_init_se (&se, NULL__null);
2073 gfc_conv_expr_val (&se, c->iterator->start);
2074 gfc_add_block_to_block (pblock, &se.pre);
2075 start = gfc_evaluate_now (se.expr, pblock);
2076
2077 gfc_init_se (&se, NULL__null);
2078 gfc_conv_expr_val (&se, c->iterator->end);
2079 gfc_add_block_to_block (pblock, &se.pre);
2080 end = gfc_evaluate_now (se.expr, pblock);
2081
2082 gfc_init_se (&se, NULL__null);
2083 gfc_conv_expr_val (&se, c->iterator->step);
2084 gfc_add_block_to_block (pblock, &se.pre);
2085 step = gfc_evaluate_now (se.expr, pblock);
2086
2087 sym = c->iterator->var->symtree->n.sym;
2088 type = gfc_typenode_for_spec (&sym->ts);
2089
2090 shadow_loopvar = gfc_create_var (type, "shadow_loopvar");
2091 gfc_shadow_sym (sym, shadow_loopvar, &saved_loopvar);
2092 }
2093
2094 gfc_start_block (&body);
2095
2096 if (c->expr->expr_type == EXPR_ARRAY)
2097 {
2098 /* Array constructors can be nested. */
2099 gfc_trans_array_constructor_value (&body, finalblock, type,
2100 desc, c->expr->value.constructor,
2101 poffset, offsetvar, dynamic);
2102 }
2103 else if (c->expr->rank > 0)
2104 {
2105 gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
2106 poffset, offsetvar, dynamic);
2107 }
2108 else
2109 {
2110 /* This code really upsets the gimplifier so don't bother for now. */
2111 gfc_constructor *p;
2112 HOST_WIDE_INTlong n;
2113 HOST_WIDE_INTlong size;
2114
2115 p = c;
2116 n = 0;
2117 while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
2118 {
2119 p = gfc_constructor_next (p);
2120 n++;
2121 }
2122 if (n < 4)
2123 {
2124 /* Scalar values. */
2125 gfc_init_se (&se, NULL__null);
2126 gfc_trans_array_ctor_element (&body, desc, *poffset,
2127 &se, c->expr);
2128
2129 *poffset = fold_build2_loc (input_location, PLUS_EXPR,
2130 gfc_array_index_type,
2131 *poffset, gfc_index_one_nodegfc_rank_cst[1]);
2132 }
2133 else
2134 {
2135 /* Collect multiple scalar constants into a constructor. */
2136 vec<constructor_elt, va_gc> *v = NULL__null;
2137 tree init;
2138 tree bound;
2139 tree tmptype;
2140 HOST_WIDE_INTlong idx = 0;
2141
2142 p = c;
2143 /* Count the number of consecutive scalar constants. */
2144 while (p && !(p->iterator
2145 || p->expr->expr_type != EXPR_CONSTANT))
2146 {
2147 gfc_init_se (&se, NULL__null);
2148 gfc_conv_constant (&se, p->expr);
2149
2150 if (c->expr->ts.type != BT_CHARACTER)
2151 se.expr = fold_convert (type, se.expr)fold_convert_loc (((location_t) 0), type, se.expr);
2152 /* For constant character array constructors we build
2153 an array of pointers. */
2154 else if (POINTER_TYPE_P (type)(((enum tree_code) (type)->base.code) == POINTER_TYPE || (
(enum tree_code) (type)->base.code) == REFERENCE_TYPE))
2155 se.expr = gfc_build_addr_expr
2156 (gfc_get_pchar_type (p->expr->ts.kind),
2157 se.expr);
2158
2159 CONSTRUCTOR_APPEND_ELT (v,do { constructor_elt _ce___ = {build_int_cst (gfc_array_index_type
, idx++), se.expr}; vec_safe_push ((v), _ce___); } while (0)
2160 build_int_cst (gfc_array_index_type,do { constructor_elt _ce___ = {build_int_cst (gfc_array_index_type
, idx++), se.expr}; vec_safe_push ((v), _ce___); } while (0)
2161 idx++),do { constructor_elt _ce___ = {build_int_cst (gfc_array_index_type
, idx++), se.expr}; vec_safe_push ((v), _ce___); } while (0)
2162 se.expr)do { constructor_elt _ce___ = {build_int_cst (gfc_array_index_type
, idx++), se.expr}; vec_safe_push ((v), _ce___); } while (0);
2163 c = p;
2164 p = gfc_constructor_next (p);
2165 }
2166
2167 bound = size_int (n - 1)size_int_kind (n - 1, stk_sizetype);
2168 /* Create an array type to hold them. */
2169 tmptype = build_range_type (gfc_array_index_type,
2170 gfc_index_zero_nodegfc_rank_cst[0], bound);
2171 tmptype = build_array_type (type, tmptype);
2172
2173 init = build_constructor (tmptype, v);
2174 TREE_CONSTANT (init)((non_type_check ((init), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 2174, __FUNCTION__))->base.constant_flag) = 1;
2175 TREE_STATIC (init)((init)->base.static_flag) = 1;
2176 /* Create a static variable to hold the data. */
2177 tmp = gfc_create_var (tmptype, "data");
2178 TREE_STATIC (tmp)((tmp)->base.static_flag) = 1;
2179 TREE_CONSTANT (tmp)((non_type_check ((tmp), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 2179, __FUNCTION__))->base.constant_flag) = 1;
2180 TREE_READONLY (tmp)((non_type_check ((tmp), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 2180, __FUNCTION__))->base.readonly_flag) = 1;
2181 DECL_INITIAL (tmp)((contains_struct_check ((tmp), (TS_DECL_COMMON), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 2181, __FUNCTION__))->decl_common.initial) = init;
2182 init = tmp;
2183
2184 /* Use BUILTIN_MEMCPY to assign the values. */
2185 tmp = gfc_conv_descriptor_data_get (desc);
2186 tmp = build_fold_indirect_ref_loc (input_location,
2187 tmp);
2188 tmp = gfc_build_array_ref (tmp, *poffset, NULL__null);
2189 tmp = gfc_build_addr_expr (NULL_TREE(tree) __null, tmp);
2190 init = gfc_build_addr_expr (NULL_TREE(tree) __null, init);
2191
2192 size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type))((unsigned long) (*tree_int_cst_elt_check ((((tree_class_check
((type), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 2192, __FUNCTION__))->type_common.size_unit)), (0), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 2192, __FUNCTION__)));
2193 bound = build_int_cst (size_type_nodeglobal_trees[TI_SIZE_TYPE], n * size);
2194 tmp = build_call_expr_loc (input_location,
2195 builtin_decl_explicit (BUILT_IN_MEMCPY),
2196 3, tmp, init, bound);
2197 gfc_add_expr_to_block (&body, tmp);
2198
2199 *poffset = fold_build2_loc (input_location, PLUS_EXPR,
2200 gfc_array_index_type, *poffset,
2201 build_int_cst (gfc_array_index_type, n));
2202 }
2203 if (!INTEGER_CST_P (*poffset)(((enum tree_code) (*poffset)->base.code) == INTEGER_CST))
2204 {
2205 gfc_add_modify (&body, *offsetvar, *poffset);
2206 *poffset = *offsetvar;
2207 }
2208
2209 if (!c->iterator)
2210 ts = c->expr->ts;
2211 }
2212
2213 /* The frontend should already have done any expansions
2214 at compile-time. */
2215 if (!c->iterator)
2216 {
2217 /* Pass the code as is. */
2218 tmp = gfc_finish_block (&body);
2219 gfc_add_expr_to_block (pblock, tmp);
2220 }
2221 else
2222 {
2223 /* Build the implied do-loop. */
2224 stmtblock_t implied_do_block;
2225 tree cond;
2226 tree exit_label;
2227 tree loopbody;
2228 tree tmp2;
2229
2230 loopbody = gfc_finish_block (&body);
2231
2232 /* Create a new block that holds the implied-do loop. A temporary
2233 loop-variable is used. */
2234 gfc_start_block(&implied_do_block);
2235
2236 /* Initialize the loop. */
2237 gfc_add_modify (&implied_do_block, shadow_loopvar, start);
2238
2239 /* If this array expands dynamically, and the number of iterations
2240 is not constant, we won't have allocated space for the static
2241 part of C->EXPR's size. Do that now. */
2242 if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
2243 {
2244 /* Get the number of iterations. */
2245 tmp = gfc_get_iteration_count (shadow_loopvar, end, step);
2246
2247 /* Get the static part of C->EXPR's size. */
2248 gfc_get_array_constructor_element_size (&size, c->expr);
2249 tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
2250
2251 /* Grow the array by TMP * TMP2 elements. */
2252 tmp = fold_build2_loc (input_location, MULT_EXPR,
2253 gfc_array_index_type, tmp, tmp2);
2254 gfc_grow_array (&implied_do_block, desc, tmp);
2255 }
2256
2257 /* Generate the loop body. */
2258 exit_label = gfc_build_label_decl (NULL_TREE(tree) __null);
2259 gfc_start_block (&body);
2260
2261 /* Generate the exit condition. Depending on the sign of
2262 the step variable we have to generate the correct
2263 comparison. */
2264 tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2265 step, build_int_cst (TREE_TYPE (step)((contains_struct_check ((step), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 2265, __FUNCTION__))->typed.type), 0));
2266 cond = fold_build3_loc (input_location, COND_EXPR,
2267 logical_type_node, tmp,
2268 fold_build2_loc (input_location, GT_EXPR,
2269 logical_type_node, shadow_loopvar, end),
2270 fold_build2_loc (input_location, LT_EXPR,
2271 logical_type_node, shadow_loopvar, end));
2272 tmp = build1_v (GOTO_EXPR, exit_label)fold_build1_loc (input_location, GOTO_EXPR, global_trees[TI_VOID_TYPE
], exit_label);
2273 TREE_USED (exit_label)((exit_label)->base.used_flag) = 1;
2274 tmp = build3_v (COND_EXPR, cond, tmp,fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], cond, tmp, build_empty_stmt (input_location))
2275 build_empty_stmt (input_location))fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], cond, tmp, build_empty_stmt (input_location));
2276 gfc_add_expr_to_block (&body, tmp);
2277
2278 /* The main loop body. */
2279 gfc_add_expr_to_block (&body, loopbody);
2280
2281 /* Increase loop variable by step. */
2282 tmp = fold_build2_loc (input_location, PLUS_EXPR,
2283 TREE_TYPE (shadow_loopvar)((contains_struct_check ((shadow_loopvar), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 2283, __FUNCTION__))->typed.type), shadow_loopvar,
2284 step);
2285 gfc_add_modify (&body, shadow_loopvar, tmp);
2286
2287 /* Finish the loop. */
2288 tmp = gfc_finish_block (&body);
2289 tmp = build1_v (LOOP_EXPR, tmp)fold_build1_loc (input_location, LOOP_EXPR, global_trees[TI_VOID_TYPE
], tmp);
2290 gfc_add_expr_to_block (&implied_do_block, tmp);
2291
2292 /* Add the exit label. */
2293 tmp = build1_v (LABEL_EXPR, exit_label)fold_build1_loc (input_location, LABEL_EXPR, global_trees[TI_VOID_TYPE
], exit_label);
2294 gfc_add_expr_to_block (&implied_do_block, tmp);
2295
2296 /* Finish the implied-do loop. */
2297 tmp = gfc_finish_block(&implied_do_block);
2298 gfc_add_expr_to_block(pblock, tmp);
2299
2300 gfc_restore_sym (c->iterator->var->symtree->n.sym, &saved_loopvar);
2301 }
2302 }
2303
2304 /* F2008 4.5.6.3 para 5: If an executable construct references a structure
2305 constructor or array constructor, the entity created by the constructor is
2306 finalized after execution of the innermost executable construct containing
2307 the reference. This, in fact, was later deleted by the Combined Techical
2308 Corrigenda 1 TO 4 for fortran 2008 (f08/0011).
2309
2310 Transmit finalization of this constructor through 'finalblock'. */
2311 if (!gfc_notification_std (GFC_STD_F2018_DEL(1<<11)) && finalblock != NULL__null
2312 && gfc_may_be_finalized (ts)
2313 && ctr > 0 && desc != NULL_TREE(tree) __null
2314 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))((tree_class_check ((((contains_struct_check ((desc), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 2314, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 2314, __FUNCTION__))->type_common.lang_flag_1))
2315 {
2316 symbol_attribute attr;
2317 gfc_se fse;
2318 gfc_warning (0, "The structure constructor at %C has been"
2319 " finalized. This feature was removed by f08/0011."
2320 " Use -std=f2018 or -std=gnu to eliminate the"
2321 " finalization.");
2322 attr.pointer = attr.allocatable = 0;
2323 gfc_init_se (&fse, NULL__null);
2324 fse.expr = desc;
2325 gfc_finalize_tree_expr (&fse, ts.u.derived, attr, 1);
2326 gfc_add_block_to_block (finalblock, &fse.pre);
2327 gfc_add_block_to_block (finalblock, &fse.finalblock);
2328 gfc_add_block_to_block (finalblock, &fse.post);
2329 }
2330
2331 mpz_clear__gmpz_clear (size);
2332}
2333
2334
2335/* The array constructor code can create a string length with an operand
2336 in the form of a temporary variable. This variable will retain its
2337 context (current_function_decl). If we store this length tree in a
2338 gfc_charlen structure which is shared by a variable in another
2339 context, the resulting gfc_charlen structure with a variable in a
2340 different context, we could trip the assertion in expand_expr_real_1
2341 when it sees that a variable has been created in one context and
2342 referenced in another.
2343
2344 If this might be the case, we create a new gfc_charlen structure and
2345 link it into the current namespace. */
2346
2347static void
2348store_backend_decl (gfc_charlen **clp, tree len, bool force_new_cl)
2349{
2350 if (force_new_cl)
2351 {
2352 gfc_charlen *new_cl = gfc_new_charlen (gfc_current_ns, *clp);
2353 *clp = new_cl;
2354 }
2355 (*clp)->backend_decl = len;
2356}
2357
2358/* A catch-all to obtain the string length for anything that is not
2359 a substring of non-constant length, a constant, array or variable. */
2360
2361static void
2362get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
2363{
2364 gfc_se se;
2365
2366 /* Don't bother if we already know the length is a constant. */
2367 if (*len && INTEGER_CST_P (*len)(((enum tree_code) (*len)->base.code) == INTEGER_CST))
2368 return;
2369
2370 if (!e->ref && e->ts.u.cl && e->ts.u.cl->length
2371 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
2372 {
2373 /* This is easy. */
2374 gfc_conv_const_charlen (e->ts.u.cl);
2375 *len = e->ts.u.cl->backend_decl;
2376 }
2377 else
2378 {
2379 /* Otherwise, be brutal even if inefficient. */
2380 gfc_init_se (&se, NULL__null);
2381
2382 /* No function call, in case of side effects. */
2383 se.no_function_call = 1;
2384 if (e->rank == 0)
2385 gfc_conv_expr (&se, e);
2386 else
2387 gfc_conv_expr_descriptor (&se, e);
2388
2389 /* Fix the value. */
2390 *len = gfc_evaluate_now (se.string_length, &se.pre);
2391
2392 gfc_add_block_to_block (block, &se.pre);
2393 gfc_add_block_to_block (block, &se.post);
2394
2395 store_backend_decl (&e->ts.u.cl, *len, true);
2396 }
2397}
2398
2399
2400/* Figure out the string length of a variable reference expression.
2401 Used by get_array_ctor_strlen. */
2402
2403static void
2404get_array_ctor_var_strlen (stmtblock_t *block, gfc_expr * expr, tree * len)
2405{
2406 gfc_ref *ref;
2407 gfc_typespec *ts;
2408 mpz_t char_len;
2409 gfc_se se;
2410
2411 /* Don't bother if we already know the length is a constant. */
2412 if (*len && INTEGER_CST_P (*len)(((enum tree_code) (*len)->base.code) == INTEGER_CST))
2413 return;
2414
2415 ts = &expr->symtree->n.sym->ts;
2416 for (ref = expr->ref; ref; ref = ref->next)
2417 {
2418 switch (ref->type)
2419 {
2420 case REF_ARRAY:
2421 /* Array references don't change the string length. */
2422 if (ts->deferred)
2423 get_array_ctor_all_strlen (block, expr, len);
2424 break;
2425
2426 case REF_COMPONENT:
2427 /* Use the length of the component. */
2428 ts = &ref->u.c.component->ts;
2429 break;
2430
2431 case REF_SUBSTRING:
2432 if (ref->u.ss.end == NULL__null
2433 || ref->u.ss.start->expr_type != EXPR_CONSTANT
2434 || ref->u.ss.end->expr_type != EXPR_CONSTANT)
2435 {
2436 /* Note that this might evaluate expr. */
2437 get_array_ctor_all_strlen (block, expr, len);
2438 return;
2439 }
2440 mpz_init_set_ui__gmpz_init_set_ui (char_len, 1);
2441 mpz_add__gmpz_add (char_len, char_len, ref->u.ss.end->value.integer);
2442 mpz_sub__gmpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
2443 *len = gfc_conv_mpz_to_tree_type (char_len, gfc_charlen_type_node);
2444 mpz_clear__gmpz_clear (char_len);
2445 return;
2446
2447 case REF_INQUIRY:
2448 break;
2449
2450 default:
2451 gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 2451, __FUNCTION__));
2452 }
2453 }
2454
2455 /* A last ditch attempt that is sometimes needed for deferred characters. */
2456 if (!ts->u.cl->backend_decl)
2457 {
2458 gfc_init_se (&se, NULL__null);
2459 if (expr->rank)
2460 gfc_conv_expr_descriptor (&se, expr);
2461 else
2462 gfc_conv_expr (&se, expr);
2463 gcc_assert (se.string_length != NULL_TREE)((void)(!(se.string_length != (tree) __null) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 2463, __FUNCTION__), 0 : 0));
2464 gfc_add_block_to_block (block, &se.pre);
2465 ts->u.cl->backend_decl = se.string_length;
2466 }
2467
2468 *len = ts->u.cl->backend_decl;
2469}
2470
2471
2472/* Figure out the string length of a character array constructor.
2473 If len is NULL, don't calculate the length; this happens for recursive calls
2474 when a sub-array-constructor is an element but not at the first position,
2475 so when we're not interested in the length.
2476 Returns TRUE if all elements are character constants. */
2477
2478bool
2479get_array_ctor_strlen (stmtblock_t *block, gfc_constructor_base base, tree * len)
2480{
2481 gfc_constructor *c;
2482 bool is_const;
2483
2484 is_const = TRUEtrue;
2485
2486 if (gfc_constructor_first (base) == NULL__null)
2487 {
2488 if (len)
2489 *len = build_int_cstu (gfc_charlen_type_node, 0);
2490 return is_const;
2491 }
2492
2493 /* Loop over all constructor elements to find out is_const, but in len we
2494 want to store the length of the first, not the last, element. We can
2495 of course exit the loop as soon as is_const is found to be false. */
2496 for (c = gfc_constructor_first (base);
2497 c && is_const; c = gfc_constructor_next (c))
2498 {
2499 switch (c->expr->expr_type)
2500 {
2501 case EXPR_CONSTANT:
2502 if (len && !(*len && INTEGER_CST_P (*len)(((enum tree_code) (*len)->base.code) == INTEGER_CST)))
2503 *len = build_int_cstu (gfc_charlen_type_node,
2504 c->expr->value.character.length);
2505 break;
2506
2507 case EXPR_ARRAY:
2508 if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
2509 is_const = false;
2510 break;
2511
2512 case EXPR_VARIABLE:
2513 is_const = false;
2514 if (len)
2515 get_array_ctor_var_strlen (block, c->expr, len);
2516 break;
2517
2518 default:
2519 is_const = false;
2520 if (len)
2521 get_array_ctor_all_strlen (block, c->expr, len);
2522 break;
2523 }
2524
2525 /* After the first iteration, we don't want the length modified. */
2526 len = NULL__null;
2527 }
2528
2529 return is_const;
2530}
2531
2532/* Check whether the array constructor C consists entirely of constant
2533 elements, and if so returns the number of those elements, otherwise
2534 return zero. Note, an empty or NULL array constructor returns zero. */
2535
2536unsigned HOST_WIDE_INTlong
2537gfc_constant_array_constructor_p (gfc_constructor_base base)
2538{
2539 unsigned HOST_WIDE_INTlong nelem = 0;
2540
2541 gfc_constructor *c = gfc_constructor_first (base);
2542 while (c)
2543 {
2544 if (c->iterator
2545 || c->expr->rank > 0
2546 || c->expr->expr_type != EXPR_CONSTANT)
2547 return 0;
2548 c = gfc_constructor_next (c);
2549 nelem++;
2550 }
2551 return nelem;
2552}
2553
2554
2555/* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
2556 and the tree type of it's elements, TYPE, return a static constant
2557 variable that is compile-time initialized. */
2558
2559tree
2560gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
2561{
2562 tree tmptype, init, tmp;
2563 HOST_WIDE_INTlong nelem;
2564 gfc_constructor *c;
2565 gfc_array_spec as;
2566 gfc_se se;
2567 int i;
2568 vec<constructor_elt, va_gc> *v = NULL__null;
2569
2570 /* First traverse the constructor list, converting the constants
2571 to tree to build an initializer. */
2572 nelem = 0;
2573 c = gfc_constructor_first (expr->value.constructor);
2574 while (c)
2575 {
2576 gfc_init_se (&se, NULL__null);
2577 gfc_conv_constant (&se, c->expr);
2578 if (c->expr->ts.type != BT_CHARACTER)
2579 se.expr = fold_convert (type, se.expr)fold_convert_loc (((location_t) 0), type, se.expr);
2580 else if (POINTER_TYPE_P (type)(((enum tree_code) (type)->base.code) == POINTER_TYPE || (
(enum tree_code) (type)->base.code) == REFERENCE_TYPE))
2581 se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
2582 se.expr);
2583 CONSTRUCTOR_APPEND_ELT (v, build_int_cst (gfc_array_index_type, nelem),do { constructor_elt _ce___ = {build_int_cst (gfc_array_index_type
, nelem), se.expr}; vec_safe_push ((v), _ce___); } while (0)
2584 se.expr)do { constructor_elt _ce___ = {build_int_cst (gfc_array_index_type
, nelem), se.expr}; vec_safe_push ((v), _ce___); } while (0);
2585 c = gfc_constructor_next (c);
2586 nelem++;
2587 }
2588
2589 /* Next determine the tree type for the array. We use the gfortran
2590 front-end's gfc_get_nodesc_array_type in order to create a suitable
2591 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
2592
2593 memset (&as, 0, sizeof (gfc_array_spec));
2594
2595 as.rank = expr->rank;
2596 as.type = AS_EXPLICIT;
2597 if (!expr->shape)
2598 {
2599 as.lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL__null, 0);
2600 as.upper[0] = gfc_get_int_expr (gfc_default_integer_kind,
2601 NULL__null, nelem - 1);
2602 }
2603 else
2604 for (i = 0; i < expr->rank; i++)
2605 {
2606 int tmp = (int) mpz_get_si__gmpz_get_si (expr->shape[i]);
2607 as.lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL__null, 0);
2608 as.upper[i] = gfc_get_int_expr (gfc_default_integer_kind,
2609 NULL__null, tmp - 1);
2610 }
2611
2612 tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
2613
2614 /* as is not needed anymore. */
2615 for (i = 0; i < as.rank + as.corank; i++)
2616 {
2617 gfc_free_expr (as.lower[i]);
2618 gfc_free_expr (as.upper[i]);
2619 }
2620
2621 init = build_constructor (tmptype, v);
2622
2623 TREE_CONSTANT (init)((non_type_check ((init), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 2623, __FUNCTION__))->base.constant_flag) = 1;
2624 TREE_STATIC (init)((init)->base.static_flag) = 1;
2625
2626 tmp = build_decl (input_location, VAR_DECL, create_tmp_var_name ("A"),
2627 tmptype);
2628 DECL_ARTIFICIAL (tmp)((contains_struct_check ((tmp), (TS_DECL_COMMON), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 2628, __FUNCTION__))->decl_common.artificial_flag) = 1;
2629 DECL_IGNORED_P (tmp)((contains_struct_check ((tmp), (TS_DECL_COMMON), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 2629, __FUNCTION__))->decl_common.ignored_flag) = 1;
2630 TREE_STATIC (tmp)((tmp)->base.static_flag) = 1;
2631 TREE_CONSTANT (tmp)((non_type_check ((tmp), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 2631, __FUNCTION__))->base.constant_flag) = 1;
2632 TREE_READONLY (tmp)((non_type_check ((tmp), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 2632, __FUNCTION__))->base.readonly_flag) = 1;
2633 DECL_INITIAL (tmp)((contains_struct_check ((tmp), (TS_DECL_COMMON), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 2633, __FUNCTION__))->decl_common.initial) = init;
2634 pushdecl (tmp);
2635
2636 return tmp;
2637}
2638
2639
2640/* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
2641 This mostly initializes the scalarizer state info structure with the
2642 appropriate values to directly use the array created by the function
2643 gfc_build_constant_array_constructor. */
2644
2645static void
2646trans_constant_array_constructor (gfc_ss * ss, tree type)
2647{
2648 gfc_array_info *info;
2649 tree tmp;
2650 int i;
2651
2652 tmp = gfc_build_constant_array_constructor (ss->info->expr, type);
2653
2654 info = &ss->info->data.array;
2655
2656 info->descriptor = tmp;
2657 info->data = gfc_build_addr_expr (NULL_TREE(tree) __null, tmp);
2658 info->offset = gfc_index_zero_nodegfc_rank_cst[0];
2659
2660 for (i = 0; i < ss->dimen; i++)
2661 {
2662 info->delta[i] = gfc_index_zero_nodegfc_rank_cst[0];
2663 info->start[i] = gfc_index_zero_nodegfc_rank_cst[0];
2664 info->end[i] = gfc_index_zero_nodegfc_rank_cst[0];
2665 info->stride[i] = gfc_index_one_nodegfc_rank_cst[1];
2666 }
2667}
2668
2669
2670static int
2671get_rank (gfc_loopinfo *loop)
2672{
2673 int rank;
2674
2675 rank = 0;
2676 for (; loop; loop = loop->parent)
2677 rank += loop->dimen;
2678
2679 return rank;
2680}
2681
2682
2683/* Helper routine of gfc_trans_array_constructor to determine if the
2684 bounds of the loop specified by LOOP are constant and simple enough
2685 to use with trans_constant_array_constructor. Returns the
2686 iteration count of the loop if suitable, and NULL_TREE otherwise. */
2687
2688static tree
2689constant_array_constructor_loop_size (gfc_loopinfo * l)
2690{
2691 gfc_loopinfo *loop;
2692 tree size = gfc_index_one_nodegfc_rank_cst[1];
2693 tree tmp;
2694 int i, total_dim;
2695
2696 total_dim = get_rank (l);
2697
2698 for (loop = l; loop; loop = loop->parent)
2699 {
2700 for (i = 0; i < loop->dimen; i++)
2701 {
2702 /* If the bounds aren't constant, return NULL_TREE. */
2703 if (!INTEGER_CST_P (loop->from[i])(((enum tree_code) (loop->from[i])->base.code) == INTEGER_CST
) || !INTEGER_CST_P (loop->to[i])(((enum tree_code) (loop->to[i])->base.code) == INTEGER_CST
))
2704 return NULL_TREE(tree) __null;
2705 if (!integer_zerop (loop->from[i]))
2706 {
2707 /* Only allow nonzero "from" in one-dimensional arrays. */
2708 if (total_dim != 1)
2709 return NULL_TREE(tree) __null;
2710 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2711 gfc_array_index_type,
2712 loop->to[i], loop->from[i]);
2713 }
2714 else
2715 tmp = loop->to[i];
2716 tmp = fold_build2_loc (input_location, PLUS_EXPR,
2717 gfc_array_index_type, tmp, gfc_index_one_nodegfc_rank_cst[1]);
2718 size = fold_build2_loc (input_location, MULT_EXPR,
2719 gfc_array_index_type, size, tmp);
2720 }
2721 }
2722
2723 return size;
2724}
2725
2726
2727static tree *
2728get_loop_upper_bound_for_array (gfc_ss *array, int array_dim)
2729{
2730 gfc_ss *ss;
2731 int n;
2732
2733 gcc_assert (array->nested_ss == NULL)((void)(!(array->nested_ss == __null) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 2733, __FUNCTION__), 0 : 0));
2734
2735 for (ss = array; ss; ss = ss->parent)
2736 for (n = 0; n < ss->loop->dimen; n++)
2737 if (array_dim == get_array_ref_dim_for_loop_dim (ss, n))
2738 return &(ss->loop->to[n]);
2739
2740 gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 2740, __FUNCTION__));
2741}
2742
2743
2744static gfc_loopinfo *
2745outermost_loop (gfc_loopinfo * loop)
2746{
2747 while (loop->parent != NULL__null)
2748 loop = loop->parent;
2749
2750 return loop;
2751}
2752
2753
2754/* Array constructors are handled by constructing a temporary, then using that
2755 within the scalarization loop. This is not optimal, but seems by far the
2756 simplest method. */
2757
2758static void
2759trans_array_constructor (gfc_ss * ss, locus * where)
2760{
2761 gfc_constructor_base c;
2762 tree offset;
2763 tree offsetvar;
2764 tree desc;
2765 tree type;
2766 tree tmp;
2767 tree *loop_ubound0;
2768 bool dynamic;
2769 bool old_first_len, old_typespec_chararray_ctor;
2770 tree old_first_len_val;
2771 gfc_loopinfo *loop, *outer_loop;
2772 gfc_ss_info *ss_info;
2773 gfc_expr *expr;
2774 gfc_ss *s;
2775 tree neg_len;
2776 char *msg;
2777 stmtblock_t finalblock;
2778
2779 /* Save the old values for nested checking. */
2780 old_first_len = first_len;
2781 old_first_len_val = first_len_val;
2782 old_typespec_chararray_ctor = typespec_chararray_ctor;
2783
2784 loop = ss->loop;
2785 outer_loop = outermost_loop (loop);
2786 ss_info = ss->info;
2787 expr = ss_info->expr;
2788
2789 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
2790 typespec was given for the array constructor. */
2791 typespec_chararray_ctor = (expr->ts.type
21.1
Field 'type' is not equal to BT_CHARACTER
 == BT_CHARACTER
2792 && expr->ts.u.cl
2793 && expr->ts.u.cl->length_from_typespec);
2794
2795 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS(1<<0))
22
←
Assuming the condition is false
→
2796 && expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor)
2797 {
2798 first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
2799 first_len = true;
2800 }
2801
2802 gcc_assert (ss->dimen == ss->loop->dimen)((void)(!(ss->dimen == ss->loop->dimen) ? fancy_abort
("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 2802, __FUNCTION__), 0 : 0));
23
←
Assuming 'ss->dimen' is equal to 'ss->loop->dimen'
→
24
←
'?' condition is false
→
2803
2804 c = expr->value.constructor;
2805 if (expr->ts.type
24.1
Field 'type' is not equal to BT_CHARACTER
 == BT_CHARACTER)
25
←
Taking false branch
→
2806 {
2807 bool const_string;
2808 bool force_new_cl = false;
2809
2810 /* get_array_ctor_strlen walks the elements of the constructor, if a
2811 typespec was given, we already know the string length and want the one
2812 specified there. */
2813 if (typespec_chararray_ctor && expr->ts.u.cl->length
2814 && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
2815 {
2816 gfc_se length_se;
2817
2818 const_string = false;
2819 gfc_init_se (&length_se, NULL__null);
2820 gfc_conv_expr_type (&length_se, expr->ts.u.cl->length,
2821 gfc_charlen_type_node);
2822 ss_info->string_length = length_se.expr;
2823
2824 /* Check if the character length is negative. If it is, then
2825 set LEN = 0. */
2826 neg_len = fold_build2_loc (input_location, LT_EXPR,
2827 logical_type_node, ss_info->string_length,
2828 build_zero_cst (TREE_TYPE((contains_struct_check ((ss_info->string_length), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 2829, __FUNCTION__))->typed.type)
2829 (ss_info->string_length)((contains_struct_check ((ss_info->string_length), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 2829, __FUNCTION__))->typed.type)));
2830 /* Print a warning if bounds checking is enabled. */
2831 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS(1<<0))
2832 {
2833 msg = xasprintf ("Negative character length treated as LEN = 0");
2834 gfc_trans_runtime_check (false, true, neg_len, &length_se.pre,
2835 where, msg);
2836 free (msg);
2837 }
2838
2839 ss_info->string_length
2840 = fold_build3_loc (input_location, COND_EXPR,
2841 gfc_charlen_type_node, neg_len,
2842 build_zero_cst
2843 (TREE_TYPE (ss_info->string_length)((contains_struct_check ((ss_info->string_length), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 2843, __FUNCTION__))->typed.type)),
2844 ss_info->string_length);
2845 ss_info->string_length = gfc_evaluate_now (ss_info->string_length,
2846 &length_se.pre);
2847 gfc_add_block_to_block (&outer_loop->pre, &length_se.pre);
2848 gfc_add_block_to_block (&outer_loop->post, &length_se.post);
2849 }
2850 else
2851 {
2852 const_string = get_array_ctor_strlen (&outer_loop->pre, c,
2853 &ss_info->string_length);
2854 force_new_cl = true;
2855 }
2856
2857 /* Complex character array constructors should have been taken care of
2858 and not end up here. */
2859 gcc_assert (ss_info->string_length)((void)(!(ss_info->string_length) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 2859, __FUNCTION__), 0 : 0));
2860
2861 store_backend_decl (&expr->ts.u.cl, ss_info->string_length, force_new_cl);
2862
2863 type = gfc_get_character_type_len (expr->ts.kind, ss_info->string_length);
2864 if (const_string)
2865 type = build_pointer_type (type);
2866 }
2867 else
2868 type = gfc_typenode_for_spec (expr->ts.type == BT_CLASS
26
←
Assuming field 'type' is not equal to BT_CLASS
→
27
←
'?' condition is false
→
2869 ? &CLASS_DATA (expr)expr->ts.u.derived->components->ts : &expr->ts);
2870
2871 /* See if the constructor determines the loop bounds. */
2872 dynamic = false;
2873
2874 loop_ubound0 = get_loop_upper_bound_for_array (ss, 0);
2875
2876 if (expr->shape && get_rank (loop) > 1 && *loop_ubound0 == NULL_TREE(tree) __null)
28
←
Assuming field 'shape' is null
→
2877 {
2878 /* We have a multidimensional parameter. */
2879 for (s = ss; s; s = s->parent)
2880 {
2881 int n;
2882 for (n = 0; n < s->loop->dimen; n++)
2883 {
2884 s->loop->from[n] = gfc_index_zero_nodegfc_rank_cst[0];
2885 s->loop->to[n] = gfc_conv_mpz_to_tree (expr->shape[s->dim[n]],
2886 gfc_index_integer_kind);
2887 s->loop->to[n] = fold_build2_loc (input_location, MINUS_EXPR,
2888 gfc_array_index_type,
2889 s->loop->to[n],
2890 gfc_index_one_nodegfc_rank_cst[1]);
2891 }
2892 }
2893 }
2894
2895 if (*loop_ubound0 == NULL_TREE(tree) __null)
29
←
Assuming the condition is false
→
30
←
Taking false branch
→
2896 {
2897 mpz_t size;
2898
2899 /* We should have a 1-dimensional, zero-based loop. */
2900 gcc_assert (loop->parent == NULL && loop->nested == NULL)((void)(!(loop->parent == __null && loop->nested
== __null) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 2900, __FUNCTION__), 0 : 0));
2901 gcc_assert (loop->dimen == 1)((void)(!(loop->dimen == 1) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 2901, __FUNCTION__), 0 : 0));
2902 gcc_assert (integer_zerop (loop->from[0]))((void)(!(integer_zerop (loop->from[0])) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 2902, __FUNCTION__), 0 : 0));
2903
2904 /* Split the constructor size into a static part and a dynamic part.
2905 Allocate the static size up-front and record whether the dynamic
2906 size might be nonzero. */
2907 mpz_init__gmpz_init (size);
2908 dynamic = gfc_get_array_constructor_size (&size, c);
2909 mpz_sub_ui__gmpz_sub_ui (size, size, 1);
2910 loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
2911 mpz_clear__gmpz_clear (size);
2912 }
2913
2914 /* Special case constant array constructors. */
2915 if (!dynamic
30.1
'dynamic' is false
)
31
←
Taking true branch
→
2916 {
2917 unsigned HOST_WIDE_INTlong nelem = gfc_constant_array_constructor_p (c);
2918 if (nelem > 0)
32
←
Assuming 'nelem' is > 0
→
33
←
Taking true branch
→
2919 {
2920 tree size = constant_array_constructor_loop_size (loop);
2921 if (size && compare_tree_int (size, nelem) == 0)
34
←
Assuming 'size' is non-null
→
35
←
Assuming the condition is true
→
36
←
Taking true branch
→
2922 {
2923 trans_constant_array_constructor (ss, type);
2924 goto finish;
37
←
Control jumps to line 2974
→
2925 }
2926 }
2927 }
2928
2929 gfc_trans_create_temp_array (&outer_loop->pre, &outer_loop->post, ss, type,
2930 NULL_TREE(tree) __null, dynamic, true, false, where);
2931
2932 desc = ss_info->data.array.descriptor;
2933 offset = gfc_index_zero_nodegfc_rank_cst[0];
2934 offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
2935 suppress_warning (offsetvar);
2936 TREE_USED (offsetvar)((offsetvar)->base.used_flag) = 0;
2937
2938 gfc_init_block (&finalblock);
2939 gfc_trans_array_constructor_value (&outer_loop->pre,
2940 expr->must_finalize ? &finalblock : NULL__null,
2941 type, desc, c, &offset, &offsetvar,
2942 dynamic);
2943
2944 /* If the array grows dynamically, the upper bound of the loop variable
2945 is determined by the array's final upper bound. */
2946 if (dynamic)
2947 {
2948 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2949 gfc_array_index_type,
2950 offsetvar, gfc_index_one_nodegfc_rank_cst[1]);
2951 tmp = gfc_evaluate_now (tmp, &outer_loop->pre);
2952 gfc_conv_descriptor_ubound_set (&loop->pre, desc, gfc_rank_cst[0], tmp);
2953 if (*loop_ubound0 && VAR_P (*loop_ubound0)(((enum tree_code) (*loop_ubound0)->base.code) == VAR_DECL
))
2954 gfc_add_modify (&outer_loop->pre, *loop_ubound0, tmp);
2955 else
2956 *loop_ubound0 = tmp;
2957 }
2958
2959 if (TREE_USED (offsetvar)((offsetvar)->base.used_flag))
2960 pushdecl (offsetvar);
2961 else
2962 gcc_assert (INTEGER_CST_P (offset))((void)(!((((enum tree_code) (offset)->base.code) == INTEGER_CST
)) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 2962, __FUNCTION__), 0 : 0));
2963
2964#if 0
2965 /* Disable bound checking for now because it's probably broken. */
2966 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS(1<<0))
2967 {
2968 gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 2968, __FUNCTION__));
2969 }
2970#endif
2971
2972finish:
2973 /* Restore old values of globals. */
2974 first_len = old_first_len;
2975 first_len_val = old_first_len_val;
2976 typespec_chararray_ctor = old_typespec_chararray_ctor;
2977
2978 /* F2008 4.5.6.3 para 5: If an executable construct references a structure
2979 constructor or array constructor, the entity created by the constructor is
2980 finalized after execution of the innermost executable construct containing
2981 the reference. */
2982 if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
38
←
Assuming field 'type' is equal to BT_DERIVED
→
2983 && finalblock.head != NULL_TREE(tree) __null)
39
←
The left operand of '!=' is a garbage value
2984 gfc_add_block_to_block (&loop->post, &finalblock);
2985
2986}
2987
2988
2989/* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
2990 called after evaluating all of INFO's vector dimensions. Go through
2991 each such vector dimension and see if we can now fill in any missing
2992 loop bounds. */
2993
2994static void
2995set_vector_loop_bounds (gfc_ss * ss)
2996{
2997 gfc_loopinfo *loop, *outer_loop;
2998 gfc_array_info *info;
2999 gfc_se se;
3000 tree tmp;
3001 tree desc;
3002 tree zero;
3003 int n;
3004 int dim;
3005
3006 outer_loop = outermost_loop (ss->loop);
3007
3008 info = &ss->info->data.array;
3009
3010 for (; ss; ss = ss->parent)
3011 {
3012 loop = ss->loop;
3013
3014 for (n = 0; n < loop->dimen; n++)
3015 {
3016 dim = ss->dim[n];
3017 if (info->ref->u.ar.dimen_type[dim] != DIMEN_VECTOR
3018 || loop->to[n] != NULL__null)
3019 continue;
3020
3021 /* Loop variable N indexes vector dimension DIM, and we don't
3022 yet know the upper bound of loop variable N. Set it to the
3023 difference between the vector's upper and lower bounds. */
3024 gcc_assert (loop->from[n] == gfc_index_zero_node)((void)(!(loop->from[n] == gfc_rank_cst[0]) ? fancy_abort (
"/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3024, __FUNCTION__), 0 : 0));
3025 gcc_assert (info->subscript[dim]((void)(!(info->subscript[dim] && info->subscript
[dim]->info->type == GFC_SS_VECTOR) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3026, __FUNCTION__), 0 : 0))
3026 && info->subscript[dim]->info->type == GFC_SS_VECTOR)((void)(!(info->subscript[dim] && info->subscript
[dim]->info->type == GFC_SS_VECTOR) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3026, __FUNCTION__), 0 : 0));
3027
3028 gfc_init_se (&se, NULL__null);
3029 desc = info->subscript[dim]->info->data.array.descriptor;
3030 zero = gfc_rank_cst[0];
3031 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3032 gfc_array_index_type,
3033 gfc_conv_descriptor_ubound_get (desc, zero),
3034 gfc_conv_descriptor_lbound_get (desc, zero));
3035 tmp = gfc_evaluate_now (tmp, &outer_loop->pre);
3036 loop->to[n] = tmp;
3037 }
3038 }
3039}
3040
3041
3042/* Tells whether a scalar argument to an elemental procedure is saved out
3043 of a scalarization loop as a value or as a reference. */
3044
3045bool
3046gfc_scalar_elemental_arg_saved_as_reference (gfc_ss_info * ss_info)
3047{
3048 if (ss_info->type != GFC_SS_REFERENCE)
3049 return false;
3050
3051 if (ss_info->data.scalar.needs_temporary)
3052 return false;
3053
3054 /* If the actual argument can be absent (in other words, it can
3055 be a NULL reference), don't try to evaluate it; pass instead
3056 the reference directly. */
3057 if (ss_info->can_be_null_ref)
3058 return true;
3059
3060 /* If the expression is of polymorphic type, it's actual size is not known,
3061 so we avoid copying it anywhere. */
3062 if (ss_info->data.scalar.dummy_arg
3063 && gfc_dummy_arg_get_typespec (*ss_info->data.scalar.dummy_arg).type
3064 == BT_CLASS
3065 && ss_info->expr->ts.type == BT_CLASS)
3066 return true;
3067
3068 /* If the expression is a data reference of aggregate type,
3069 and the data reference is not used on the left hand side,
3070 avoid a copy by saving a reference to the content. */
3071 if (!ss_info->data.scalar.needs_temporary
3072 && (ss_info->expr->ts.type == BT_DERIVED
3073 || ss_info->expr->ts.type == BT_CLASS)
3074 && gfc_expr_is_variable (ss_info->expr))
3075 return true;
3076
3077 /* Otherwise the expression is evaluated to a temporary variable before the
3078 scalarization loop. */
3079 return false;
3080}
3081
3082
3083/* Add the pre and post chains for all the scalar expressions in a SS chain
3084 to loop. This is called after the loop parameters have been calculated,
3085 but before the actual scalarizing loops. */
3086
3087static void
3088gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
3089 locus * where)
3090{
3091 gfc_loopinfo *nested_loop, *outer_loop;
3092 gfc_se se;
3093 gfc_ss_info *ss_info;
3094 gfc_array_info *info;
3095 gfc_expr *expr;
3096 int n;
3097
3098 /* Don't evaluate the arguments for realloc_lhs_loop_for_fcn_call; otherwise,
3099 arguments could get evaluated multiple times. */
3100 if (ss->is_alloc_lhs)
5
←
Assuming field 'is_alloc_lhs' is 0
→
6
←
Taking false branch
→
12
←
Assuming field 'is_alloc_lhs' is 0
→
13
←
Taking false branch
→
3101 return;
3102
3103 outer_loop = outermost_loop (loop);
3104
3105 /* TODO: This can generate bad code if there are ordering dependencies,
3106 e.g., a callee allocated function and an unknown size constructor. */
3107 gcc_assert (ss != NULL)((void)(!(ss != __null) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3107, __FUNCTION__), 0 : 0));
7
←
'?' condition is false
→
14
←
'?' condition is false
→
3108
3109 for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
8
←
Loop condition is false. Execution continues on line 3245
→
15
←
Loop condition is true. Entering loop body
→
3110 {
3111 gcc_assert (ss)((void)(!(ss) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3111, __FUNCTION__), 0 : 0));
16
←
'?' condition is false
→
3112
3113 /* Cross loop arrays are handled from within the most nested loop. */
3114 if (ss->nested_ss != NULL__null)
17
←
Assuming field 'nested_ss' is equal to NULL
→
18
←
Taking false branch
→
3115 continue;
3116
3117 ss_info = ss->info;
3118 expr = ss_info->expr;
3119 info = &ss_info->data.array;
3120
3121 switch (ss_info->type)
19
←
Control jumps to 'case GFC_SS_CONSTRUCTOR:' at line 3218
→
3122 {
3123 case GFC_SS_SCALAR:
3124 /* Scalar expression. Evaluate this now. This includes elemental
3125 dimension indices, but not array section bounds. */
3126 gfc_init_se (&se, NULL__null);
3127 gfc_conv_expr (&se, expr);
3128 gfc_add_block_to_block (&outer_loop->pre, &se.pre);
3129
3130 if (expr->ts.type != BT_CHARACTER
3131 && !gfc_is_alloc_class_scalar_function (expr))
3132 {
3133 /* Move the evaluation of scalar expressions outside the
3134 scalarization loop, except for WHERE assignments. */
3135 if (subscript)
3136 se.expr = convert(gfc_array_index_type, se.expr);
3137 if (!ss_info->where)
3138 se.expr = gfc_evaluate_now (se.expr, &outer_loop->pre);
3139 gfc_add_block_to_block (&outer_loop->pre, &se.post);
3140 }
3141 else
3142 gfc_add_block_to_block (&outer_loop->post, &se.post);
3143
3144 ss_info->data.scalar.value = se.expr;
3145 ss_info->string_length = se.string_length;
3146 break;
3147
3148 case GFC_SS_REFERENCE:
3149 /* Scalar argument to elemental procedure. */
3150 gfc_init_se (&se, NULL__null);
3151 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info))
3152 gfc_conv_expr_reference (&se, expr);
3153 else
3154 {
3155 /* Evaluate the argument outside the loop and pass
3156 a reference to the value. */
3157 gfc_conv_expr (&se, expr);
3158 }
3159
3160 /* Ensure that a pointer to the string is stored. */
3161 if (expr->ts.type == BT_CHARACTER)
3162 gfc_conv_string_parameter (&se);
3163
3164 gfc_add_block_to_block (&outer_loop->pre, &se.pre);
3165 gfc_add_block_to_block (&outer_loop->post, &se.post);
3166 if (gfc_is_class_scalar_expr (expr))
3167 /* This is necessary because the dynamic type will always be
3168 large than the declared type. In consequence, assigning
3169 the value to a temporary could segfault.
3170 OOP-TODO: see if this is generally correct or is the value
3171 has to be written to an allocated temporary, whose address
3172 is passed via ss_info. */
3173 ss_info->data.scalar.value = se.expr;
3174 else
3175 ss_info->data.scalar.value = gfc_evaluate_now (se.expr,
3176 &outer_loop->pre);
3177
3178 ss_info->string_length = se.string_length;
3179 break;
3180
3181 case GFC_SS_SECTION:
3182 /* Add the expressions for scalar and vector subscripts. */
3183 for (n = 0; n < GFC_MAX_DIMENSIONS15; n++)
3184 if (info->subscript[n])
3185 gfc_add_loop_ss_code (loop, info->subscript[n], true, where);
3186
3187 set_vector_loop_bounds (ss);
3188 break;
3189
3190 case GFC_SS_VECTOR:
3191 /* Get the vector's descriptor and store it in SS. */
3192 gfc_init_se (&se, NULL__null);
3193 gfc_conv_expr_descriptor (&se, expr);
3194 gfc_add_block_to_block (&outer_loop->pre, &se.pre);
3195 gfc_add_block_to_block (&outer_loop->post, &se.post);
3196 info->descriptor = se.expr;
3197 break;
3198
3199 case GFC_SS_INTRINSIC:
3200 gfc_add_intrinsic_ss_code (loop, ss);
3201 break;
3202
3203 case GFC_SS_FUNCTION:
3204 /* Array function return value. We call the function and save its
3205 result in a temporary for use inside the loop. */
3206 gfc_init_se (&se, NULL__null);
3207 se.loop = loop;
3208 se.ss = ss;
3209 if (gfc_is_class_array_function (expr))
3210 expr->must_finalize = 1;
3211 gfc_conv_expr (&se, expr);
3212 gfc_add_block_to_block (&outer_loop->pre, &se.pre);
3213 gfc_add_block_to_block (&outer_loop->post, &se.post);
3214 gfc_add_block_to_block (&outer_loop->post, &se.finalblock);
3215 ss_info->string_length = se.string_length;
3216 break;
3217
3218 case GFC_SS_CONSTRUCTOR:
3219 if (expr->ts.type == BT_CHARACTER
20
←
Assuming field 'type' is not equal to BT_CHARACTER
→
3220 && ss_info->string_length == NULL__null
3221 && expr->ts.u.cl
3222 && expr->ts.u.cl->length
3223 && expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
3224 {
3225 gfc_init_se (&se, NULL__null);
3226 gfc_conv_expr_type (&se, expr->ts.u.cl->length,
3227 gfc_charlen_type_node);
3228 ss_info->string_length = se.expr;
3229 gfc_add_block_to_block (&outer_loop->pre, &se.pre);
3230 gfc_add_block_to_block (&outer_loop->post, &se.post);
3231 }
3232 trans_array_constructor (ss, where);
21
←
Calling 'trans_array_constructor'
→
3233 break;
3234
3235 case GFC_SS_TEMP:
3236 case GFC_SS_COMPONENT:
3237 /* Do nothing. These are handled elsewhere. */
3238 break;
3239
3240 default:
3241 gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3241, __FUNCTION__));
3242 }
3243 }
3244
3245 if (!subscript
8.1
'subscript' is false
)
9
←
Taking true branch
→
3246 for (nested_loop = loop->nested; nested_loop;
10
←
Loop condition is true. Entering loop body
→
3247 nested_loop = nested_loop->next)
3248 gfc_add_loop_ss_code (nested_loop, nested_loop->ss, subscript, where);
11
←
Calling 'gfc_add_loop_ss_code'
→
3249}
3250
3251
3252/* Translate expressions for the descriptor and data pointer of a SS. */
3253/*GCC ARRAYS*/
3254
3255static void
3256gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
3257{
3258 gfc_se se;
3259 gfc_ss_info *ss_info;
3260 gfc_array_info *info;
3261 tree tmp;
3262
3263 ss_info = ss->info;
3264 info = &ss_info->data.array;
3265
3266 /* Get the descriptor for the array to be scalarized. */
3267 gcc_assert (ss_info->expr->expr_type == EXPR_VARIABLE)((void)(!(ss_info->expr->expr_type == EXPR_VARIABLE) ? fancy_abort
("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3267, __FUNCTION__), 0 : 0));
3268 gfc_init_se (&se, NULL__null);
3269 se.descriptor_only = 1;
3270 gfc_conv_expr_lhs (&se, ss_info->expr);
3271 gfc_add_block_to_block (block, &se.pre);
3272 info->descriptor = se.expr;
3273 ss_info->string_length = se.string_length;
3274
3275 if (base)
3276 {
3277 if (ss_info->expr->ts.type == BT_CHARACTER && !ss_info->expr->ts.deferred
3278 && ss_info->expr->ts.u.cl->length == NULL__null)
3279 {
3280 /* Emit a DECL_EXPR for the variable sized array type in
3281 GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
3282 sizes works correctly. */
3283 tree arraytype = TREE_TYPE (((contains_struct_check (((((tree_class_check ((((contains_struct_check
((info->descriptor), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3284, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3284, __FUNCTION__))->type_with_lang_specific.lang_specific
)->dataptr_type)), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3284, __FUNCTION__))->typed.type)
3284 GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (info->descriptor)))((contains_struct_check (((((tree_class_check ((((contains_struct_check
((info->descriptor), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3284, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3284, __FUNCTION__))->type_with_lang_specific.lang_specific
)->dataptr_type)), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3284, __FUNCTION__))->typed.type);
3285 if (! TYPE_NAME (arraytype)((tree_class_check ((arraytype), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3285, __FUNCTION__))->type_common.name))
3286 TYPE_NAME (arraytype)((tree_class_check ((arraytype), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3286, __FUNCTION__))->type_common.name) = build_decl (UNKNOWN_LOCATION((location_t) 0), TYPE_DECL,
3287 NULL_TREE(tree) __null, arraytype);
3288 gfc_add_expr_to_block (block, build1 (DECL_EXPR, arraytype,
3289 TYPE_NAME (arraytype)((tree_class_check ((arraytype), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3289, __FUNCTION__))->type_common.name)));
3290 }
3291 /* Also the data pointer. */
3292 tmp = gfc_conv_array_data (se.expr);
3293 /* If this is a variable or address or a class array, use it directly.
3294 Otherwise we must evaluate it now to avoid breaking dependency
3295 analysis by pulling the expressions for elemental array indices
3296 inside the loop. */
3297 if (!(DECL_P (tmp)(tree_code_type_tmpl <0>::tree_code_type[(int) (((enum tree_code
) (tmp)->base.code))] == tcc_declaration)
3298 || (TREE_CODE (tmp)((enum tree_code) (tmp)->base.code) == ADDR_EXPR
3299 && DECL_P (TREE_OPERAND (tmp, 0))(tree_code_type_tmpl <0>::tree_code_type[(int) (((enum tree_code
) ((*((const_cast<tree*> (tree_operand_check ((tmp), (0
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3299, __FUNCTION__))))))->base.code))] == tcc_declaration
))
3300 || (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))((tree_class_check ((((contains_struct_check ((se.expr), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3300, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3300, __FUNCTION__))->type_common.lang_flag_1)
3301 && TREE_CODE (se.expr)((enum tree_code) (se.expr)->base.code) == COMPONENT_REF
3302 && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (se.expr, 0)))((tree_class_check ((((contains_struct_check (((*((const_cast
<tree*> (tree_operand_check ((se.expr), (0), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3302, __FUNCTION__)))))), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3302, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3302, __FUNCTION__))->type_common.lang_flag_4))))
3303 tmp = gfc_evaluate_now (tmp, block);
3304 info->data = tmp;
3305
3306 tmp = gfc_conv_array_offset (se.expr);
3307 info->offset = gfc_evaluate_now (tmp, block);
3308
3309 /* Make absolutely sure that the saved_offset is indeed saved
3310 so that the variable is still accessible after the loops
3311 are translated. */
3312 info->saved_offset = info->offset;
3313 }
3314}
3315
3316
3317/* Initialize a gfc_loopinfo structure. */
3318
3319void
3320gfc_init_loopinfo (gfc_loopinfo * loop)
3321{
3322 int n;
3323
3324 memset (loop, 0, sizeof (gfc_loopinfo));
3325 gfc_init_block (&loop->pre);
3326 gfc_init_block (&loop->post);
3327
3328 /* Initially scalarize in order and default to no loop reversal. */
3329 for (n = 0; n < GFC_MAX_DIMENSIONS15; n++)
3330 {
3331 loop->order[n] = n;
3332 loop->reverse[n] = GFC_INHIBIT_REVERSE;
3333 }
3334
3335 loop->ss = gfc_ss_terminator;
3336}
3337
3338
3339/* Copies the loop variable info to a gfc_se structure. Does not copy the SS
3340 chain. */
3341
3342void
3343gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
3344{
3345 se->loop = loop;
3346}
3347
3348
3349/* Return an expression for the data pointer of an array. */
3350
3351tree
3352gfc_conv_array_data (tree descriptor)
3353{
3354 tree type;
3355
3356 type = TREE_TYPE (descriptor)((contains_struct_check ((descriptor), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3356, __FUNCTION__))->typed.type);
3357 if (GFC_ARRAY_TYPE_P (type)((tree_class_check ((type), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3357, __FUNCTION__))->type_common.lang_flag_2))
3358 {
3359 if (TREE_CODE (type)((enum tree_code) (type)->base.code) == POINTER_TYPE)
3360 return descriptor;
3361 else
3362 {
3363 /* Descriptorless arrays. */
3364 return gfc_build_addr_expr (NULL_TREE(tree) __null, descriptor);
3365 }
3366 }
3367 else
3368 return gfc_conv_descriptor_data_get (descriptor);
3369}
3370
3371
3372/* Return an expression for the base offset of an array. */
3373
3374tree
3375gfc_conv_array_offset (tree descriptor)
3376{
3377 tree type;
3378
3379 type = TREE_TYPE (descriptor)((contains_struct_check ((descriptor), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3379, __FUNCTION__))->typed.type);
3380 if (GFC_ARRAY_TYPE_P (type)((tree_class_check ((type), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3380, __FUNCTION__))->type_common.lang_flag_2))
3381 return GFC_TYPE_ARRAY_OFFSET (type)(((tree_class_check ((type), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3381, __FUNCTION__))->type_with_lang_specific.lang_specific
)->offset);
3382 else
3383 return gfc_conv_descriptor_offset_get (descriptor);
3384}
3385
3386
3387/* Get an expression for the array stride. */
3388
3389tree
3390gfc_conv_array_stride (tree descriptor, int dim)
3391{
3392 tree tmp;
3393 tree type;
3394
3395 type = TREE_TYPE (descriptor)((contains_struct_check ((descriptor), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3395, __FUNCTION__))->typed.type);
3396
3397 /* For descriptorless arrays use the array size. */
3398 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim)(((tree_class_check ((type), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3398, __FUNCTION__))->type_with_lang_specific.lang_specific
)->stride[dim]);
3399 if (tmp != NULL_TREE(tree) __null)
3400 return tmp;
3401
3402 tmp = gfc_conv_descriptor_stride_get (descriptor, gfc_rank_cst[dim]);
3403 return tmp;
3404}
3405
3406
3407/* Like gfc_conv_array_stride, but for the lower bound. */
3408
3409tree
3410gfc_conv_array_lbound (tree descriptor, int dim)
3411{
3412 tree tmp;
3413 tree type;
3414
3415 type = TREE_TYPE (descriptor)((contains_struct_check ((descriptor), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3415, __FUNCTION__))->typed.type);
3416
3417 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim)(((tree_class_check ((type), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3417, __FUNCTION__))->type_with_lang_specific.lang_specific
)->lbound[dim]);
3418 if (tmp != NULL_TREE(tree) __null)
3419 return tmp;
3420
3421 tmp = gfc_conv_descriptor_lbound_get (descriptor, gfc_rank_cst[dim]);
3422 return tmp;
3423}
3424
3425
3426/* Like gfc_conv_array_stride, but for the upper bound. */
3427
3428tree
3429gfc_conv_array_ubound (tree descriptor, int dim)
3430{
3431 tree tmp;
3432 tree type;
3433
3434 type = TREE_TYPE (descriptor)((contains_struct_check ((descriptor), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3434, __FUNCTION__))->typed.type);
3435
3436 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim)(((tree_class_check ((type), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3436, __FUNCTION__))->type_with_lang_specific.lang_specific
)->ubound[dim]);
3437 if (tmp != NULL_TREE(tree) __null)
3438 return tmp;
3439
3440 /* This should only ever happen when passing an assumed shape array
3441 as an actual parameter. The value will never be used. */
3442 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor))((tree_class_check ((((contains_struct_check ((descriptor), (
TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3442, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3442, __FUNCTION__))->type_common.lang_flag_2))
3443 return gfc_index_zero_nodegfc_rank_cst[0];
3444
3445 tmp = gfc_conv_descriptor_ubound_get (descriptor, gfc_rank_cst[dim]);
3446 return tmp;
3447}
3448
3449
3450/* Generate code to perform an array index bound check. */
3451
3452static tree
3453trans_array_bound_check (gfc_se * se, gfc_ss *ss, tree index, int n,
3454 locus * where, bool check_upper)
3455{
3456 tree fault;
3457 tree tmp_lo, tmp_up;
3458 tree descriptor;
3459 char *msg;
3460 const char * name = NULL__null;
3461
3462 if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS(1<<0)))
3463 return index;
3464
3465 descriptor = ss->info->data.array.descriptor;
3466
3467 index = gfc_evaluate_now (index, &se->pre);
3468
3469 /* We find a name for the error message. */
3470 name = ss->info->expr->symtree->n.sym->name;
3471 gcc_assert (name != NULL)((void)(!(name != __null) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3471, __FUNCTION__), 0 : 0));
3472
3473 if (VAR_P (descriptor)(((enum tree_code) (descriptor)->base.code) == VAR_DECL))
3474 name = IDENTIFIER_POINTER (DECL_NAME (descriptor))((const char *) (tree_check ((((contains_struct_check ((descriptor
), (TS_DECL_MINIMAL), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3474, __FUNCTION__))->decl_minimal.name)), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3474, __FUNCTION__, (IDENTIFIER_NODE)))->identifier.id.str
);
3475
3476 /* If upper bound is present, include both bounds in the error message. */
3477 if (check_upper)
3478 {
3479 tmp_lo = gfc_conv_array_lbound (descriptor, n);
3480 tmp_up = gfc_conv_array_ubound (descriptor, n);
3481
3482 if (name)
3483 msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3484 "outside of expected range (%%ld:%%ld)", n+1, name);
3485 else
3486 msg = xasprintf ("Index '%%ld' of dimension %d "
3487 "outside of expected range (%%ld:%%ld)", n+1);
3488
3489 fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3490 index, tmp_lo);
3491 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
3492 fold_convert (long_integer_type_node, index)fold_convert_loc (((location_t) 0), integer_types[itk_long], index
),
3493 fold_convert (long_integer_type_node, tmp_lo)fold_convert_loc (((location_t) 0), integer_types[itk_long], tmp_lo
),
3494 fold_convert (long_integer_type_node, tmp_up)fold_convert_loc (((location_t) 0), integer_types[itk_long], tmp_up
));
3495 fault = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3496 index, tmp_up);
3497 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
3498 fold_convert (long_integer_type_node, index)fold_convert_loc (((location_t) 0), integer_types[itk_long], index
),
3499 fold_convert (long_integer_type_node, tmp_lo)fold_convert_loc (((location_t) 0), integer_types[itk_long], tmp_lo
),
3500 fold_convert (long_integer_type_node, tmp_up)fold_convert_loc (((location_t) 0), integer_types[itk_long], tmp_up
));
3501 free (msg);
3502 }
3503 else
3504 {
3505 tmp_lo = gfc_conv_array_lbound (descriptor, n);
3506
3507 if (name)
3508 msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3509 "below lower bound of %%ld", n+1, name);
3510 else
3511 msg = xasprintf ("Index '%%ld' of dimension %d "
3512 "below lower bound of %%ld", n+1);
3513
3514 fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3515 index, tmp_lo);
3516 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
3517 fold_convert (long_integer_type_node, index)fold_convert_loc (((location_t) 0), integer_types[itk_long], index
),
3518 fold_convert (long_integer_type_node, tmp_lo)fold_convert_loc (((location_t) 0), integer_types[itk_long], tmp_lo
));
3519 free (msg);
3520 }
3521
3522 return index;
3523}
3524
3525
3526/* Return the offset for an index. Performs bound checking for elemental
3527 dimensions. Single element references are processed separately.
3528 DIM is the array dimension, I is the loop dimension. */
3529
3530static tree
3531conv_array_index_offset (gfc_se * se, gfc_ss * ss, int dim, int i,
3532 gfc_array_ref * ar, tree stride)
3533{
3534 gfc_array_info *info;
3535 tree index;
3536 tree desc;
3537 tree data;
3538
3539 info = &ss->info->data.array;
3540
3541 /* Get the index into the array for this dimension. */
3542 if (ar)
3543 {
3544 gcc_assert (ar->type != AR_ELEMENT)((void)(!(ar->type != AR_ELEMENT) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3544, __FUNCTION__), 0 : 0));
3545 switch (ar->dimen_type[dim])
3546 {
3547 case DIMEN_THIS_IMAGE:
3548 gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3548, __FUNCTION__));
3549 break;
3550 case DIMEN_ELEMENT:
3551 /* Elemental dimension. */
3552 gcc_assert (info->subscript[dim]((void)(!(info->subscript[dim] && info->subscript
[dim]->info->type == GFC_SS_SCALAR) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3553, __FUNCTION__), 0 : 0))
3553 && info->subscript[dim]->info->type == GFC_SS_SCALAR)((void)(!(info->subscript[dim] && info->subscript
[dim]->info->type == GFC_SS_SCALAR) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3553, __FUNCTION__), 0 : 0));
3554 /* We've already translated this value outside the loop. */
3555 index = info->subscript[dim]->info->data.scalar.value;
3556
3557 index = trans_array_bound_check (se, ss, index, dim, &ar->where,
3558 ar->as->type != AS_ASSUMED_SIZE
3559 || dim < ar->dimen - 1);
3560 break;
3561
3562 case DIMEN_VECTOR:
3563 gcc_assert (info && se->loop)((void)(!(info && se->loop) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3563, __FUNCTION__), 0 : 0));
3564 gcc_assert (info->subscript[dim]((void)(!(info->subscript[dim] && info->subscript
[dim]->info->type == GFC_SS_VECTOR) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3565, __FUNCTION__), 0 : 0))
3565 && info->subscript[dim]->info->type == GFC_SS_VECTOR)((void)(!(info->subscript[dim] && info->subscript
[dim]->info->type == GFC_SS_VECTOR) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3565, __FUNCTION__), 0 : 0));
3566 desc = info->subscript[dim]->info->data.array.descriptor;
3567
3568 /* Get a zero-based index into the vector. */
3569 index = fold_build2_loc (input_location, MINUS_EXPR,
3570 gfc_array_index_type,
3571 se->loop->loopvar[i], se->loop->from[i]);
3572
3573 /* Multiply the index by the stride. */
3574 index = fold_build2_loc (input_location, MULT_EXPR,
3575 gfc_array_index_type,
3576 index, gfc_conv_array_stride (desc, 0));
3577
3578 /* Read the vector to get an index into info->descriptor. */
3579 data = build_fold_indirect_ref_loc (input_location,
3580 gfc_conv_array_data (desc));
3581 index = gfc_build_array_ref (data, index, NULL__null);
3582 index = gfc_evaluate_now (index, &se->pre);
3583 index = fold_convert (gfc_array_index_type, index)fold_convert_loc (((location_t) 0), gfc_array_index_type, index
);
3584
3585 /* Do any bounds checking on the final info->descriptor index. */
3586 index = trans_array_bound_check (se, ss, index, dim, &ar->where,
3587 ar->as->type != AS_ASSUMED_SIZE
3588 || dim < ar->dimen - 1);
3589 break;
3590
3591 case DIMEN_RANGE:
3592 /* Scalarized dimension. */
3593 gcc_assert (info && se->loop)((void)(!(info && se->loop) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3593, __FUNCTION__), 0 : 0));
3594
3595 /* Multiply the loop variable by the stride and delta. */
3596 index = se->loop->loopvar[i];
3597 if (!integer_onep (info->stride[dim]))
3598 index = fold_build2_loc (input_location, MULT_EXPR,
3599 gfc_array_index_type, index,
3600 info->stride[dim]);
3601 if (!integer_zerop (info->delta[dim]))
3602 index = fold_build2_loc (input_location, PLUS_EXPR,
3603 gfc_array_index_type, index,
3604 info->delta[dim]);
3605 break;
3606
3607 default:
3608 gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3608, __FUNCTION__));
3609 }
3610 }
3611 else
3612 {
3613 /* Temporary array or derived type component. */
3614 gcc_assert (se->loop)((void)(!(se->loop) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3614, __FUNCTION__), 0 : 0));
3615 index = se->loop->loopvar[se->loop->order[i]];
3616
3617 /* Pointer functions can have stride[0] different from unity.
3618 Use the stride returned by the function call and stored in
3619 the descriptor for the temporary. */
3620 if (se->ss && se->ss->info->type == GFC_SS_FUNCTION
3621 && se->ss->info->expr
3622 && se->ss->info->expr->symtree
3623 && se->ss->info->expr->symtree->n.sym->result
3624 && se->ss->info->expr->symtree->n.sym->result->attr.pointer)
3625 stride = gfc_conv_descriptor_stride_get (info->descriptor,
3626 gfc_rank_cst[dim]);
3627
3628 if (info->delta[dim] && !integer_zerop (info->delta[dim]))
3629 index = fold_build2_loc (input_location, PLUS_EXPR,
3630 gfc_array_index_type, index, info->delta[dim]);
3631 }
3632
3633 /* Multiply by the stride. */
3634 if (stride != NULL__null && !integer_onep (stride))
3635 index = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
3636 index, stride);
3637
3638 return index;
3639}
3640
3641
3642/* Build a scalarized array reference using the vptr 'size'. */
3643
3644static bool
3645build_class_array_ref (gfc_se *se, tree base, tree index)
3646{
3647 tree size;
3648 tree decl = NULL_TREE(tree) __null;
3649 tree tmp;
3650 gfc_expr *expr = se->ss->info->expr;
3651 gfc_expr *class_expr;
3652 gfc_typespec *ts;
3653 gfc_symbol *sym;
3654
3655 tmp = !VAR_P (base)(((enum tree_code) (base)->base.code) == VAR_DECL) ? gfc_get_class_from_expr (base) : NULL_TREE(tree) __null;
3656
3657 if (tmp != NULL_TREE(tree) __null)
3658 decl = tmp;
3659 else
3660 {
3661 /* The base expression does not contain a class component, either
3662 because it is a temporary array or array descriptor. Class
3663 array functions are correctly resolved above. */
3664 if (!expr
3665 || (expr->ts.type != BT_CLASS
3666 && !gfc_is_class_array_ref (expr, NULL__null)))
3667 return false;
3668
3669 /* Obtain the expression for the class entity or component that is
3670 followed by an array reference, which is not an element, so that
3671 the span of the array can be obtained. */
3672 class_expr = gfc_find_and_cut_at_last_class_ref (expr, false, &ts);
3673
3674 if (!ts)
3675 return false;
3676
3677 sym = (!class_expr && expr) ? expr->symtree->n.sym : NULL__null;
3678 if (sym && sym->attr.function
3679 && sym == sym->result
3680 && sym->backend_decl == current_function_decl)
3681 /* The temporary is the data field of the class data component
3682 of the current function. */
3683 decl = gfc_get_fake_result_decl (sym, 0);
3684 else if (sym)
3685 {
3686 if (decl == NULL_TREE(tree) __null)
3687 decl = expr->symtree->n.sym->backend_decl;
3688 /* For class arrays the tree containing the class is stored in
3689 GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl.
3690 For all others it's sym's backend_decl directly. */
3691 if (DECL_LANG_SPECIFIC (decl)((contains_struct_check ((decl), (TS_DECL_COMMON), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3691, __FUNCTION__))->decl_common.lang_specific) && GFC_DECL_SAVED_DESCRIPTOR (decl)(((contains_struct_check ((decl), (TS_DECL_COMMON), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3691, __FUNCTION__))->decl_common.lang_specific)->saved_descriptor
))
3692 decl = GFC_DECL_SAVED_DESCRIPTOR (decl)(((contains_struct_check ((decl), (TS_DECL_COMMON), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3692, __FUNCTION__))->decl_common.lang_specific)->saved_descriptor
);
3693 }
3694 else
3695 decl = gfc_get_class_from_gfc_expr (class_expr);
3696
3697 if (POINTER_TYPE_P (TREE_TYPE (decl))(((enum tree_code) (((contains_struct_check ((decl), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3697, __FUNCTION__))->typed.type))->base.code) == POINTER_TYPE
|| ((enum tree_code) (((contains_struct_check ((decl), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3697, __FUNCTION__))->typed.type))->base.code) == REFERENCE_TYPE
))
3698 decl = build_fold_indirect_ref_loc (input_location, decl);
3699
3700 if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl))((tree_class_check ((((contains_struct_check ((decl), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3700, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3700, __FUNCTION__))->type_common.lang_flag_4))
3701 return false;
3702 }
3703
3704 se->class_vptr = gfc_evaluate_now (gfc_class_vptr_get (decl), &se->pre);
3705
3706 size = gfc_class_vtab_size_get (decl);
3707 /* For unlimited polymorphic entities then _len component needs to be
3708 multiplied with the size. */
3709 size = gfc_resize_class_size_with_len (&se->pre, decl, size);
3710 size = fold_convert (TREE_TYPE (index), size)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(index), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3710, __FUNCTION__))->typed.type), size);
3711
3712 /* Return the element in the se expression. */
3713 se->expr = gfc_build_spanned_array_ref (base, index, size);
3714 return true;
3715}
3716
3717
3718/* Indicates that the tree EXPR is a reference to an array that can’t
3719 have any negative stride. */
3720
3721static bool
3722non_negative_strides_array_p (tree expr)
3723{
3724 if (expr == NULL_TREE(tree) __null)
3725 return false;
3726
3727 tree type = TREE_TYPE (expr)((contains_struct_check ((expr), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3727, __FUNCTION__))->typed.type);
3728 if (POINTER_TYPE_P (type)(((enum tree_code) (type)->base.code) == POINTER_TYPE || (
(enum tree_code) (type)->base.code) == REFERENCE_TYPE))
3729 type = TREE_TYPE (type)((contains_struct_check ((type), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3729, __FUNCTION__))->typed.type);
3730
3731 if (TYPE_LANG_SPECIFIC (type)((tree_class_check ((type), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3731, __FUNCTION__))->type_with_lang_specific.lang_specific
))
3732 {
3733 gfc_array_kind array_kind = GFC_TYPE_ARRAY_AKIND (type)(((tree_class_check ((type), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3733, __FUNCTION__))->type_with_lang_specific.lang_specific
)->akind);
3734
3735 if (array_kind == GFC_ARRAY_ALLOCATABLE
3736 || array_kind == GFC_ARRAY_ASSUMED_SHAPE_CONT)
3737 return true;
3738 }
3739
3740 /* An array with descriptor can have negative strides.
3741 We try to be conservative and return false by default here
3742 if we don’t recognize a contiguous array instead of
3743 returning false if we can identify a non-contiguous one. */
3744 if (!GFC_ARRAY_TYPE_P (type)((tree_class_check ((type), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3744, __FUNCTION__))->type_common.lang_flag_2))
3745 return false;
3746
3747 /* If the array was originally a dummy with a descriptor, strides can be
3748 negative. */
3749 if (DECL_P (expr)(tree_code_type_tmpl <0>::tree_code_type[(int) (((enum tree_code
) (expr)->base.code))] == tcc_declaration)
3750 && DECL_LANG_SPECIFIC (expr)((contains_struct_check ((expr), (TS_DECL_COMMON), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3750, __FUNCTION__))->decl_common.lang_specific)
3751 && GFC_DECL_SAVED_DESCRIPTOR (expr)(((contains_struct_check ((expr), (TS_DECL_COMMON), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3751, __FUNCTION__))->decl_common.lang_specific)->saved_descriptor
)
3752 && GFC_DECL_SAVED_DESCRIPTOR (expr)(((contains_struct_check ((expr), (TS_DECL_COMMON), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3752, __FUNCTION__))->decl_common.lang_specific)->saved_descriptor
) != expr)
3753 return non_negative_strides_array_p (GFC_DECL_SAVED_DESCRIPTOR (expr)(((contains_struct_check ((expr), (TS_DECL_COMMON), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3753, __FUNCTION__))->decl_common.lang_specific)->saved_descriptor
));
3754
3755 return true;
3756}
3757
3758
3759/* Build a scalarized reference to an array. */
3760
3761static void
3762gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar,
3763 bool tmp_array = false)
3764{
3765 gfc_array_info *info;
3766 tree decl = NULL_TREE(tree) __null;
3767 tree index;
3768 tree base;
3769 gfc_ss *ss;
3770 gfc_expr *expr;
3771 int n;
3772
3773 ss = se->ss;
3774 expr = ss->info->expr;
3775 info = &ss->info->data.array;
3776 if (ar)
3777 n = se->loop->order[0];
3778 else
3779 n = 0;
3780
3781 index = conv_array_index_offset (se, ss, ss->dim[n], n, ar, info->stride0);
3782 /* Add the offset for this dimension to the stored offset for all other
3783 dimensions. */
3784 if (info->offset && !integer_zerop (info->offset))
3785 index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3786 index, info->offset);
3787
3788 base = build_fold_indirect_ref_loc (input_location, info->data);
3789
3790 /* Use the vptr 'size' field to access the element of a class array. */
3791 if (build_class_array_ref (se, base, index))
3792 return;
3793
3794 if (get_CFI_desc (NULL__null, expr, &decl, ar))
3795 decl = build_fold_indirect_ref_loc (input_location, decl);
3796
3797 /* A pointer array component can be detected from its field decl. Fix
3798 the descriptor, mark the resulting variable decl and pass it to
3799 gfc_build_array_ref. */
3800 if (is_pointer_array (info->descriptor)
3801 || (expr && expr->ts.deferred && info->descriptor
3802 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (info->descriptor))((tree_class_check ((((contains_struct_check ((info->descriptor
), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3802, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3802, __FUNCTION__))->type_common.lang_flag_1)))
3803 {
3804 if (TREE_CODE (info->descriptor)((enum tree_code) (info->descriptor)->base.code) == COMPONENT_REF)
3805 decl = info->descriptor;
3806 else if (TREE_CODE (info->descriptor)((enum tree_code) (info->descriptor)->base.code) == INDIRECT_REF)
3807 decl = TREE_OPERAND (info->descriptor, 0)(*((const_cast<tree*> (tree_operand_check ((info->descriptor
), (0), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3807, __FUNCTION__)))));
3808
3809 if (decl == NULL_TREE(tree) __null)
3810 decl = info->descriptor;
3811 }
3812
3813 bool non_negative_stride = tmp_array
3814 || non_negative_strides_array_p (info->descriptor);
3815 se->expr = gfc_build_array_ref (base, index, decl,
3816 non_negative_stride);
3817}
3818
3819
3820/* Translate access of temporary array. */
3821
3822void
3823gfc_conv_tmp_array_ref (gfc_se * se)
3824{
3825 se->string_length = se->ss->info->string_length;
3826 gfc_conv_scalarized_array_ref (se, NULL__null, true);
3827 gfc_advance_se_ss_chain (se);
3828}
3829
3830/* Add T to the offset pair *OFFSET, *CST_OFFSET. */
3831
3832static void
3833add_to_offset (tree *cst_offset, tree *offset, tree t)
3834{
3835 if (TREE_CODE (t)((enum tree_code) (t)->base.code) == INTEGER_CST)
3836 *cst_offset = int_const_binop (PLUS_EXPR, *cst_offset, t);
3837 else
3838 {
3839 if (!integer_zerop (*offset))
3840 *offset = fold_build2_loc (input_location, PLUS_EXPR,
3841 gfc_array_index_type, *offset, t);
3842 else
3843 *offset = t;
3844 }
3845}
3846
3847
3848static tree
3849build_array_ref (tree desc, tree offset, tree decl, tree vptr)
3850{
3851 tree tmp;
3852 tree type;
3853 tree cdesc;
3854
3855 /* For class arrays the class declaration is stored in the saved
3856 descriptor. */
3857 if (INDIRECT_REF_P (desc)(((enum tree_code) (desc)->base.code) == INDIRECT_REF)
3858 && DECL_LANG_SPECIFIC (TREE_OPERAND (desc, 0))((contains_struct_check (((*((const_cast<tree*> (tree_operand_check
((desc), (0), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3858, __FUNCTION__)))))), (TS_DECL_COMMON), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3858, __FUNCTION__))->decl_common.lang_specific)
3859 && GFC_DECL_SAVED_DESCRIPTOR (TREE_OPERAND (desc, 0))(((contains_struct_check (((*((const_cast<tree*> (tree_operand_check
((desc), (0), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3859, __FUNCTION__)))))), (TS_DECL_COMMON), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3859, __FUNCTION__))->decl_common.lang_specific)->saved_descriptor
))
3860 cdesc = gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR ((((contains_struct_check (((*((const_cast<tree*> (tree_operand_check
((desc), (0), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3861, __FUNCTION__)))))), (TS_DECL_COMMON), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3861, __FUNCTION__))->decl_common.lang_specific)->saved_descriptor
)
3861 TREE_OPERAND (desc, 0))(((contains_struct_check (((*((const_cast<tree*> (tree_operand_check
((desc), (0), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3861, __FUNCTION__)))))), (TS_DECL_COMMON), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3861, __FUNCTION__))->decl_common.lang_specific)->saved_descriptor
));
3862 else
3863 cdesc = desc;
3864
3865 /* Class container types do not always have the GFC_CLASS_TYPE_P
3866 but the canonical type does. */
3867 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cdesc))((tree_class_check ((((contains_struct_check ((cdesc), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3867, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3867, __FUNCTION__))->type_common.lang_flag_1)
3868 && TREE_CODE (cdesc)((enum tree_code) (cdesc)->base.code) == COMPONENT_REF)
3869 {
3870 type = TREE_TYPE (TREE_OPERAND (cdesc, 0))((contains_struct_check (((*((const_cast<tree*> (tree_operand_check
((cdesc), (0), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3870, __FUNCTION__)))))), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3870, __FUNCTION__))->typed.type);
3871 if (TYPE_CANONICAL (type)((tree_class_check ((type), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3871, __FUNCTION__))->type_common.canonical)
3872 && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type))((tree_class_check ((((tree_class_check ((type), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3872, __FUNCTION__))->type_common.canonical)), (tcc_type
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3872, __FUNCTION__))->type_common.lang_flag_4))
3873 vptr = gfc_class_vptr_get (TREE_OPERAND (cdesc, 0)(*((const_cast<tree*> (tree_operand_check ((cdesc), (0)
, "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3873, __FUNCTION__))))));
3874 }
3875
3876 tmp = gfc_conv_array_data (desc);
3877 tmp = build_fold_indirect_ref_loc (input_location, tmp);
3878 tmp = gfc_build_array_ref (tmp, offset, decl,
3879 non_negative_strides_array_p (desc),
3880 vptr);
3881 return tmp;
3882}
3883
3884
3885/* Build an array reference. se->expr already holds the array descriptor.
3886 This should be either a variable, indirect variable reference or component
3887 reference. For arrays which do not have a descriptor, se->expr will be
3888 the data pointer.
3889 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
3890
3891void
3892gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
3893 locus * where)
3894{
3895 int n;
3896 tree offset, cst_offset;
3897 tree tmp;
3898 tree stride;
3899 tree decl = NULL_TREE(tree) __null;
3900 gfc_se indexse;
3901 gfc_se tmpse;
3902 gfc_symbol * sym = expr->symtree->n.sym;
3903 char *var_name = NULL__null;
3904
3905 if (ar->dimen == 0)
3906 {
3907 gcc_assert (ar->codimen || sym->attr.select_rank_temporary((void)(!(ar->codimen || sym->attr.select_rank_temporary
|| (ar->as && ar->as->corank)) ? fancy_abort
("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3908, __FUNCTION__), 0 : 0))
3908 || (ar->as && ar->as->corank))((void)(!(ar->codimen || sym->attr.select_rank_temporary
|| (ar->as && ar->as->corank)) ? fancy_abort
("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3908, __FUNCTION__), 0 : 0));
3909
3910 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr))((tree_class_check ((((contains_struct_check ((se->expr), (
TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3910, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3910, __FUNCTION__))->type_common.lang_flag_1))
3911 se->expr = build_fold_indirect_ref (gfc_conv_array_data (se->expr))build_fold_indirect_ref_loc (((location_t) 0), gfc_conv_array_data
(se->expr));
3912 else
3913 {
3914 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr))((tree_class_check ((((contains_struct_check ((se->expr), (
TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3914, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3914, __FUNCTION__))->type_common.lang_flag_2)
3915 && TREE_CODE (TREE_TYPE (se->expr))((enum tree_code) (((contains_struct_check ((se->expr), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3915, __FUNCTION__))->typed.type))->base.code) == POINTER_TYPE)
3916 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
3917
3918 /* Use the actual tree type and not the wrapped coarray. */
3919 if (!se->want_pointer)
3920 se->expr = fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se->expr)),fold_convert_loc (((location_t) 0), ((tree_class_check ((((contains_struct_check
((se->expr), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3920, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3920, __FUNCTION__))->type_common.main_variant), se->
expr)
3921 se->expr)fold_convert_loc (((location_t) 0), ((tree_class_check ((((contains_struct_check
((se->expr), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3920, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 3920, __FUNCTION__))->type_common.main_variant), se->
expr);
3922 }
3923
3924 return;
3925 }
3926
3927 /* Handle scalarized references separately. */
3928 if (ar->type != AR_ELEMENT)
3929 {
3930 gfc_conv_scalarized_array_ref (se, ar);
3931 gfc_advance_se_ss_chain (se);
3932 return;
3933 }
3934
3935 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS(1<<0))
3936 {
3937 size_t len;
3938 gfc_ref *ref;
3939
3940 len = strlen (sym->name) + 1;
3941 for (ref = expr->ref; ref; ref = ref->next)
3942 {
3943 if (ref->type == REF_ARRAY && &ref->u.ar == ar)
3944 break;
3945 if (ref->type == REF_COMPONENT)
3946 len += 2 + strlen (ref->u.c.component->name);
3947 }
3948
3949 var_name = XALLOCAVEC (char, len)((char *) __builtin_alloca(sizeof (char) * (len)));
3950 strcpy (var_name, sym->name);
3951
3952 for (ref = expr->ref; ref; ref = ref->next)
3953 {
3954 if (ref->type == REF_ARRAY && &ref->u.ar == ar)
3955 break;
3956 if (ref->type == REF_COMPONENT)
3957 {
3958 strcat (var_name, "%%");
3959 strcat (var_name, ref->u.c.component->name);
3960 }
3961 }
3962 }
3963
3964 decl = se->expr;
3965 if (IS_CLASS_ARRAY (sym)(sym->ts.type == BT_CLASS && sym->ts.u.derived->
components && sym->ts.u.derived->components->
attr.dimension && !sym->ts.u.derived->components
->attr.class_pointer) && sym->attr.dummy && ar->as->type != AS_DEFERRED)
3966 decl = sym->backend_decl;
3967
3968 cst_offset = offset = gfc_index_zero_nodegfc_rank_cst[0];
3969 add_to_offset (&cst_offset, &offset, gfc_conv_array_offset (decl));
3970
3971 /* Calculate the offsets from all the dimensions. Make sure to associate
3972 the final offset so that we form a chain of loop invariant summands. */
3973 for (n = ar->dimen - 1; n >= 0; n--)
3974 {
3975 /* Calculate the index for this dimension. */
3976 gfc_init_se (&indexse, se);
3977 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
3978 gfc_add_block_to_block (&se->pre, &indexse.pre);
3979
3980 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS(1<<0)) && ! expr->no_bounds_check)
3981 {
3982 /* Check array bounds. */
3983 tree cond;
3984 char *msg;
3985
3986 /* Evaluate the indexse.expr only once. */
3987 indexse.expr = save_expr (indexse.expr);
3988
3989 /* Lower bound. */
3990 tmp = gfc_conv_array_lbound (decl, n);
3991 if (sym->attr.temporary)
3992 {
3993 gfc_init_se (&tmpse, se);
3994 gfc_conv_expr_type (&tmpse, ar->as->lower[n],
3995 gfc_array_index_type);
3996 gfc_add_block_to_block (&se->pre, &tmpse.pre);
3997 tmp = tmpse.expr;
3998 }
3999
4000 cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
4001 indexse.expr, tmp);
4002 msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4003 "below lower bound of %%ld", n+1, var_name);
4004 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
4005 fold_convert (long_integer_type_node,fold_convert_loc (((location_t) 0), integer_types[itk_long], indexse
.expr)
4006 indexse.expr)fold_convert_loc (((location_t) 0), integer_types[itk_long], indexse
.expr),
4007 fold_convert (long_integer_type_node, tmp)fold_convert_loc (((location_t) 0), integer_types[itk_long], tmp
));
4008 free (msg);
4009
4010 /* Upper bound, but not for the last dimension of assumed-size
4011 arrays. */
4012 if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE)
4013 {
4014 tmp = gfc_conv_array_ubound (decl, n);
4015 if (sym->attr.temporary)
4016 {
4017 gfc_init_se (&tmpse, se);
4018 gfc_conv_expr_type (&tmpse, ar->as->upper[n],
4019 gfc_array_index_type);
4020 gfc_add_block_to_block (&se->pre, &tmpse.pre);
4021 tmp = tmpse.expr;
4022 }
4023
4024 cond = fold_build2_loc (input_location, GT_EXPR,
4025 logical_type_node, indexse.expr, tmp);
4026 msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4027 "above upper bound of %%ld", n+1, var_name);
4028 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
4029 fold_convert (long_integer_type_node,fold_convert_loc (((location_t) 0), integer_types[itk_long], indexse
.expr)
4030 indexse.expr)fold_convert_loc (((location_t) 0), integer_types[itk_long], indexse
.expr),
4031 fold_convert (long_integer_type_node, tmp)fold_convert_loc (((location_t) 0), integer_types[itk_long], tmp
));
4032 free (msg);
4033 }
4034 }
4035
4036 /* Multiply the index by the stride. */
4037 stride = gfc_conv_array_stride (decl, n);
4038 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4039 indexse.expr, stride);
4040
4041 /* And add it to the total. */
4042 add_to_offset (&cst_offset, &offset, tmp);
4043 }
4044
4045 if (!integer_zerop (cst_offset))
4046 offset = fold_build2_loc (input_location, PLUS_EXPR,
4047 gfc_array_index_type, offset, cst_offset);
4048
4049 /* A pointer array component can be detected from its field decl. Fix
4050 the descriptor, mark the resulting variable decl and pass it to
4051 build_array_ref. */
4052 decl = NULL_TREE(tree) __null;
4053 if (get_CFI_desc (sym, expr, &decl, ar))
4054 decl = build_fold_indirect_ref_loc (input_location, decl);
4055 if (!expr->ts.deferred && !sym->attr.codimension
4056 && is_pointer_array (se->expr))
4057 {
4058 if (TREE_CODE (se->expr)((enum tree_code) (se->expr)->base.code) == COMPONENT_REF)
4059 decl = se->expr;
4060 else if (TREE_CODE (se->expr)((enum tree_code) (se->expr)->base.code) == INDIRECT_REF)
4061 decl = TREE_OPERAND (se->expr, 0)(*((const_cast<tree*> (tree_operand_check ((se->expr
), (0), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 4061, __FUNCTION__)))));
4062 else
4063 decl = se->expr;
4064 }
4065 else if (expr->ts.deferred
4066 || (sym->ts.type == BT_CHARACTER
4067 && sym->attr.select_type_temporary))
4068 {
4069 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr))((tree_class_check ((((contains_struct_check ((se->expr), (
TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 4069, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 4069, __FUNCTION__))->type_common.lang_flag_1))
4070 {
4071 decl = se->expr;
4072 if (TREE_CODE (decl)((enum tree_code) (decl)->base.code) == INDIRECT_REF)
4073 decl = TREE_OPERAND (decl, 0)(*((const_cast<tree*> (tree_operand_check ((decl), (0),
"/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 4073, __FUNCTION__)))));
4074 }
4075 else
4076 decl = sym->backend_decl;
4077 }
4078 else if (sym->ts.type == BT_CLASS)
4079 {
4080 if (UNLIMITED_POLY (sym)(sym != __null && sym->ts.type == BT_CLASS &&
sym->ts.u.derived->components && sym->ts.u.
derived->components->ts.u.derived && sym->ts
.u.derived->components->ts.u.derived->attr.unlimited_polymorphic
))
4081 {
4082 gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (expr);
4083 gfc_init_se (&tmpse, NULL__null);
4084 gfc_conv_expr (&tmpse, class_expr);
4085 if (!se->class_vptr)
4086 se->class_vptr = gfc_class_vptr_get (tmpse.expr);
4087 gfc_free_expr (class_expr);
4088 decl = tmpse.expr;
4089 }
4090 else
4091 decl = NULL_TREE(tree) __null;
4092 }
4093
4094 se->expr = build_array_ref (se->expr, offset, decl, se->class_vptr);
4095}
4096
4097
4098/* Add the offset corresponding to array's ARRAY_DIM dimension and loop's
4099 LOOP_DIM dimension (if any) to array's offset. */
4100
4101static void
4102add_array_offset (stmtblock_t *pblock, gfc_loopinfo *loop, gfc_ss *ss,
4103 gfc_array_ref *ar, int array_dim, int loop_dim)
4104{
4105 gfc_se se;
4106 gfc_array_info *info;
4107 tree stride, index;
4108
4109 info = &ss->info->data.array;
4110
4111 gfc_init_se (&se, NULL__null);
4112 se.loop = loop;
4113 se.expr = info->descriptor;
4114 stride = gfc_conv_array_stride (info->descriptor, array_dim);
4115 index = conv_array_index_offset (&se, ss, array_dim, loop_dim, ar, stride);
4116 gfc_add_block_to_block (pblock, &se.pre);
4117
4118 info->offset = fold_build2_loc (input_location, PLUS_EXPR,
4119 gfc_array_index_type,
4120 info->offset, index);
4121 info->offset = gfc_evaluate_now (info->offset, pblock);
4122}
4123
4124
4125/* Generate the code to be executed immediately before entering a
4126 scalarization loop. */
4127
4128static void
4129gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
4130 stmtblock_t * pblock)
4131{
4132 tree stride;
4133 gfc_ss_info *ss_info;
4134 gfc_array_info *info;
4135 gfc_ss_type ss_type;
4136 gfc_ss *ss, *pss;
4137 gfc_loopinfo *ploop;
4138 gfc_array_ref *ar;
4139 int i;
4140
4141 /* This code will be executed before entering the scalarization loop
4142 for this dimension. */
4143 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4144 {
4145 ss_info = ss->info;
4146
4147 if ((ss_info->useflags & flag) == 0)
4148 continue;
4149
4150 ss_type = ss_info->type;
4151 if (ss_type != GFC_SS_SECTION
4152 && ss_type != GFC_SS_FUNCTION
4153 && ss_type != GFC_SS_CONSTRUCTOR
4154 && ss_type != GFC_SS_COMPONENT)
4155 continue;
4156
4157 info = &ss_info->data.array;
4158
4159 gcc_assert (dim < ss->dimen)((void)(!(dim < ss->dimen) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 4159, __FUNCTION__), 0 : 0));
4160 gcc_assert (ss->dimen == loop->dimen)((void)(!(ss->dimen == loop->dimen) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 4160, __FUNCTION__), 0 : 0));
4161
4162 if (info->ref)
4163 ar = &info->ref->u.ar;
4164 else
4165 ar = NULL__null;
4166
4167 if (dim == loop->dimen - 1 && loop->parent != NULL__null)
4168 {
4169 /* If we are in the outermost dimension of this loop, the previous
4170 dimension shall be in the parent loop. */
4171 gcc_assert (ss->parent != NULL)((void)(!(ss->parent != __null) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 4171, __FUNCTION__), 0 : 0));
4172
4173 pss = ss->parent;
4174 ploop = loop->parent;
4175
4176 /* ss and ss->parent are about the same array. */
4177 gcc_assert (ss_info == pss->info)((void)(!(ss_info == pss->info) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 4177, __FUNCTION__), 0 : 0));
4178 }
4179 else
4180 {
4181 ploop = loop;
4182 pss = ss;
4183 }
4184
4185 if (dim == loop->dimen - 1)
4186 i = 0;
4187 else
4188 i = dim + 1;
4189
4190 /* For the time being, there is no loop reordering. */
4191 gcc_assert (i == ploop->order[i])((void)(!(i == ploop->order[i]) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 4191, __FUNCTION__), 0 : 0));
4192 i = ploop->order[i];
4193
4194 if (dim == loop->dimen - 1 && loop->parent == NULL__null)
4195 {
4196 stride = gfc_conv_array_stride (info->descriptor,
4197 innermost_ss (ss)->dim[i]);
4198
4199 /* Calculate the stride of the innermost loop. Hopefully this will
4200 allow the backend optimizers to do their stuff more effectively.
4201 */
4202 info->stride0 = gfc_evaluate_now (stride, pblock);
4203
4204 /* For the outermost loop calculate the offset due to any
4205 elemental dimensions. It will have been initialized with the
4206 base offset of the array. */
4207 if (info->ref)
4208 {
4209 for (i = 0; i < ar->dimen; i++)
4210 {
4211 if (ar->dimen_type[i] != DIMEN_ELEMENT)
4212 continue;
4213
4214 add_array_offset (pblock, loop, ss, ar, i, /* unused */ -1);
4215 }
4216 }
4217 }
4218 else
4219 /* Add the offset for the previous loop dimension. */
4220 add_array_offset (pblock, ploop, ss, ar, pss->dim[i], i);
4221
4222 /* Remember this offset for the second loop. */
4223 if (dim == loop->temp_dim - 1 && loop->parent == NULL__null)
4224 info->saved_offset = info->offset;
4225 }
4226}
4227
4228
4229/* Start a scalarized expression. Creates a scope and declares loop
4230 variables. */
4231
4232void
4233gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
4234{
4235 int dim;
4236 int n;
4237 int flags;
4238
4239 gcc_assert (!loop->array_parameter)((void)(!(!loop->array_parameter) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 4239, __FUNCTION__), 0 : 0));
4240
4241 for (dim = loop->dimen - 1; dim >= 0; dim--)
4242 {
4243 n = loop->order[dim];
4244
4245 gfc_start_block (&loop->code[n]);
4246
4247 /* Create the loop variable. */
4248 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
4249
4250 if (dim < loop->temp_dim)
4251 flags = 3;
4252 else
4253 flags = 1;
4254 /* Calculate values that will be constant within this loop. */
4255 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
4256 }
4257 gfc_start_block (pbody);
4258}
4259
4260
4261/* Generates the actual loop code for a scalarization loop. */
4262
4263static void
4264gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
4265 stmtblock_t * pbody)
4266{
4267 stmtblock_t block;
4268 tree cond;
4269 tree tmp;
4270 tree loopbody;
4271 tree exit_label;
4272 tree stmt;
4273 tree init;
4274 tree incr;
4275
4276 if ((ompws_flags & (OMPWS_WORKSHARE_FLAG1 | OMPWS_SCALARIZER_WS4
4277 | OMPWS_SCALARIZER_BODY8))
4278 == (OMPWS_WORKSHARE_FLAG1 | OMPWS_SCALARIZER_WS4)
4279 && n == loop->dimen - 1)
4280 {
4281 /* We create an OMP_FOR construct for the outermost scalarized loop. */
4282 init = make_tree_vec (1);
4283 cond = make_tree_vec (1);
4284 incr = make_tree_vec (1);
4285
4286 /* Cycle statement is implemented with a goto. Exit statement must not
4287 be present for this loop. */
4288 exit_label = gfc_build_label_decl (NULL_TREE(tree) __null);
4289 TREE_USED (exit_label)((exit_label)->base.used_flag) = 1;
4290
4291 /* Label for cycle statements (if needed). */
4292 tmp = build1_v (LABEL_EXPR, exit_label)fold_build1_loc (input_location, LABEL_EXPR, global_trees[TI_VOID_TYPE
], exit_label);
4293 gfc_add_expr_to_block (pbody, tmp);
4294
4295 stmt = make_node (OMP_FOR);
4296
4297 TREE_TYPE (stmt)((contains_struct_check ((stmt), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 4297, __FUNCTION__))->typed.type) = void_type_nodeglobal_trees[TI_VOID_TYPE];
4298 OMP_FOR_BODY (stmt)(*((const_cast<tree*> (tree_operand_check (((tree_range_check
((stmt), (OMP_FOR), (OACC_LOOP), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 4298, __FUNCTION__))), (0), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 4298, __FUNCTION__))))) = loopbody = gfc_finish_block (pbody);
4299
4300 OMP_FOR_CLAUSES (stmt)(*((const_cast<tree*> (tree_operand_check (((tree_range_check
((stmt), (OMP_FOR), (OACC_LOOP), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 4300, __FUNCTION__))), (1), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 4300, __FUNCTION__))))) = build_omp_clause (input_location,
4301 OMP_CLAUSE_SCHEDULE);
4302 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt))((omp_clause_subcode_check (((*((const_cast<tree*> (tree_operand_check
(((tree_range_check ((stmt), (OMP_FOR), (OACC_LOOP), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 4302, __FUNCTION__))), (1), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 4302, __FUNCTION__)))))), (OMP_CLAUSE_SCHEDULE), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 4302, __FUNCTION__))->omp_clause.subcode.schedule_kind)
4303 = OMP_CLAUSE_SCHEDULE_STATIC;
4304 if (ompws_flags & OMPWS_NOWAIT16)
4305 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt))((contains_struct_check (((tree_check (((*((const_cast<tree
*> (tree_operand_check (((tree_range_check ((stmt), (OMP_FOR
), (OACC_LOOP), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 4305, __FUNCTION__))), (1), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 4305, __FUNCTION__)))))), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 4305, __FUNCTION__, (OMP_CLAUSE)))), (TS_COMMON), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 4305, __FUNCTION__))->common.chain)
4306 = build_omp_clause (input_location, OMP_CLAUSE_NOWAIT);
4307
4308 /* Initialize the loopvar. */
4309 TREE_VEC_ELT (init, 0)(*((const_cast<tree *> (tree_vec_elt_check ((init), (0)
, "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 4309, __FUNCTION__))))) = build2_v (MODIFY_EXPR, loop->loopvar[n],fold_build2_loc (input_location, MODIFY_EXPR, global_trees[TI_VOID_TYPE
], loop->loopvar[n], loop->from[n])
4310 loop->from[n])fold_build2_loc (input_location, MODIFY_EXPR, global_trees[TI_VOID_TYPE
], loop->loopvar[n], loop->from[n]);
4311 OMP_FOR_INIT (stmt)(*((const_cast<tree*> (tree_operand_check (((tree_range_check
((stmt), (OMP_FOR), (OACC_LOOP), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 4311, __FUNCTION__))), (2), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 4311, __FUNCTION__))))) = init;
4312 /* The exit condition. */
4313 TREE_VEC_ELT (cond, 0)(*((const_cast<tree *> (tree_vec_elt_check ((cond), (0)
, "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 4313, __FUNCTION__))))) = build2_loc (input_location, LE_EXPR,
4314 logical_type_node,
4315 loop->loopvar[n], loop->to[n]);
4316 SET_EXPR_LOCATION (TREE_VEC_ELT (cond, 0), input_location)(expr_check ((((*((const_cast<tree *> (tree_vec_elt_check
((cond), (0), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 4316, __FUNCTION__))))))), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 4316, __FUNCTION__))->exp.locus = (input_location);
4317 OMP_FOR_COND (stmt)(*((const_cast<tree*> (tree_operand_check (((tree_range_check
((stmt), (OMP_FOR), (OACC_LOOP), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 4317, __FUNCTION__))), (3), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 4317, __FUNCTION__))))) = cond;
4318 /* Increment the loopvar. */
4319 tmp = build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4320 loop->loopvar[n], gfc_index_one_nodegfc_rank_cst[1]);
4321 TREE_VEC_ELT (incr, 0)(*((const_cast<tree *> (tree_vec_elt_check ((incr), (0)
, "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 4321, __FUNCTION__))))) = fold_build2_loc (input_location, MODIFY_EXPR,
4322 void_type_nodeglobal_trees[TI_VOID_TYPE], loop->loopvar[n], tmp);
4323 OMP_FOR_INCR (stmt)(*((const_cast<tree*> (tree_operand_check (((tree_range_check
((stmt), (OMP_FOR), (OACC_LOOP), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 4323, __FUNCTION__))), (4), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 4323, __FUNCTION__))))) = incr;
4324
4325 ompws_flags &= ~OMPWS_CURR_SINGLEUNIT2;
4326 gfc_add_expr_to_block (&loop->code[n], stmt);
4327 }
4328 else
4329 {
4330 bool reverse_loop = (loop->reverse[n] == GFC_REVERSE_SET)
4331 && (loop->temp_ss == NULL__null);
4332
4333 loopbody = gfc_finish_block (pbody);
4334
4335 if (reverse_loop)
4336 std::swap (loop->from[n], loop->to[n]);
4337
4338 /* Initialize the loopvar. */
4339 if (loop->loopvar[n] != loop->from[n])
4340 gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
4341
4342 exit_label = gfc_build_label_decl (NULL_TREE(tree) __null);
4343
4344 /* Generate the loop body. */
4345 gfc_init_block (&block);
4346
4347 /* The exit condition. */
4348 cond = fold_build2_loc (input_location, reverse_loop ? LT_EXPR : GT_EXPR,
4349 logical_type_node, loop->loopvar[n], loop->to[n]);
4350 tmp = build1_v (GOTO_EXPR, exit_label)fold_build1_loc (input_location, GOTO_EXPR, global_trees[TI_VOID_TYPE
], exit_label);
4351 TREE_USED (exit_label)((exit_label)->base.used_flag) = 1;
4352 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location))fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], cond, tmp, build_empty_stmt (input_location));
4353 gfc_add_expr_to_block (&block, tmp);
4354
4355 /* The main body. */
4356 gfc_add_expr_to_block (&block, loopbody);
4357
4358 /* Increment the loopvar. */
4359 tmp = fold_build2_loc (input_location,
4360 reverse_loop ? MINUS_EXPR : PLUS_EXPR,
4361 gfc_array_index_type, loop->loopvar[n],
4362 gfc_index_one_nodegfc_rank_cst[1]);
4363
4364 gfc_add_modify (&block, loop->loopvar[n], tmp);
4365
4366 /* Build the loop. */
4367 tmp = gfc_finish_block (&block);
4368 tmp = build1_v (LOOP_EXPR, tmp)fold_build1_loc (input_location, LOOP_EXPR, global_trees[TI_VOID_TYPE
], tmp);
4369 gfc_add_expr_to_block (&loop->code[n], tmp);
4370
4371 /* Add the exit label. */
4372 tmp = build1_v (LABEL_EXPR, exit_label)fold_build1_loc (input_location, LABEL_EXPR, global_trees[TI_VOID_TYPE
], exit_label);
4373 gfc_add_expr_to_block (&loop->code[n], tmp);
4374 }
4375
4376}
4377
4378
4379/* Finishes and generates the loops for a scalarized expression. */
4380
4381void
4382gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
4383{
4384 int dim;
4385 int n;
4386 gfc_ss *ss;
4387 stmtblock_t *pblock;
4388 tree tmp;
4389
4390 pblock = body;
4391 /* Generate the loops. */
4392 for (dim = 0; dim < loop->dimen; dim++)
4393 {
4394 n = loop->order[dim];
4395 gfc_trans_scalarized_loop_end (loop, n, pblock);
4396 loop->loopvar[n] = NULL_TREE(tree) __null;
4397 pblock = &loop->code[n];
4398 }
4399
4400 tmp = gfc_finish_block (pblock);
4401 gfc_add_expr_to_block (&loop->pre, tmp);
4402
4403 /* Clear all the used flags. */
4404 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4405 if (ss->parent == NULL__null)
4406 ss->info->useflags = 0;
4407}
4408
4409
4410/* Finish the main body of a scalarized expression, and start the secondary
4411 copying body. */
4412
4413void
4414gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
4415{
4416 int dim;
4417 int n;
4418 stmtblock_t *pblock;
4419 gfc_ss *ss;
4420
4421 pblock = body;
4422 /* We finish as many loops as are used by the temporary. */
4423 for (dim = 0; dim < loop->temp_dim - 1; dim++)
4424 {
4425 n = loop->order[dim];
4426 gfc_trans_scalarized_loop_end (loop, n, pblock);
4427 loop->loopvar[n] = NULL_TREE(tree) __null;
4428 pblock = &loop->code[n];
4429 }
4430
4431 /* We don't want to finish the outermost loop entirely. */
4432 n = loop->order[loop->temp_dim - 1];
4433 gfc_trans_scalarized_loop_end (loop, n, pblock);
4434
4435 /* Restore the initial offsets. */
4436 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4437 {
4438 gfc_ss_type ss_type;
4439 gfc_ss_info *ss_info;
4440
4441 ss_info = ss->info;
4442
4443 if ((ss_info->useflags & 2) == 0)
4444 continue;
4445
4446 ss_type = ss_info->type;
4447 if (ss_type != GFC_SS_SECTION
4448 && ss_type != GFC_SS_FUNCTION
4449 && ss_type != GFC_SS_CONSTRUCTOR
4450 && ss_type != GFC_SS_COMPONENT)
4451 continue;
4452
4453 ss_info->data.array.offset = ss_info->data.array.saved_offset;
4454 }
4455
4456 /* Restart all the inner loops we just finished. */
4457 for (dim = loop->temp_dim - 2; dim >= 0; dim--)
4458 {
4459 n = loop->order[dim];
4460
4461 gfc_start_block (&loop->code[n]);
4462
4463 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
4464
4465 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
4466 }
4467
4468 /* Start a block for the secondary copying code. */
4469 gfc_start_block (body);
4470}
4471
4472
4473/* Precalculate (either lower or upper) bound of an array section.
4474 BLOCK: Block in which the (pre)calculation code will go.
4475 BOUNDS[DIM]: Where the bound value will be stored once evaluated.
4476 VALUES[DIM]: Specified bound (NULL <=> unspecified).
4477 DESC: Array descriptor from which the bound will be picked if unspecified
4478 (either lower or upper bound according to LBOUND). */
4479
4480static void
4481evaluate_bound (stmtblock_t *block, tree *bounds, gfc_expr ** values,
4482 tree desc, int dim, bool lbound, bool deferred)
4483{
4484 gfc_se se;
4485 gfc_expr * input_val = values[dim];
4486 tree *output = &bounds[dim];
4487
4488
4489 if (input_val)
4490 {
4491 /* Specified section bound. */
4492 gfc_init_se (&se, NULL__null);
4493 gfc_conv_expr_type (&se, input_val, gfc_array_index_type);
4494 gfc_add_block_to_block (block, &se.pre);
4495 *output = se.expr;
4496 }
4497 else if (deferred && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))((tree_class_check ((((contains_struct_check ((desc), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 4497, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 4497, __FUNCTION__))->type_common.lang_flag_1))
4498 {
4499 /* The gfc_conv_array_lbound () routine returns a constant zero for
4500 deferred length arrays, which in the scalarizer wreaks havoc, when
4501 copying to a (newly allocated) one-based array.
4502 Keep returning the actual result in sync for both bounds. */
4503 *output = lbound ? gfc_conv_descriptor_lbound_get (desc,
4504 gfc_rank_cst[dim]):
4505 gfc_conv_descriptor_ubound_get (desc,
4506 gfc_rank_cst[dim]);
4507 }
4508 else
4509 {
4510 /* No specific bound specified so use the bound of the array. */
4511 *output = lbound ? gfc_conv_array_lbound (desc, dim) :
4512 gfc_conv_array_ubound (desc, dim);
4513 }
4514 *output = gfc_evaluate_now (*output, block);
4515}
4516
4517
4518/* Calculate the lower bound of an array section. */
4519
4520static void
4521gfc_conv_section_startstride (stmtblock_t * block, gfc_ss * ss, int dim)
4522{
4523 gfc_expr *stride = NULL__null;
4524 tree desc;
4525 gfc_se se;
4526 gfc_array_info *info;
4527 gfc_array_ref *ar;
4528
4529 gcc_assert (ss->info->type == GFC_SS_SECTION)((void)(!(ss->info->type == GFC_SS_SECTION) ? fancy_abort
("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 4529, __FUNCTION__), 0 : 0));
4530
4531 info = &ss->info->data.array;
4532 ar = &info->ref->u.ar;
4533
4534 if (ar->dimen_type[dim] == DIMEN_VECTOR)
4535 {
4536 /* We use a zero-based index to access the vector. */
4537 info->start[dim] = gfc_index_zero_nodegfc_rank_cst[0];
4538 info->end[dim] = NULL__null;
4539 info->stride[dim] = gfc_index_one_nodegfc_rank_cst[1];
4540 return;
4541 }
4542
4543 gcc_assert (ar->dimen_type[dim] == DIMEN_RANGE((void)(!(ar->dimen_type[dim] == DIMEN_RANGE || ar->dimen_type
[dim] == DIMEN_THIS_IMAGE) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 4544, __FUNCTION__), 0 : 0))
4544 || ar->dimen_type[dim] == DIMEN_THIS_IMAGE)((void)(!(ar->dimen_type[dim] == DIMEN_RANGE || ar->dimen_type
[dim] == DIMEN_THIS_IMAGE) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 4544, __FUNCTION__), 0 : 0));
4545 desc = info->descriptor;
4546 stride = ar->stride[dim];
4547
4548
4549 /* Calculate the start of the range. For vector subscripts this will
4550 be the range of the vector. */
4551 evaluate_bound (block, info->start, ar->start, desc, dim, true,
4552 ar->as->type == AS_DEFERRED);
4553
4554 /* Similarly calculate the end. Although this is not used in the
4555 scalarizer, it is needed when checking bounds and where the end
4556 is an expression with side-effects. */
4557 evaluate_bound (block, info->end, ar->end, desc, dim, false,
4558 ar->as->type == AS_DEFERRED);
4559
4560
4561 /* Calculate the stride. */
4562 if (stride == NULL__null)
4563 info->stride[dim] = gfc_index_one_nodegfc_rank_cst[1];
4564 else
4565 {
4566 gfc_init_se (&se, NULL__null);
4567 gfc_conv_expr_type (&se, stride, gfc_array_index_type);
4568 gfc_add_block_to_block (block, &se.pre);
4569 info->stride[dim] = gfc_evaluate_now (se.expr, block);
4570 }
4571}
4572
4573
4574/* Calculates the range start and stride for a SS chain. Also gets the
4575 descriptor and data pointer. The range of vector subscripts is the size
4576 of the vector. Array bounds are also checked. */
4577
4578void
4579gfc_conv_ss_startstride (gfc_loopinfo * loop)
4580{
4581 int n;
4582 tree tmp;
4583 gfc_ss *ss;
4584 tree desc;
4585
4586 gfc_loopinfo * const outer_loop = outermost_loop (loop);
4587
4588 loop->dimen = 0;
4589 /* Determine the rank of the loop. */
4590 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4591 {
4592 switch (ss->info->type)
4593 {
4594 case GFC_SS_SECTION:
4595 case GFC_SS_CONSTRUCTOR:
4596 case GFC_SS_FUNCTION:
4597 case GFC_SS_COMPONENT:
4598 loop->dimen = ss->dimen;
4599 goto done;
4600
4601 /* As usual, lbound and ubound are exceptions!. */
4602 case GFC_SS_INTRINSIC:
4603 switch (ss->info->expr->value.function.isym->id)
4604 {
4605 case GFC_ISYM_LBOUND:
4606 case GFC_ISYM_UBOUND:
4607 case GFC_ISYM_LCOBOUND:
4608 case GFC_ISYM_UCOBOUND:
4609 case GFC_ISYM_SHAPE:
4610 case GFC_ISYM_THIS_IMAGE:
4611 loop->dimen = ss->dimen;
4612 goto done;
4613
4614 default:
4615 break;
4616 }
4617
4618 default:
4619 break;
4620 }
4621 }
4622
4623 /* We should have determined the rank of the expression by now. If
4624 not, that's bad news. */
4625 gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 4625, __FUNCTION__));
4626
4627done:
4628 /* Loop over all the SS in the chain. */
4629 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4630 {
4631 gfc_ss_info *ss_info;
4632 gfc_array_info *info;
4633 gfc_expr *expr;
4634
4635 ss_info = ss->info;
4636 expr = ss_info->expr;
4637 info = &ss_info->data.array;
4638
4639 if (expr && expr->shape && !info->shape)
4640 info->shape = expr->shape;
4641
4642 switch (ss_info->type)
4643 {
4644 case GFC_SS_SECTION:
4645 /* Get the descriptor for the array. If it is a cross loops array,
4646 we got the descriptor already in the outermost loop. */
4647 if (ss->parent == NULL__null)
4648 gfc_conv_ss_descriptor (&outer_loop->pre, ss,
4649 !loop->array_parameter);
4650
4651 for (n = 0; n < ss->dimen; n++)
4652 gfc_conv_section_startstride (&outer_loop->pre, ss, ss->dim[n]);
4653 break;
4654
4655 case GFC_SS_INTRINSIC:
4656 switch (expr->value.function.isym->id)
4657 {
4658 /* Fall through to supply start and stride. */
4659 case GFC_ISYM_LBOUND:
4660 case GFC_ISYM_UBOUND:
4661 /* This is the variant without DIM=... */
4662 gcc_assert (expr->value.function.actual->next->expr == NULL)((void)(!(expr->value.function.actual->next->expr ==
__null) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 4662, __FUNCTION__), 0 : 0));
4663 /* Fall through. */
4664
4665 case GFC_ISYM_SHAPE:
4666 {
4667 gfc_expr *arg;
4668
4669 arg = expr->value.function.actual->expr;
4670 if (arg->rank == -1)
4671 {
4672 gfc_se se;
4673 tree rank, tmp;
4674
4675 /* The rank (hence the return value's shape) is unknown,
4676 we have to retrieve it. */
4677 gfc_init_se (&se, NULL__null);
4678 se.descriptor_only = 1;
4679 gfc_conv_expr (&se, arg);
4680 /* This is a bare variable, so there is no preliminary
4681 or cleanup code. */
4682 gcc_assert (se.pre.head == NULL_TREE((void)(!(se.pre.head == (tree) __null && se.post.head
== (tree) __null) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 4683, __FUNCTION__), 0 : 0))
4683 && se.post.head == NULL_TREE)((void)(!(se.pre.head == (tree) __null && se.post.head
== (tree) __null) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 4683, __FUNCTION__), 0 : 0));
4684 rank = gfc_conv_descriptor_rank (se.expr);
4685 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4686 gfc_array_index_type,
4687 fold_convert (gfc_array_index_type,fold_convert_loc (((location_t) 0), gfc_array_index_type, rank
)
4688 rank)fold_convert_loc (((location_t) 0), gfc_array_index_type, rank
),
4689 gfc_index_one_nodegfc_rank_cst[1]);
4690 info->end[0] = gfc_evaluate_now (tmp, &outer_loop->pre);
4691 info->start[0] = gfc_index_zero_nodegfc_rank_cst[0];
4692 info->stride[0] = gfc_index_one_nodegfc_rank_cst[1];
4693 continue;
4694 }
4695 /* Otherwise fall through GFC_SS_FUNCTION. */
4696 gcc_fallthrough ();
4697 }
4698 case GFC_ISYM_LCOBOUND:
4699 case GFC_ISYM_UCOBOUND:
4700 case GFC_ISYM_THIS_IMAGE:
4701 break;
4702
4703 default:
4704 continue;
4705 }
4706
4707 /* FALLTHRU */
4708 case GFC_SS_CONSTRUCTOR:
4709 case GFC_SS_FUNCTION:
4710 for (n = 0; n < ss->dimen; n++)
4711 {
4712 int dim = ss->dim[n];
4713
4714 info->start[dim] = gfc_index_zero_nodegfc_rank_cst[0];
4715 info->end[dim] = gfc_index_zero_nodegfc_rank_cst[0];
4716 info->stride[dim] = gfc_index_one_nodegfc_rank_cst[1];
4717 }
4718 break;
4719
4720 default:
4721 break;
4722 }
4723 }
4724
4725 /* The rest is just runtime bounds checking. */
4726 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS(1<<0))
4727 {
4728 stmtblock_t block;
4729 tree lbound, ubound;
4730 tree end;
4731 tree size[GFC_MAX_DIMENSIONS15];
4732 tree stride_pos, stride_neg, non_zerosized, tmp2, tmp3;
4733 gfc_array_info *info;
4734 char *msg;
4735 int dim;
4736
4737 gfc_start_block (&block);
4738
4739 for (n = 0; n < loop->dimen; n++)
4740 size[n] = NULL_TREE(tree) __null;
4741
4742 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4743 {
4744 stmtblock_t inner;
4745 gfc_ss_info *ss_info;
4746 gfc_expr *expr;
4747 locus *expr_loc;
4748 const char *expr_name;
4749
4750 ss_info = ss->info;
4751 if (ss_info->type != GFC_SS_SECTION)
4752 continue;
4753
4754 /* Catch allocatable lhs in f2003. */
4755 if (flag_realloc_lhsglobal_options.x_flag_realloc_lhs && ss->no_bounds_check)
4756 continue;
4757
4758 expr = ss_info->expr;
4759 expr_loc = &expr->where;
4760 expr_name = expr->symtree->name;
4761
4762 gfc_start_block (&inner);
4763
4764 /* TODO: range checking for mapped dimensions. */
4765 info = &ss_info->data.array;
4766
4767 /* This code only checks ranges. Elemental and vector
4768 dimensions are checked later. */
4769 for (n = 0; n < loop->dimen; n++)
4770 {
4771 bool check_upper;
4772
4773 dim = ss->dim[n];
4774 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
4775 continue;
4776
4777 if (dim == info->ref->u.ar.dimen - 1
4778 && info->ref->u.ar.as->type == AS_ASSUMED_SIZE)
4779 check_upper = false;
4780 else
4781 check_upper = true;
4782
4783 /* Zero stride is not allowed. */
4784 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
4785 info->stride[dim], gfc_index_zero_nodegfc_rank_cst[0]);
4786 msg = xasprintf ("Zero stride is not allowed, for dimension %d "
4787 "of array '%s'", dim + 1, expr_name);
4788 gfc_trans_runtime_check (true, false, tmp, &inner,
4789 expr_loc, msg);
4790 free (msg);
4791
4792 desc = info->descriptor;
4793
4794 /* This is the run-time equivalent of resolve.cc's
4795 check_dimension(). The logical is more readable there
4796 than it is here, with all the trees. */
4797 lbound = gfc_conv_array_lbound (desc, dim);
4798 end = info->end[dim];
4799 if (check_upper)
4800 ubound = gfc_conv_array_ubound (desc, dim);
4801 else
4802 ubound = NULL__null;
4803
4804 /* non_zerosized is true when the selected range is not
4805 empty. */
4806 stride_pos = fold_build2_loc (input_location, GT_EXPR,
4807 logical_type_node, info->stride[dim],
4808 gfc_index_zero_nodegfc_rank_cst[0]);
4809 tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
4810 info->start[dim], end);
4811 stride_pos = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4812 logical_type_node, stride_pos, tmp);
4813
4814 stride_neg = fold_build2_loc (input_location, LT_EXPR,
4815 logical_type_node,
4816 info->stride[dim], gfc_index_zero_nodegfc_rank_cst[0]);
4817 tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
4818 info->start[dim], end);
4819 stride_neg = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4820 logical_type_node,
4821 stride_neg, tmp);
4822 non_zerosized = fold_build2_loc (input_location, TRUTH_OR_EXPR,
4823 logical_type_node,
4824 stride_pos, stride_neg);
4825
4826 /* Check the start of the range against the lower and upper
4827 bounds of the array, if the range is not empty.
4828 If upper bound is present, include both bounds in the
4829 error message. */
4830 if (check_upper)
4831 {
4832 tmp = fold_build2_loc (input_location, LT_EXPR,
4833 logical_type_node,
4834 info->start[dim], lbound);
4835 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4836 logical_type_node,
4837 non_zerosized, tmp);
4838 tmp2 = fold_build2_loc (input_location, GT_EXPR,
4839 logical_type_node,
4840 info->start[dim], ubound);
4841 tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4842 logical_type_node,
4843 non_zerosized, tmp2);
4844 msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4845 "outside of expected range (%%ld:%%ld)",
4846 dim + 1, expr_name);
4847 gfc_trans_runtime_check (true, false, tmp, &inner,
4848 expr_loc, msg,
4849 fold_convert (long_integer_type_node, info->start[dim])fold_convert_loc (((location_t) 0), integer_types[itk_long], info
->start[dim]),
4850 fold_convert (long_integer_type_node, lbound)fold_convert_loc (((location_t) 0), integer_types[itk_long], lbound
),
4851 fold_convert (long_integer_type_node, ubound)fold_convert_loc (((location_t) 0), integer_types[itk_long], ubound
));
4852 gfc_trans_runtime_check (true, false, tmp2, &inner,
4853 expr_loc, msg,
4854 fold_convert (long_integer_type_node, info->start[dim])fold_convert_loc (((location_t) 0), integer_types[itk_long], info
->start[dim]),
4855 fold_convert (long_integer_type_node, lbound)fold_convert_loc (((location_t) 0), integer_types[itk_long], lbound
),
4856 fold_convert (long_integer_type_node, ubound)fold_convert_loc (((location_t) 0), integer_types[itk_long], ubound
));
4857 free (msg);
4858 }
4859 else
4860 {
4861 tmp = fold_build2_loc (input_location, LT_EXPR,
4862 logical_type_node,
4863 info->start[dim], lbound);
4864 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4865 logical_type_node, non_zerosized, tmp);
4866 msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4867 "below lower bound of %%ld",
4868 dim + 1, expr_name);
4869 gfc_trans_runtime_check (true, false, tmp, &inner,
4870 expr_loc, msg,
4871 fold_convert (long_integer_type_node, info->start[dim])fold_convert_loc (((location_t) 0), integer_types[itk_long], info
->start[dim]),
4872 fold_convert (long_integer_type_node, lbound)fold_convert_loc (((location_t) 0), integer_types[itk_long], lbound
));
4873 free (msg);
4874 }
4875
4876 /* Compute the last element of the range, which is not
4877 necessarily "end" (think 0:5:3, which doesn't contain 5)
4878 and check it against both lower and upper bounds. */
4879
4880 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4881 gfc_array_index_type, end,
4882 info->start[dim]);
4883 tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
4884 gfc_array_index_type, tmp,
4885 info->stride[dim]);
4886 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4887 gfc_array_index_type, end, tmp);
4888 tmp2 = fold_build2_loc (input_location, LT_EXPR,
4889 logical_type_node, tmp, lbound);
4890 tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4891 logical_type_node, non_zerosized, tmp2);
4892 if (check_upper)
4893 {
4894 tmp3 = fold_build2_loc (input_location, GT_EXPR,
4895 logical_type_node, tmp, ubound);
4896 tmp3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4897 logical_type_node, non_zerosized, tmp3);
4898 msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4899 "outside of expected range (%%ld:%%ld)",
4900 dim + 1, expr_name);
4901 gfc_trans_runtime_check (true, false, tmp2, &inner,
4902 expr_loc, msg,
4903 fold_convert (long_integer_type_node, tmp)fold_convert_loc (((location_t) 0), integer_types[itk_long], tmp
),
4904 fold_convert (long_integer_type_node, ubound)fold_convert_loc (((location_t) 0), integer_types[itk_long], ubound
),
4905 fold_convert (long_integer_type_node, lbound)fold_convert_loc (((location_t) 0), integer_types[itk_long], lbound
));
4906 gfc_trans_runtime_check (true, false, tmp3, &inner,
4907 expr_loc, msg,
4908 fold_convert (long_integer_type_node, tmp)fold_convert_loc (((location_t) 0), integer_types[itk_long], tmp
),
4909 fold_convert (long_integer_type_node, ubound)fold_convert_loc (((location_t) 0), integer_types[itk_long], ubound
),
4910 fold_convert (long_integer_type_node, lbound)fold_convert_loc (((location_t) 0), integer_types[itk_long], lbound
));
4911 free (msg);
4912 }
4913 else
4914 {
4915 msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4916 "below lower bound of %%ld",
4917 dim + 1, expr_name);
4918 gfc_trans_runtime_check (true, false, tmp2, &inner,
4919 expr_loc, msg,
4920 fold_convert (long_integer_type_node, tmp)fold_convert_loc (((location_t) 0), integer_types[itk_long], tmp
),
4921 fold_convert (long_integer_type_node, lbound)fold_convert_loc (((location_t) 0), integer_types[itk_long], lbound
));
4922 free (msg);
4923 }
4924
4925 /* Check the section sizes match. */
4926 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4927 gfc_array_index_type, end,
4928 info->start[dim]);
4929 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
4930 gfc_array_index_type, tmp,
4931 info->stride[dim]);
4932 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4933 gfc_array_index_type,
4934 gfc_index_one_nodegfc_rank_cst[1], tmp);
4935 tmp = fold_build2_loc (input_location, MAX_EXPR,
4936 gfc_array_index_type, tmp,
4937 build_int_cst (gfc_array_index_type, 0));
4938 /* We remember the size of the first section, and check all the
4939 others against this. */
4940 if (size[n])
4941 {
4942 tmp3 = fold_build2_loc (input_location, NE_EXPR,
4943 logical_type_node, tmp, size[n]);
4944 msg = xasprintf ("Array bound mismatch for dimension %d "
4945 "of array '%s' (%%ld/%%ld)",
4946 dim + 1, expr_name);
4947
4948 gfc_trans_runtime_check (true, false, tmp3, &inner,
4949 expr_loc, msg,
4950 fold_convert (long_integer_type_node, tmp)fold_convert_loc (((location_t) 0), integer_types[itk_long], tmp
),
4951 fold_convert (long_integer_type_node, size[n])fold_convert_loc (((location_t) 0), integer_types[itk_long], size
[n]));
4952
4953 free (msg);
4954 }
4955 else
4956 size[n] = gfc_evaluate_now (tmp, &inner);
4957 }
4958
4959 tmp = gfc_finish_block (&inner);
4960
4961 /* For optional arguments, only check bounds if the argument is
4962 present. */
4963 if ((expr->symtree->n.sym->attr.optional
4964 || expr->symtree->n.sym->attr.not_always_present)
4965 && expr->symtree->n.sym->attr.dummy)
4966 tmp = build3_v (COND_EXPR,fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], gfc_conv_expr_present (expr->symtree->n.sym), tmp, build_empty_stmt
(input_location))
4967 gfc_conv_expr_present (expr->symtree->n.sym),fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], gfc_conv_expr_present (expr->symtree->n.sym), tmp, build_empty_stmt
(input_location))
4968 tmp, build_empty_stmt (input_location))fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], gfc_conv_expr_present (expr->symtree->n.sym), tmp, build_empty_stmt
(input_location));
4969
4970 gfc_add_expr_to_block (&block, tmp);
4971
4972 }
4973
4974 tmp = gfc_finish_block (&block);
4975 gfc_add_expr_to_block (&outer_loop->pre, tmp);
4976 }
4977
4978 for (loop = loop->nested; loop; loop = loop->next)
4979 gfc_conv_ss_startstride (loop);
4980}
4981
4982/* Return true if both symbols could refer to the same data object. Does
4983 not take account of aliasing due to equivalence statements. */
4984
4985static int
4986symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym, bool lsym_pointer,
4987 bool lsym_target, bool rsym_pointer, bool rsym_target)
4988{
4989 /* Aliasing isn't possible if the symbols have different base types. */
4990 if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0)
4991 return 0;
4992
4993 /* Pointers can point to other pointers and target objects. */
4994
4995 if ((lsym_pointer && (rsym_pointer || rsym_target))
4996 || (rsym_pointer && (lsym_pointer || lsym_target)))
4997 return 1;
4998
4999 /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
5000 and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
5001 checked above. */
5002 if (lsym_target && rsym_target
5003 && ((lsym->attr.dummy && !lsym->attr.contiguous
5004 && (!lsym->attr.dimension || lsym->as->type == AS_ASSUMED_SHAPE))
5005 || (rsym->attr.dummy && !rsym->attr.contiguous
5006 && (!rsym->attr.dimension
5007 || rsym->as->type == AS_ASSUMED_SHAPE))))
5008 return 1;
5009
5010 return 0;
5011}
5012
5013
5014/* Return true if the two SS could be aliased, i.e. both point to the same data
5015 object. */
5016/* TODO: resolve aliases based on frontend expressions. */
5017
5018static int
5019gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
5020{
5021 gfc_ref *lref;
5022 gfc_ref *rref;
5023 gfc_expr *lexpr, *rexpr;
5024 gfc_symbol *lsym;
5025 gfc_symbol *rsym;
5026 bool lsym_pointer, lsym_target, rsym_pointer, rsym_target;
5027
5028 lexpr = lss->info->expr;
5029 rexpr = rss->info->expr;
5030
5031 lsym = lexpr->symtree->n.sym;
5032 rsym = rexpr->symtree->n.sym;
5033
5034 lsym_pointer = lsym->attr.pointer;
5035 lsym_target = lsym->attr.target;
5036 rsym_pointer = rsym->attr.pointer;
5037 rsym_target = rsym->attr.target;
5038
5039 if (symbols_could_alias (lsym, rsym, lsym_pointer, lsym_target,
5040 rsym_pointer, rsym_target))
5041 return 1;
5042
5043 if (rsym->ts.type != BT_DERIVED && rsym->ts.type != BT_CLASS
5044 && lsym->ts.type != BT_DERIVED && lsym->ts.type != BT_CLASS)
5045 return 0;
5046
5047 /* For derived types we must check all the component types. We can ignore
5048 array references as these will have the same base type as the previous
5049 component ref. */
5050 for (lref = lexpr->ref; lref != lss->info->data.array.ref; lref = lref->next)
5051 {
5052 if (lref->type != REF_COMPONENT)
5053 continue;
5054
5055 lsym_pointer = lsym_pointer || lref->u.c.sym->attr.pointer;
5056 lsym_target = lsym_target || lref->u.c.sym->attr.target;
5057
5058 if (symbols_could_alias (lref->u.c.sym, rsym, lsym_pointer, lsym_target,
5059 rsym_pointer, rsym_target))
5060 return 1;
5061
5062 if ((lsym_pointer && (rsym_pointer || rsym_target))
5063 || (rsym_pointer && (lsym_pointer || lsym_target)))
5064 {
5065 if (gfc_compare_types (&lref->u.c.component->ts,
5066 &rsym->ts))
5067 return 1;
5068 }
5069
5070 for (rref = rexpr->ref; rref != rss->info->data.array.ref;
5071 rref = rref->next)
5072 {
5073 if (rref->type != REF_COMPONENT)
5074 continue;
5075
5076 rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
5077 rsym_target = lsym_target || rref->u.c.sym->attr.target;
5078
5079 if (symbols_could_alias (lref->u.c.sym, rref->u.c.sym,
5080 lsym_pointer, lsym_target,
5081 rsym_pointer, rsym_target))
5082 return 1;
5083
5084 if ((lsym_pointer && (rsym_pointer || rsym_target))
5085 || (rsym_pointer && (lsym_pointer || lsym_target)))
5086 {
5087 if (gfc_compare_types (&lref->u.c.component->ts,
5088 &rref->u.c.sym->ts))
5089 return 1;
5090 if (gfc_compare_types (&lref->u.c.sym->ts,
5091 &rref->u.c.component->ts))
5092 return 1;
5093 if (gfc_compare_types (&lref->u.c.component->ts,
5094 &rref->u.c.component->ts))
5095 return 1;
5096 }
5097 }
5098 }
5099
5100 lsym_pointer = lsym->attr.pointer;
5101 lsym_target = lsym->attr.target;
5102
5103 for (rref = rexpr->ref; rref != rss->info->data.array.ref; rref = rref->next)
5104 {
5105 if (rref->type != REF_COMPONENT)
5106 break;
5107
5108 rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
5109 rsym_target = lsym_target || rref->u.c.sym->attr.target;
5110
5111 if (symbols_could_alias (rref->u.c.sym, lsym,
5112 lsym_pointer, lsym_target,
5113 rsym_pointer, rsym_target))
5114 return 1;
5115
5116 if ((lsym_pointer && (rsym_pointer || rsym_target))
5117 || (rsym_pointer && (lsym_pointer || lsym_target)))
5118 {
5119 if (gfc_compare_types (&lsym->ts, &rref->u.c.component->ts))
5120 return 1;
5121 }
5122 }
5123
5124 return 0;
5125}
5126
5127
5128/* Resolve array data dependencies. Creates a temporary if required. */
5129/* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to
5130 dependency.cc. */
5131
5132void
5133gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
5134 gfc_ss * rss)
5135{
5136 gfc_ss *ss;
5137 gfc_ref *lref;
5138 gfc_ref *rref;
5139 gfc_ss_info *ss_info;
5140 gfc_expr *dest_expr;
5141 gfc_expr *ss_expr;
5142 int nDepend = 0;
5143 int i, j;
5144
5145 loop->temp_ss = NULL__null;
5146 dest_expr = dest->info->expr;
5147
5148 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
5149 {
5150 ss_info = ss->info;
5151 ss_expr = ss_info->expr;
5152
5153 if (ss_info->array_outer_dependency)
5154 {
5155 nDepend = 1;
5156 break;
5157 }
5158
5159 if (ss_info->type != GFC_SS_SECTION)
5160 {
5161 if (flag_realloc_lhsglobal_options.x_flag_realloc_lhs
5162 && dest_expr != ss_expr
5163 && gfc_is_reallocatable_lhs (dest_expr)
5164 && ss_expr->rank)
5165 nDepend = gfc_check_dependency (dest_expr, ss_expr, true);
5166
5167 /* Check for cases like c(:)(1:2) = c(2)(2:3) */
5168 if (!nDepend && dest_expr->rank > 0
5169 && dest_expr->ts.type == BT_CHARACTER
5170 && ss_expr->expr_type == EXPR_VARIABLE)
5171
5172 nDepend = gfc_check_dependency (dest_expr, ss_expr, false);
5173
5174 if (ss_info->type == GFC_SS_REFERENCE
5175 && gfc_check_dependency (dest_expr, ss_expr, false))
5176 ss_info->data.scalar.needs_temporary = 1;
5177
5178 if (nDepend)
5179 break;
5180 else
5181 continue;
5182 }
5183
5184 if (dest_expr->symtree->n.sym != ss_expr->symtree->n.sym)
5185 {
5186 if (gfc_could_be_alias (dest, ss)
5187 || gfc_are_equivalenced_arrays (dest_expr, ss_expr))
5188 {
5189 nDepend = 1;
5190 break;
5191 }
5192 }
5193 else
5194 {
5195 lref = dest_expr->ref;
5196 rref = ss_expr->ref;
5197
5198 nDepend = gfc_dep_resolver (lref, rref, &loop->reverse[0]);
5199
5200 if (nDepend == 1)
5201 break;
5202
5203 for (i = 0; i < dest->dimen; i++)
5204 for (j = 0; j < ss->dimen; j++)
5205 if (i != j
5206 && dest->dim[i] == ss->dim[j])
5207 {
5208 /* If we don't access array elements in the same order,
5209 there is a dependency. */
5210 nDepend = 1;
5211 goto temporary;
5212 }
5213#if 0
5214 /* TODO : loop shifting. */
5215 if (nDepend == 1)
5216 {
5217 /* Mark the dimensions for LOOP SHIFTING */
5218 for (n = 0; n < loop->dimen; n++)
5219 {
5220 int dim = dest->data.info.dim[n];
5221
5222 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
5223 depends[n] = 2;
5224 else if (! gfc_is_same_range (&lref->u.ar,
5225 &rref->u.ar, dim, 0))
5226 depends[n] = 1;
5227 }
5228
5229 /* Put all the dimensions with dependencies in the
5230 innermost loops. */
5231 dim = 0;
5232 for (n = 0; n < loop->dimen; n++)
5233 {
5234 gcc_assert (loop->order[n] == n)((void)(!(loop->order[n] == n) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 5234, __FUNCTION__), 0 : 0));
5235 if (depends[n])
5236 loop->order[dim++] = n;
5237 }
5238 for (n = 0; n < loop->dimen; n++)
5239 {
5240 if (! depends[n])
5241 loop->order[dim++] = n;
5242 }
5243
5244 gcc_assert (dim == loop->dimen)((void)(!(dim == loop->dimen) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 5244, __FUNCTION__), 0 : 0));
5245 break;
5246 }
5247#endif
5248 }
5249 }
5250
5251temporary:
5252
5253 if (nDepend == 1)
5254 {
5255 tree base_type = gfc_typenode_for_spec (&dest_expr->ts);
5256 if (GFC_ARRAY_TYPE_P (base_type)((tree_class_check ((base_type), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 5256, __FUNCTION__))->type_common.lang_flag_2)
5257 || GFC_DESCRIPTOR_TYPE_P (base_type)((tree_class_check ((base_type), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 5257, __FUNCTION__))->type_common.lang_flag_1))
5258 base_type = gfc_get_element_type (base_type);
5259 loop->temp_ss = gfc_get_temp_ss (base_type, dest->info->string_length,
5260 loop->dimen);
5261 gfc_add_ss_to_loop (loop, loop->temp_ss);
5262 }
5263 else
5264 loop->temp_ss = NULL__null;
5265}
5266
5267
5268/* Browse through each array's information from the scalarizer and set the loop
5269 bounds according to the "best" one (per dimension), i.e. the one which
5270 provides the most information (constant bounds, shape, etc.). */
5271
5272static void
5273set_loop_bounds (gfc_loopinfo *loop)
5274{
5275 int n, dim, spec_dim;
5276 gfc_array_info *info;
5277 gfc_array_info *specinfo;
5278 gfc_ss *ss;
5279 tree tmp;
5280 gfc_ss **loopspec;
5281 bool dynamic[GFC_MAX_DIMENSIONS15];
5282 mpz_t *cshape;
5283 mpz_t i;
5284 bool nonoptional_arr;
5285
5286 gfc_loopinfo * const outer_loop = outermost_loop (loop);
5287
5288 loopspec = loop->specloop;
5289
5290 mpz_init__gmpz_init (i);
5291 for (n = 0; n < loop->dimen; n++)
5292 {
5293 loopspec[n] = NULL__null;
5294 dynamic[n] = false;
5295
5296 /* If there are both optional and nonoptional array arguments, scalarize
5297 over the nonoptional; otherwise, it does not matter as then all
5298 (optional) arrays have to be present per F2008, 125.2.12p3(6). */
5299
5300 nonoptional_arr = false;
5301
5302 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5303 if (ss->info->type != GFC_SS_SCALAR && ss->info->type != GFC_SS_TEMP
5304 && ss->info->type != GFC_SS_REFERENCE && !ss->info->can_be_null_ref)
5305 {
5306 nonoptional_arr = true;
5307 break;
5308 }
5309
5310 /* We use one SS term, and use that to determine the bounds of the
5311 loop for this dimension. We try to pick the simplest term. */
5312 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5313 {
5314 gfc_ss_type ss_type;
5315
5316 ss_type = ss->info->type;
5317 if (ss_type == GFC_SS_SCALAR
5318 || ss_type == GFC_SS_TEMP
5319 || ss_type == GFC_SS_REFERENCE
5320 || (ss->info->can_be_null_ref && nonoptional_arr))
5321 continue;
5322
5323 info = &ss->info->data.array;
5324 dim = ss->dim[n];
5325
5326 if (loopspec[n] != NULL__null)
5327 {
5328 specinfo = &loopspec[n]->info->data.array;
5329 spec_dim = loopspec[n]->dim[n];
5330 }
5331 else
5332 {
5333 /* Silence uninitialized warnings. */
5334 specinfo = NULL__null;
5335 spec_dim = 0;
5336 }
5337
5338 if (info->shape)
5339 {
5340 /* The frontend has worked out the size for us. */
5341 if (!loopspec[n]
5342 || !specinfo->shape
5343 || !integer_zerop (specinfo->start[spec_dim]))
5344 /* Prefer zero-based descriptors if possible. */
5345 loopspec[n] = ss;
5346 continue;
5347 }
5348
5349 if (ss_type == GFC_SS_CONSTRUCTOR)
5350 {
5351 gfc_constructor_base base;
5352 /* An unknown size constructor will always be rank one.
5353 Higher rank constructors will either have known shape,
5354 or still be wrapped in a call to reshape. */
5355 gcc_assert (loop->dimen == 1)((void)(!(loop->dimen == 1) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 5355, __FUNCTION__), 0 : 0));
5356
5357 /* Always prefer to use the constructor bounds if the size
5358 can be determined at compile time. Prefer not to otherwise,
5359 since the general case involves realloc, and it's better to
5360 avoid that overhead if possible. */
5361 base = ss->info->expr->value.constructor;
5362 dynamic[n] = gfc_get_array_constructor_size (&i, base);
5363 if (!dynamic[n] || !loopspec[n])
5364 loopspec[n] = ss;
5365 continue;
5366 }
5367
5368 /* Avoid using an allocatable lhs in an assignment, since
5369 there might be a reallocation coming. */
5370 if (loopspec[n] && ss->is_alloc_lhs)
5371 continue;
5372
5373 if (!loopspec[n])
5374 loopspec[n] = ss;
5375 /* Criteria for choosing a loop specifier (most important first):
5376 doesn't need realloc
5377 stride of one
5378 known stride
5379 known lower bound
5380 known upper bound
5381 */
5382 else if (loopspec[n]->info->type == GFC_SS_CONSTRUCTOR && dynamic[n])
5383 loopspec[n] = ss;
5384 else if (integer_onep (info->stride[dim])
5385 && !integer_onep (specinfo->stride[spec_dim]))
5386 loopspec[n] = ss;
5387 else if (INTEGER_CST_P (info->stride[dim])(((enum tree_code) (info->stride[dim])->base.code) == INTEGER_CST
)
5388 && !INTEGER_CST_P (specinfo->stride[spec_dim])(((enum tree_code) (specinfo->stride[spec_dim])->base.code
) == INTEGER_CST))
5389 loopspec[n] = ss;
5390 else if (INTEGER_CST_P (info->start[dim])(((enum tree_code) (info->start[dim])->base.code) == INTEGER_CST
)
5391 && !INTEGER_CST_P (specinfo->start[spec_dim])(((enum tree_code) (specinfo->start[spec_dim])->base.code
) == INTEGER_CST)
5392 && integer_onep (info->stride[dim])
5393 == integer_onep (specinfo->stride[spec_dim])
5394 && INTEGER_CST_P (info->stride[dim])(((enum tree_code) (info->stride[dim])->base.code) == INTEGER_CST
)
5395 == INTEGER_CST_P (specinfo->stride[spec_dim])(((enum tree_code) (specinfo->stride[spec_dim])->base.code
) == INTEGER_CST))
5396 loopspec[n] = ss;
5397 /* We don't work out the upper bound.
5398 else if (INTEGER_CST_P (info->finish[n])
5399 && ! INTEGER_CST_P (specinfo->finish[n]))
5400 loopspec[n] = ss; */
5401 }
5402
5403 /* We should have found the scalarization loop specifier. If not,
5404 that's bad news. */
5405 gcc_assert (loopspec[n])((void)(!(loopspec[n]) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 5405, __FUNCTION__), 0 : 0));
5406
5407 info = &loopspec[n]->info->data.array;
5408 dim = loopspec[n]->dim[n];
5409
5410 /* Set the extents of this range. */
5411 cshape = info->shape;
5412 if (cshape && INTEGER_CST_P (info->start[dim])(((enum tree_code) (info->start[dim])->base.code) == INTEGER_CST
)
5413 && INTEGER_CST_P (info->stride[dim])(((enum tree_code) (info->stride[dim])->base.code) == INTEGER_CST
))
5414 {
5415 loop->from[n] = info->start[dim];
5416 mpz_set__gmpz_set (i, cshape[get_array_ref_dim_for_loop_dim (loopspec[n], n)]);
5417 mpz_sub_ui__gmpz_sub_ui (i, i, 1);
5418 /* To = from + (size - 1) * stride. */
5419 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
5420 if (!integer_onep (info->stride[dim]))
5421 tmp = fold_build2_loc (input_location, MULT_EXPR,
5422 gfc_array_index_type, tmp,
5423 info->stride[dim]);
5424 loop->to[n] = fold_build2_loc (input_location, PLUS_EXPR,
5425 gfc_array_index_type,
5426 loop->from[n], tmp);
5427 }
5428 else
5429 {
5430 loop->from[n] = info->start[dim];
5431 switch (loopspec[n]->info->type)
5432 {
5433 case GFC_SS_CONSTRUCTOR:
5434 /* The upper bound is calculated when we expand the
5435 constructor. */
5436 gcc_assert (loop->to[n] == NULL_TREE)((void)(!(loop->to[n] == (tree) __null) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 5436, __FUNCTION__), 0 : 0));
5437 break;
5438
5439 case GFC_SS_SECTION:
5440 /* Use the end expression if it exists and is not constant,
5441 so that it is only evaluated once. */
5442 loop->to[n] = info->end[dim];
5443 break;
5444
5445 case GFC_SS_FUNCTION:
5446 /* The loop bound will be set when we generate the call. */
5447 gcc_assert (loop->to[n] == NULL_TREE)((void)(!(loop->to[n] == (tree) __null) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 5447, __FUNCTION__), 0 : 0));
5448 break;
5449
5450 case GFC_SS_INTRINSIC:
5451 {
5452 gfc_expr *expr = loopspec[n]->info->expr;
5453
5454 /* The {l,u}bound of an assumed rank. */
5455 if (expr->value.function.isym->id == GFC_ISYM_SHAPE)
5456 gcc_assert (expr->value.function.actual->expr->rank == -1)((void)(!(expr->value.function.actual->expr->rank ==
-1) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 5456, __FUNCTION__), 0 : 0));
5457 else
5458 gcc_assert ((expr->value.function.isym->id == GFC_ISYM_LBOUND((void)(!((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) ? fancy_abort
("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 5461, __FUNCTION__), 0 : 0))
5459 || expr->value.function.isym->id == GFC_ISYM_UBOUND)((void)(!((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) ? fancy_abort
("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 5461, __FUNCTION__), 0 : 0))
5460 && expr->value.function.actual->next->expr == NULL((void)(!((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) ? fancy_abort
("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 5461, __FUNCTION__), 0 : 0))
5461 && expr->value.function.actual->expr->rank == -1)((void)(!((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) ? fancy_abort
("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 5461, __FUNCTION__), 0 : 0));
5462
5463 loop->to[n] = info->end[dim];
5464 break;
5465 }
5466
5467 case GFC_SS_COMPONENT:
5468 {
5469 if (info->end[dim] != NULL_TREE(tree) __null)
5470 {
5471 loop->to[n] = info->end[dim];
5472 break;
5473 }
5474 else
5475 gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 5475, __FUNCTION__));
5476 }
5477
5478 default:
5479 gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 5479, __FUNCTION__));
5480 }
5481 }
5482
5483 /* Transform everything so we have a simple incrementing variable. */
5484 if (integer_onep (info->stride[dim]))
5485 info->delta[dim] = gfc_index_zero_nodegfc_rank_cst[0];
5486 else
5487 {
5488 /* Set the delta for this section. */
5489 info->delta[dim] = gfc_evaluate_now (loop->from[n], &outer_loop->pre);
5490 /* Number of iterations is (end - start + step) / step.
5491 with start = 0, this simplifies to
5492 last = end / step;
5493 for (i = 0; i<=last; i++){...}; */
5494 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5495 gfc_array_index_type, loop->to[n],
5496 loop->from[n]);
5497 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
5498 gfc_array_index_type, tmp, info->stride[dim]);
5499 tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
5500 tmp, build_int_cst (gfc_array_index_type, -1));
5501 loop->to[n] = gfc_evaluate_now (tmp, &outer_loop->pre);
5502 /* Make the loop variable start at 0. */
5503 loop->from[n] = gfc_index_zero_nodegfc_rank_cst[0];
5504 }
5505 }
5506 mpz_clear__gmpz_clear (i);
5507
5508 for (loop = loop->nested; loop; loop = loop->next)
5509 set_loop_bounds (loop);
5510}
5511
5512
5513/* Initialize the scalarization loop. Creates the loop variables. Determines
5514 the range of the loop variables. Creates a temporary if required.
5515 Also generates code for scalar expressions which have been
5516 moved outside the loop. */
5517
5518void
5519gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
5520{
5521 gfc_ss *tmp_ss;
5522 tree tmp;
5523
5524 set_loop_bounds (loop);
5525
5526 /* Add all the scalar code that can be taken out of the loops.
5527 This may include calculating the loop bounds, so do it before
5528 allocating the temporary. */
5529 gfc_add_loop_ss_code (loop, loop->ss, false, where);
4
←
Calling 'gfc_add_loop_ss_code'
→
5530
5531 tmp_ss = loop->temp_ss;
5532 /* If we want a temporary then create it. */
5533 if (tmp_ss != NULL__null)
5534 {
5535 gfc_ss_info *tmp_ss_info;
5536
5537 tmp_ss_info = tmp_ss->info;
5538 gcc_assert (tmp_ss_info->type == GFC_SS_TEMP)((void)(!(tmp_ss_info->type == GFC_SS_TEMP) ? fancy_abort (
"/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 5538, __FUNCTION__), 0 : 0));
5539 gcc_assert (loop->parent == NULL)((void)(!(loop->parent == __null) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 5539, __FUNCTION__), 0 : 0));
5540
5541 /* Make absolutely sure that this is a complete type. */
5542 if (tmp_ss_info->string_length)
5543 tmp_ss_info->data.temp.type
5544 = gfc_get_character_type_len_for_eltype
5545 (TREE_TYPE (tmp_ss_info->data.temp.type)((contains_struct_check ((tmp_ss_info->data.temp.type), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 5545, __FUNCTION__))->typed.type),
5546 tmp_ss_info->string_length);
5547
5548 tmp = tmp_ss_info->data.temp.type;
5549 memset (&tmp_ss_info->data.array, 0, sizeof (gfc_array_info));
5550 tmp_ss_info->type = GFC_SS_SECTION;
5551
5552 gcc_assert (tmp_ss->dimen != 0)((void)(!(tmp_ss->dimen != 0) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 5552, __FUNCTION__), 0 : 0));
5553
5554 gfc_trans_create_temp_array (&loop->pre, &loop->post, tmp_ss, tmp,
5555 NULL_TREE(tree) __null, false, true, false, where);
5556 }
5557
5558 /* For array parameters we don't have loop variables, so don't calculate the
5559 translations. */
5560 if (!loop->array_parameter)
5561 gfc_set_delta (loop);
5562}
5563
5564
5565/* Calculates how to transform from loop variables to array indices for each
5566 array: once loop bounds are chosen, sets the difference (DELTA field) between
5567 loop bounds and array reference bounds, for each array info. */
5568
5569void
5570gfc_set_delta (gfc_loopinfo *loop)
5571{
5572 gfc_ss *ss, **loopspec;
5573 gfc_array_info *info;
5574 tree tmp;
5575 int n, dim;
5576
5577 gfc_loopinfo * const outer_loop = outermost_loop (loop);
5578
5579 loopspec = loop->specloop;
5580
5581 /* Calculate the translation from loop variables to array indices. */
5582 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5583 {
5584 gfc_ss_type ss_type;
5585
5586 ss_type = ss->info->type;
5587 if (ss_type != GFC_SS_SECTION
5588 && ss_type != GFC_SS_COMPONENT
5589 && ss_type != GFC_SS_CONSTRUCTOR)
5590 continue;
5591
5592 info = &ss->info->data.array;
5593
5594 for (n = 0; n < ss->dimen; n++)
5595 {
5596 /* If we are specifying the range the delta is already set. */
5597 if (loopspec[n] != ss)
5598 {
5599 dim = ss->dim[n];
5600
5601 /* Calculate the offset relative to the loop variable.
5602 First multiply by the stride. */
5603 tmp = loop->from[n];
5604 if (!integer_onep (info->stride[dim]))
5605 tmp = fold_build2_loc (input_location, MULT_EXPR,
5606 gfc_array_index_type,
5607 tmp, info->stride[dim]);
5608
5609 /* Then subtract this from our starting value. */
5610 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5611 gfc_array_index_type,
5612 info->start[dim], tmp);
5613
5614 info->delta[dim] = gfc_evaluate_now (tmp, &outer_loop->pre);
5615 }
5616 }
5617 }
5618
5619 for (loop = loop->nested; loop; loop = loop->next)
5620 gfc_set_delta (loop);
5621}
5622
5623
5624/* Calculate the size of a given array dimension from the bounds. This
5625 is simply (ubound - lbound + 1) if this expression is positive
5626 or 0 if it is negative (pick either one if it is zero). Optionally
5627 (if or_expr is present) OR the (expression != 0) condition to it. */
5628
5629tree
5630gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr)
5631{
5632 tree res;
5633 tree cond;
5634
5635 /* Calculate (ubound - lbound + 1). */
5636 res = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5637 ubound, lbound);
5638 res = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, res,
5639 gfc_index_one_nodegfc_rank_cst[1]);
5640
5641 /* Check whether the size for this dimension is negative. */
5642 cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, res,
5643 gfc_index_zero_nodegfc_rank_cst[0]);
5644 res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
5645 gfc_index_zero_nodegfc_rank_cst[0], res);
5646
5647 /* Build OR expression. */
5648 if (or_expr)
5649 *or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
5650 logical_type_node, *or_expr, cond);
5651
5652 return res;
5653}
5654
5655
5656/* For an array descriptor, get the total number of elements. This is just
5657 the product of the extents along from_dim to to_dim. */
5658
5659static tree
5660gfc_conv_descriptor_size_1 (tree desc, int from_dim, int to_dim)
5661{
5662 tree res;
5663 int dim;
5664
5665 res = gfc_index_one_nodegfc_rank_cst[1];
5666
5667 for (dim = from_dim; dim < to_dim; ++dim)
5668 {
5669 tree lbound;
5670 tree ubound;
5671 tree extent;
5672
5673 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
5674 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
5675
5676 extent = gfc_conv_array_extent_dim (lbound, ubound, NULL__null);
5677 res = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5678 res, extent);
5679 }
5680
5681 return res;
5682}
5683
5684
5685/* Full size of an array. */
5686
5687tree
5688gfc_conv_descriptor_size (tree desc, int rank)
5689{
5690 return gfc_conv_descriptor_size_1 (desc, 0, rank);
5691}
5692
5693
5694/* Size of a coarray for all dimensions but the last. */
5695
5696tree
5697gfc_conv_descriptor_cosize (tree desc, int rank, int corank)
5698{
5699 return gfc_conv_descriptor_size_1 (desc, rank, rank + corank - 1);
5700}
5701
5702
5703/* Fills in an array descriptor, and returns the size of the array.
5704 The size will be a simple_val, ie a variable or a constant. Also
5705 calculates the offset of the base. The pointer argument overflow,
5706 which should be of integer type, will increase in value if overflow
5707 occurs during the size calculation. Returns the size of the array.
5708 {
5709 stride = 1;
5710 offset = 0;
5711 for (n = 0; n < rank; n++)
5712 {
5713 a.lbound[n] = specified_lower_bound;
5714 offset = offset + a.lbond[n] * stride;
5715 size = 1 - lbound;
5716 a.ubound[n] = specified_upper_bound;
5717 a.stride[n] = stride;
5718 size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
5719 overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
5720 stride = stride * size;
5721 }
5722 for (n = rank; n < rank+corank; n++)
5723 (Set lcobound/ucobound as above.)
5724 element_size = sizeof (array element);
5725 if (!rank)
5726 return element_size
5727 stride = (size_t) stride;
5728 overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
5729 stride = stride * element_size;
5730 return (stride);
5731 } */
5732/*GCC ARRAYS*/
5733
5734static tree
5735gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
5736 gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
5737 stmtblock_t * descriptor_block, tree * overflow,
5738 tree expr3_elem_size, tree *nelems, gfc_expr *expr3,
5739 tree expr3_desc, bool e3_has_nodescriptor, gfc_expr *expr,
5740 tree *element_size)
5741{
5742 tree type;
5743 tree tmp;
5744 tree size;
5745 tree offset;
5746 tree stride;
5747 tree or_expr;
5748 tree thencase;
5749 tree elsecase;
5750 tree cond;
5751 tree var;
5752 stmtblock_t thenblock;
5753 stmtblock_t elseblock;
5754 gfc_expr *ubound;
5755 gfc_se se;
5756 int n;
5757
5758 type = TREE_TYPE (descriptor)((contains_struct_check ((descriptor), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-array.cc"
, 5758, __FUNCTION__))->typed.type);
5759
5760 stride = gfc_index_one_nodegfc_rank_cst[1];
5761 offset = gfc_index_zero_nodegfc_rank_cst[0];
5762
5763 /* Set the dtype before the alloc, because registration of coarrays needs
5764 it initialized. */
5765 if