Bug Summary

File:build/gcc/vec.h
Warning:line 814, column 10
Called C++ object pointer is null

Annotated Source Code

Press '?' to see keyboard shortcuts

clang -cc1 -cc1 -triple x86_64-unknown-linux-gnu -analyze -disable-free -disable-llvm-verifier -discard-value-names -main-file-name trans-stmt.c -analyzer-store=region -analyzer-opt-analyze-nested-blocks -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 -fno-rounding-math -mconstructor-aliases -munwind-tables -target-cpu x86-64 -tune-cpu generic -debugger-tuning=gdb -fcoverage-compilation-dir=/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/objdir/gcc -resource-dir /usr/lib64/clang/13.0.0 -D IN_GCC_FRONTEND -D IN_GCC -D HAVE_CONFIG_H -I . -I fortran -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../include -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libcpp/include -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libcody -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libdecnumber -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libdecnumber/bid -I ../libdecnumber -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libbacktrace -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/11/../../../../include/c++/11 -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/11/../../../../include/c++/11/x86_64-suse-linux -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/11/../../../../include/c++/11/backward -internal-isystem /usr/lib64/clang/13.0.0/include -internal-isystem /usr/local/include -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/11/../../../../x86_64-suse-linux/include -internal-externc-isystem /include -internal-externc-isystem /usr/include -O2 -Wno-narrowing -Wwrite-strings -Wno-error=format-diag -Wno-long-long -Wno-variadic-macros -Wno-overlength-strings -fdeprecated-macro -fdebug-compilation-dir=/home/marxin/BIG/buildbot/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 /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/objdir/clang-static-analyzer/2021-11-20-133755-20252-1/report-151FH_.plist -x c++ /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c

/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c

1/* Statement translation -- generate GCC trees from gfc_code.
2 Copyright (C) 2002-2021 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
23#include "config.h"
24#include "system.h"
25#include "coretypes.h"
26#include "options.h"
27#include "tree.h"
28#include "gfortran.h"
29#include "trans.h"
30#include "stringpool.h"
31#include "fold-const.h"
32#include "trans-stmt.h"
33#include "trans-types.h"
34#include "trans-array.h"
35#include "trans-const.h"
36#include "dependency.h"
37
38typedef struct iter_info
39{
40 tree var;
41 tree start;
42 tree end;
43 tree step;
44 struct iter_info *next;
45}
46iter_info;
47
48typedef struct forall_info
49{
50 iter_info *this_loop;
51 tree mask;
52 tree maskindex;
53 int nvar;
54 tree size;
55 struct forall_info *prev_nest;
56 bool do_concurrent;
57}
58forall_info;
59
60static void gfc_trans_where_2 (gfc_code *, tree, bool,
61 forall_info *, stmtblock_t *);
62
63/* Translate a F95 label number to a LABEL_EXPR. */
64
65tree
66gfc_trans_label_here (gfc_code * code)
67{
68 return build1_v (LABEL_EXPR, gfc_get_label_decl (code->here))fold_build1_loc (input_location, LABEL_EXPR, global_trees[TI_VOID_TYPE
], gfc_get_label_decl (code->here))
;
69}
70
71
72/* Given a variable expression which has been ASSIGNed to, find the decl
73 containing the auxiliary variables. For variables in common blocks this
74 is a field_decl. */
75
76void
77gfc_conv_label_variable (gfc_se * se, gfc_expr * expr)
78{
79 gcc_assert (expr->symtree->n.sym->attr.assign == 1)((void)(!(expr->symtree->n.sym->attr.assign == 1) ? fancy_abort
("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 79, __FUNCTION__), 0 : 0))
;
80 gfc_conv_expr (se, expr);
81 /* Deals with variable in common block. Get the field declaration. */
82 if (TREE_CODE (se->expr)((enum tree_code) (se->expr)->base.code) == COMPONENT_REF)
83 se->expr = TREE_OPERAND (se->expr, 1)(*((const_cast<tree*> (tree_operand_check ((se->expr
), (1), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 83, __FUNCTION__)))))
;
84 /* Deals with dummy argument. Get the parameter declaration. */
85 else if (TREE_CODE (se->expr)((enum tree_code) (se->expr)->base.code) == INDIRECT_REF)
86 se->expr = TREE_OPERAND (se->expr, 0)(*((const_cast<tree*> (tree_operand_check ((se->expr
), (0), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 86, __FUNCTION__)))))
;
87}
88
89/* Translate a label assignment statement. */
90
91tree
92gfc_trans_label_assign (gfc_code * code)
93{
94 tree label_tree;
95 gfc_se se;
96 tree len;
97 tree addr;
98 tree len_tree;
99 int label_len;
100
101 /* Start a new block. */
102 gfc_init_se (&se, NULL__null);
103 gfc_start_block (&se.pre);
104 gfc_conv_label_variable (&se, code->expr1);
105
106 len = GFC_DECL_STRING_LEN (se.expr)((contains_struct_check ((se.expr), (TS_DECL_COMMON), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 106, __FUNCTION__))->decl_common.lang_specific)->stringlen
;
107 addr = GFC_DECL_ASSIGN_ADDR (se.expr)((contains_struct_check ((se.expr), (TS_DECL_COMMON), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 107, __FUNCTION__))->decl_common.lang_specific)->addr
;
108
109 label_tree = gfc_get_label_decl (code->label1);
110
111 if (code->label1->defined == ST_LABEL_TARGET
112 || code->label1->defined == ST_LABEL_DO_TARGET)
113 {
114 label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree);
115 len_tree = build_int_cst (gfc_charlen_type_node, -1);
116 }
117 else
118 {
119 gfc_expr *format = code->label1->format;
120
121 label_len = format->value.character.length;
122 len_tree = build_int_cst (gfc_charlen_type_node, label_len);
123 label_tree = gfc_build_wide_string_const (format->ts.kind, label_len + 1,
124 format->value.character.string);
125 label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree);
126 }
127
128 gfc_add_modify (&se.pre, len, fold_convert (TREE_TYPE (len), len_tree)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(len), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 128, __FUNCTION__))->typed.type), len_tree)
);
129 gfc_add_modify (&se.pre, addr, label_tree);
130
131 return gfc_finish_block (&se.pre);
132}
133
134/* Translate a GOTO statement. */
135
136tree
137gfc_trans_goto (gfc_code * code)
138{
139 locus loc = code->loc;
140 tree assigned_goto;
141 tree target;
142 tree tmp;
143 gfc_se se;
144
145 if (code->label1 != NULL__null)
146 return build1_v (GOTO_EXPR, gfc_get_label_decl (code->label1))fold_build1_loc (input_location, GOTO_EXPR, global_trees[TI_VOID_TYPE
], gfc_get_label_decl (code->label1))
;
147
148 /* ASSIGNED GOTO. */
149 gfc_init_se (&se, NULL__null);
150 gfc_start_block (&se.pre);
151 gfc_conv_label_variable (&se, code->expr1);
152 tmp = GFC_DECL_STRING_LEN (se.expr)((contains_struct_check ((se.expr), (TS_DECL_COMMON), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 152, __FUNCTION__))->decl_common.lang_specific)->stringlen
;
153 tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
154 build_int_cst (TREE_TYPE (tmp)((contains_struct_check ((tmp), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 154, __FUNCTION__))->typed.type)
, -1));
155 gfc_trans_runtime_check (true, false, tmp, &se.pre, &loc,
156 "Assigned label is not a target label");
157
158 assigned_goto = GFC_DECL_ASSIGN_ADDR (se.expr)((contains_struct_check ((se.expr), (TS_DECL_COMMON), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 158, __FUNCTION__))->decl_common.lang_specific)->addr
;
159
160 /* We're going to ignore a label list. It does not really change the
161 statement's semantics (because it is just a further restriction on
162 what's legal code); before, we were comparing label addresses here, but
163 that's a very fragile business and may break with optimization. So
164 just ignore it. */
165
166 target = fold_build1_loc (input_location, GOTO_EXPR, void_type_nodeglobal_trees[TI_VOID_TYPE],
167 assigned_goto);
168 gfc_add_expr_to_block (&se.pre, target);
169 return gfc_finish_block (&se.pre);
170}
171
172
173/* Translate an ENTRY statement. Just adds a label for this entry point. */
174tree
175gfc_trans_entry (gfc_code * code)
176{
177 return build1_v (LABEL_EXPR, code->ext.entry->label)fold_build1_loc (input_location, LABEL_EXPR, global_trees[TI_VOID_TYPE
], code->ext.entry->label)
;
178}
179
180
181/* Replace a gfc_ss structure by another both in the gfc_se struct
182 and the gfc_loopinfo struct. This is used in gfc_conv_elemental_dependencies
183 to replace a variable ss by the corresponding temporary. */
184
185static void
186replace_ss (gfc_se *se, gfc_ss *old_ss, gfc_ss *new_ss)
187{
188 gfc_ss **sess, **loopss;
189
190 /* The old_ss is a ss for a single variable. */
191 gcc_assert (old_ss->info->type == GFC_SS_SECTION)((void)(!(old_ss->info->type == GFC_SS_SECTION) ? fancy_abort
("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 191, __FUNCTION__), 0 : 0))
;
192
193 for (sess = &(se->ss); *sess != gfc_ss_terminator; sess = &((*sess)->next))
194 if (*sess == old_ss)
195 break;
196 gcc_assert (*sess != gfc_ss_terminator)((void)(!(*sess != gfc_ss_terminator) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 196, __FUNCTION__), 0 : 0))
;
197
198 *sess = new_ss;
199 new_ss->next = old_ss->next;
200
201 /* Make sure that trailing references are not lost. */
202 if (old_ss->info
203 && old_ss->info->data.array.ref
204 && old_ss->info->data.array.ref->next
205 && !(new_ss->info->data.array.ref
206 && new_ss->info->data.array.ref->next))
207 new_ss->info->data.array.ref = old_ss->info->data.array.ref;
208
209 for (loopss = &(se->loop->ss); *loopss != gfc_ss_terminator;
210 loopss = &((*loopss)->loop_chain))
211 if (*loopss == old_ss)
212 break;
213 gcc_assert (*loopss != gfc_ss_terminator)((void)(!(*loopss != gfc_ss_terminator) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 213, __FUNCTION__), 0 : 0))
;
214
215 *loopss = new_ss;
216 new_ss->loop_chain = old_ss->loop_chain;
217 new_ss->loop = old_ss->loop;
218
219 gfc_free_ss (old_ss);
220}
221
222
223/* Check for dependencies between INTENT(IN) and INTENT(OUT) arguments of
224 elemental subroutines. Make temporaries for output arguments if any such
225 dependencies are found. Output arguments are chosen because internal_unpack
226 can be used, as is, to copy the result back to the variable. */
227static void
228gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse,
229 gfc_symbol * sym, gfc_actual_arglist * arg,
230 gfc_dep_check check_variable)
231{
232 gfc_actual_arglist *arg0;
233 gfc_expr *e;
234 gfc_formal_arglist *formal;
235 gfc_se parmse;
236 gfc_ss *ss;
237 gfc_symbol *fsym;
238 tree data;
239 tree size;
240 tree tmp;
241
242 if (loopse->ss == NULL__null)
243 return;
244
245 ss = loopse->ss;
246 arg0 = arg;
247 formal = gfc_sym_get_dummy_args (sym);
248
249 /* Loop over all the arguments testing for dependencies. */
250 for (; arg != NULL__null; arg = arg->next, formal = formal ? formal->next : NULL__null)
251 {
252 e = arg->expr;
253 if (e == NULL__null)
254 continue;
255
256 /* Obtain the info structure for the current argument. */
257 for (ss = loopse->ss; ss && ss != gfc_ss_terminator; ss = ss->next)
258 if (ss->info->expr == e)
259 break;
260
261 /* If there is a dependency, create a temporary and use it
262 instead of the variable. */
263 fsym = formal ? formal->sym : NULL__null;
264 if (e->expr_type == EXPR_VARIABLE
265 && e->rank && fsym
266 && fsym->attr.intent != INTENT_IN
267 && gfc_check_fncall_dependency (e, fsym->attr.intent,
268 sym, arg0, check_variable))
269 {
270 tree initial, temptype;
271 stmtblock_t temp_post;
272 gfc_ss *tmp_ss;
273
274 tmp_ss = gfc_get_array_ss (gfc_ss_terminator, NULL__null, ss->dimen,
275 GFC_SS_SECTION);
276 gfc_mark_ss_chain_used (tmp_ss, 1);
277 tmp_ss->info->expr = ss->info->expr;
278 replace_ss (loopse, ss, tmp_ss);
279
280 /* Obtain the argument descriptor for unpacking. */
281 gfc_init_se (&parmse, NULL__null);
282 parmse.want_pointer = 1;
283 gfc_conv_expr_descriptor (&parmse, e);
284 gfc_add_block_to_block (&se->pre, &parmse.pre);
285
286 /* If we've got INTENT(INOUT) or a derived type with INTENT(OUT),
287 initialize the array temporary with a copy of the values. */
288 if (fsym->attr.intent == INTENT_INOUT
289 || (fsym->ts.type ==BT_DERIVED
290 && fsym->attr.intent == INTENT_OUT))
291 initial = parmse.expr;
292 /* For class expressions, we always initialize with the copy of
293 the values. */
294 else if (e->ts.type == BT_CLASS)
295 initial = parmse.expr;
296 else
297 initial = NULL_TREE(tree) __null;
298
299 if (e->ts.type != BT_CLASS)
300 {
301 /* Find the type of the temporary to create; we don't use the type
302 of e itself as this breaks for subcomponent-references in e
303 (where the type of e is that of the final reference, but
304 parmse.expr's type corresponds to the full derived-type). */
305 /* TODO: Fix this somehow so we don't need a temporary of the whole
306 array but instead only the components referenced. */
307 temptype = TREE_TYPE (parmse.expr)((contains_struct_check ((parmse.expr), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 307, __FUNCTION__))->typed.type)
; /* Pointer to descriptor. */
308 gcc_assert (TREE_CODE (temptype) == POINTER_TYPE)((void)(!(((enum tree_code) (temptype)->base.code) == POINTER_TYPE
) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 308, __FUNCTION__), 0 : 0))
;
309 temptype = TREE_TYPE (temptype)((contains_struct_check ((temptype), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 309, __FUNCTION__))->typed.type)
;
310 temptype = gfc_get_element_type (temptype);
311 }
312
313 else
314 /* For class arrays signal that the size of the dynamic type has to
315 be obtained from the vtable, using the 'initial' expression. */
316 temptype = NULL_TREE(tree) __null;
317
318 /* Generate the temporary. Cleaning up the temporary should be the
319 very last thing done, so we add the code to a new block and add it
320 to se->post as last instructions. */
321 size = gfc_create_var (gfc_array_index_type, NULL__null);
322 data = gfc_create_var (pvoid_type_node, NULL__null);
323 gfc_init_block (&temp_post);
324 tmp = gfc_trans_create_temp_array (&se->pre, &temp_post, tmp_ss,
325 temptype, initial, false, true,
326 false, &arg->expr->where);
327 gfc_add_modify (&se->pre, size, tmp);
328 tmp = fold_convert (pvoid_type_node, tmp_ss->info->data.array.data)fold_convert_loc (((location_t) 0), pvoid_type_node, tmp_ss->
info->data.array.data)
;
329 gfc_add_modify (&se->pre, data, tmp);
330
331 /* Update other ss' delta. */
332 gfc_set_delta (loopse->loop);
333
334 /* Copy the result back using unpack..... */
335 if (e->ts.type != BT_CLASS)
336 tmp = build_call_expr_loc (input_location,
337 gfor_fndecl_in_unpack, 2, parmse.expr, data);
338 else
339 {
340 /* ... except for class results where the copy is
341 unconditional. */
342 tmp = build_fold_indirect_ref_loc (input_location, parmse.expr);
343 tmp = gfc_conv_descriptor_data_get (tmp);
344 tmp = build_call_expr_loc (input_location,
345 builtin_decl_explicit (BUILT_IN_MEMCPY),
346 3, tmp, data,
347 fold_convert (size_type_node, size)fold_convert_loc (((location_t) 0), global_trees[TI_SIZE_TYPE
], size)
);
348 }
349 gfc_add_expr_to_block (&se->post, tmp);
350
351 /* parmse.pre is already added above. */
352 gfc_add_block_to_block (&se->post, &parmse.post);
353 gfc_add_block_to_block (&se->post, &temp_post);
354 }
355 }
356}
357
358
359/* Given an executable statement referring to an intrinsic function call,
360 returns the intrinsic symbol. */
361
362static gfc_intrinsic_sym *
363get_intrinsic_for_code (gfc_code *code)
364{
365 if (code->op == EXEC_CALL)
366 {
367 gfc_intrinsic_sym * const isym = code->resolved_isym;
368 if (isym)
369 return isym;
370 else
371 return gfc_get_intrinsic_for_expr (code->expr1);
372 }
373
374 return NULL__null;
375}
376
377
378/* Translate the CALL statement. Builds a call to an F95 subroutine. */
379
380tree
381gfc_trans_call (gfc_code * code, bool dependency_check,
382 tree mask, tree count1, bool invert)
383{
384 gfc_se se;
385 gfc_ss * ss;
386 int has_alternate_specifier;
387 gfc_dep_check check_variable;
388 tree index = NULL_TREE(tree) __null;
389 tree maskexpr = NULL_TREE(tree) __null;
390 tree tmp;
391 bool is_intrinsic_mvbits;
392
393 /* A CALL starts a new block because the actual arguments may have to
394 be evaluated first. */
395 gfc_init_se (&se, NULL__null);
396 gfc_start_block (&se.pre);
397
398 gcc_assert (code->resolved_sym)((void)(!(code->resolved_sym) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 398, __FUNCTION__), 0 : 0))
;
399
400 ss = gfc_ss_terminator;
401 if (code->resolved_sym->attr.elemental)
402 ss = gfc_walk_elemental_function_args (ss, code->ext.actual,
403 get_intrinsic_for_code (code),
404 GFC_SS_REFERENCE);
405
406 /* MVBITS is inlined but needs the dependency checking found here. */
407 is_intrinsic_mvbits = code->resolved_isym
408 && code->resolved_isym->id == GFC_ISYM_MVBITS;
409
410 /* Is not an elemental subroutine call with array valued arguments. */
411 if (ss == gfc_ss_terminator)
412 {
413
414 if (is_intrinsic_mvbits)
415 {
416 has_alternate_specifier = 0;
417 gfc_conv_intrinsic_mvbits (&se, code->ext.actual, NULL__null);
418 }
419 else
420 {
421 /* Translate the call. */
422 has_alternate_specifier =
423 gfc_conv_procedure_call (&se, code->resolved_sym,
424 code->ext.actual, code->expr1, NULL__null);
425
426 /* A subroutine without side-effect, by definition, does nothing! */
427 TREE_SIDE_EFFECTS (se.expr)((non_type_check ((se.expr), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 427, __FUNCTION__))->base.side_effects_flag)
= 1;
428 }
429
430 /* Chain the pieces together and return the block. */
431 if (has_alternate_specifier)
432 {
433 gfc_code *select_code;
434 gfc_symbol *sym;
435 select_code = code->next;
436 gcc_assert(select_code->op == EXEC_SELECT)((void)(!(select_code->op == EXEC_SELECT) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 436, __FUNCTION__), 0 : 0))
;
437 sym = select_code->expr1->symtree->n.sym;
438 se.expr = convert (gfc_typenode_for_spec (&sym->ts), se.expr);
439 if (sym->backend_decl == NULL__null)
440 sym->backend_decl = gfc_get_symbol_decl (sym);
441 gfc_add_modify (&se.pre, sym->backend_decl, se.expr);
442 }
443 else
444 gfc_add_expr_to_block (&se.pre, se.expr);
445
446 gfc_add_block_to_block (&se.pre, &se.post);
447 }
448
449 else
450 {
451 /* An elemental subroutine call with array valued arguments has
452 to be scalarized. */
453 gfc_loopinfo loop;
454 stmtblock_t body;
455 stmtblock_t block;
456 gfc_se loopse;
457 gfc_se depse;
458
459 /* gfc_walk_elemental_function_args renders the ss chain in the
460 reverse order to the actual argument order. */
461 ss = gfc_reverse_ss (ss);
462
463 /* Initialize the loop. */
464 gfc_init_se (&loopse, NULL__null);
465 gfc_init_loopinfo (&loop);
466 gfc_add_ss_to_loop (&loop, ss);
467
468 gfc_conv_ss_startstride (&loop);
469 /* TODO: gfc_conv_loop_setup generates a temporary for vector
470 subscripts. This could be prevented in the elemental case
471 as temporaries are handled separatedly
472 (below in gfc_conv_elemental_dependencies). */
473 if (code->expr1)
474 gfc_conv_loop_setup (&loop, &code->expr1->where);
475 else
476 gfc_conv_loop_setup (&loop, &code->loc);
477
478 gfc_mark_ss_chain_used (ss, 1);
479
480 /* Convert the arguments, checking for dependencies. */
481 gfc_copy_loopinfo_to_se (&loopse, &loop);
482 loopse.ss = ss;
483
484 /* For operator assignment, do dependency checking. */
485 if (dependency_check)
486 check_variable = ELEM_CHECK_VARIABLE;
487 else
488 check_variable = ELEM_DONT_CHECK_VARIABLE;
489
490 gfc_init_se (&depse, NULL__null);
491 gfc_conv_elemental_dependencies (&depse, &loopse, code->resolved_sym,
492 code->ext.actual, check_variable);
493
494 gfc_add_block_to_block (&loop.pre, &depse.pre);
495 gfc_add_block_to_block (&loop.post, &depse.post);
496
497 /* Generate the loop body. */
498 gfc_start_scalarized_body (&loop, &body);
499 gfc_init_block (&block);
500
501 if (mask && count1)
502 {
503 /* Form the mask expression according to the mask. */
504 index = count1;
505 maskexpr = gfc_build_array_ref (mask, index, NULL__null);
506 if (invert)
507 maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
508 TREE_TYPE (maskexpr)((contains_struct_check ((maskexpr), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 508, __FUNCTION__))->typed.type)
, maskexpr);
509 }
510
511 if (is_intrinsic_mvbits)
512 {
513 has_alternate_specifier = 0;
514 gfc_conv_intrinsic_mvbits (&loopse, code->ext.actual, &loop);
515 }
516 else
517 {
518 /* Add the subroutine call to the block. */
519 gfc_conv_procedure_call (&loopse, code->resolved_sym,
520 code->ext.actual, code->expr1,
521 NULL__null);
522 }
523
524 if (mask && count1)
525 {
526 tmp = build3_v (COND_EXPR, maskexpr, loopse.expr,fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], maskexpr, loopse.expr, build_empty_stmt (input_location))
527 build_empty_stmt (input_location))fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], maskexpr, loopse.expr, build_empty_stmt (input_location))
;
528 gfc_add_expr_to_block (&loopse.pre, tmp);
529 tmp = fold_build2_loc (input_location, PLUS_EXPR,
530 gfc_array_index_type,
531 count1, gfc_index_one_nodegfc_rank_cst[1]);
532 gfc_add_modify (&loopse.pre, count1, tmp);
533 }
534 else
535 gfc_add_expr_to_block (&loopse.pre, loopse.expr);
536
537 gfc_add_block_to_block (&block, &loopse.pre);
538 gfc_add_block_to_block (&block, &loopse.post);
539
540 /* Finish up the loop block and the loop. */
541 gfc_add_expr_to_block (&body, gfc_finish_block (&block));
542 gfc_trans_scalarizing_loops (&loop, &body);
543 gfc_add_block_to_block (&se.pre, &loop.pre);
544 gfc_add_block_to_block (&se.pre, &loop.post);
545 gfc_add_block_to_block (&se.pre, &se.post);
546 gfc_cleanup_loop (&loop);
547 }
548
549 return gfc_finish_block (&se.pre);
550}
551
552
553/* Translate the RETURN statement. */
554
555tree
556gfc_trans_return (gfc_code * code)
557{
558 if (code->expr1)
559 {
560 gfc_se se;
561 tree tmp;
562 tree result;
563
564 /* If code->expr is not NULL, this return statement must appear
565 in a subroutine and current_fake_result_decl has already
566 been generated. */
567
568 result = gfc_get_fake_result_decl (NULL__null, 0);
569 if (!result)
570 {
571 gfc_warning (0,
572 "An alternate return at %L without a * dummy argument",
573 &code->expr1->where);
574 return gfc_generate_return ();
575 }
576
577 /* Start a new block for this statement. */
578 gfc_init_se (&se, NULL__null);
579 gfc_start_block (&se.pre);
580
581 gfc_conv_expr (&se, code->expr1);
582
583 /* Note that the actually returned expression is a simple value and
584 does not depend on any pointers or such; thus we can clean-up with
585 se.post before returning. */
586 tmp = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (result)((contains_struct_check ((result), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 586, __FUNCTION__))->typed.type)
,
587 result, fold_convert (TREE_TYPE (result),fold_convert_loc (((location_t) 0), ((contains_struct_check (
(result), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 587, __FUNCTION__))->typed.type), se.expr)
588 se.expr)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(result), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 587, __FUNCTION__))->typed.type), se.expr)
);
589 gfc_add_expr_to_block (&se.pre, tmp);
590 gfc_add_block_to_block (&se.pre, &se.post);
591
592 tmp = gfc_generate_return ();
593 gfc_add_expr_to_block (&se.pre, tmp);
594 return gfc_finish_block (&se.pre);
595 }
596
597 return gfc_generate_return ();
598}
599
600
601/* Translate the PAUSE statement. We have to translate this statement
602 to a runtime library call. */
603
604tree
605gfc_trans_pause (gfc_code * code)
606{
607 tree gfc_int8_type_node = gfc_get_int_type (8);
608 gfc_se se;
609 tree tmp;
610
611 /* Start a new block for this statement. */
612 gfc_init_se (&se, NULL__null);
613 gfc_start_block (&se.pre);
614
615
616 if (code->expr1 == NULL__null)
617 {
618 tmp = build_int_cst (size_type_nodeglobal_trees[TI_SIZE_TYPE], 0);
619 tmp = build_call_expr_loc (input_location,
620 gfor_fndecl_pause_string, 2,
621 build_int_cst (pchar_type_node, 0), tmp);
622 }
623 else if (code->expr1->ts.type == BT_INTEGER)
624 {
625 gfc_conv_expr (&se, code->expr1);
626 tmp = build_call_expr_loc (input_location,
627 gfor_fndecl_pause_numeric, 1,
628 fold_convert (gfc_int8_type_node, se.expr)fold_convert_loc (((location_t) 0), gfc_int8_type_node, se.expr
)
);
629 }
630 else
631 {
632 gfc_conv_expr_reference (&se, code->expr1);
633 tmp = build_call_expr_loc (input_location,
634 gfor_fndecl_pause_string, 2,
635 se.expr, fold_convert (size_type_node,fold_convert_loc (((location_t) 0), global_trees[TI_SIZE_TYPE
], se.string_length)
636 se.string_length)fold_convert_loc (((location_t) 0), global_trees[TI_SIZE_TYPE
], se.string_length)
);
637 }
638
639 gfc_add_expr_to_block (&se.pre, tmp);
640
641 gfc_add_block_to_block (&se.pre, &se.post);
642
643 return gfc_finish_block (&se.pre);
644}
645
646
647/* Translate the STOP statement. We have to translate this statement
648 to a runtime library call. */
649
650tree
651gfc_trans_stop (gfc_code *code, bool error_stop)
652{
653 gfc_se se;
654 tree tmp;
655
656 /* Start a new block for this statement. */
657 gfc_init_se (&se, NULL__null);
658 gfc_start_block (&se.pre);
659
660 if (code->expr1 == NULL__null)
661 {
662 tmp = build_int_cst (size_type_nodeglobal_trees[TI_SIZE_TYPE], 0);
663 tmp = build_call_expr_loc (input_location,
664 error_stop
665 ? (flag_coarrayglobal_options.x_flag_coarray == GFC_FCOARRAY_LIB
666 ? gfor_fndecl_caf_error_stop_str
667 : gfor_fndecl_error_stop_string)
668 : (flag_coarrayglobal_options.x_flag_coarray == GFC_FCOARRAY_LIB
669 ? gfor_fndecl_caf_stop_str
670 : gfor_fndecl_stop_string),
671 3, build_int_cst (pchar_type_node, 0), tmp,
672 boolean_false_nodeglobal_trees[TI_BOOLEAN_FALSE]);
673 }
674 else if (code->expr1->ts.type == BT_INTEGER)
675 {
676 gfc_conv_expr (&se, code->expr1);
677 tmp = build_call_expr_loc (input_location,
678 error_stop
679 ? (flag_coarrayglobal_options.x_flag_coarray == GFC_FCOARRAY_LIB
680 ? gfor_fndecl_caf_error_stop
681 : gfor_fndecl_error_stop_numeric)
682 : (flag_coarrayglobal_options.x_flag_coarray == GFC_FCOARRAY_LIB
683 ? gfor_fndecl_caf_stop_numeric
684 : gfor_fndecl_stop_numeric), 2,
685 fold_convert (integer_type_node, se.expr)fold_convert_loc (((location_t) 0), integer_types[itk_int], se
.expr)
,
686 boolean_false_nodeglobal_trees[TI_BOOLEAN_FALSE]);
687 }
688 else
689 {
690 gfc_conv_expr_reference (&se, code->expr1);
691 tmp = build_call_expr_loc (input_location,
692 error_stop
693 ? (flag_coarrayglobal_options.x_flag_coarray == GFC_FCOARRAY_LIB
694 ? gfor_fndecl_caf_error_stop_str
695 : gfor_fndecl_error_stop_string)
696 : (flag_coarrayglobal_options.x_flag_coarray == GFC_FCOARRAY_LIB
697 ? gfor_fndecl_caf_stop_str
698 : gfor_fndecl_stop_string),
699 3, se.expr, fold_convert (size_type_node,fold_convert_loc (((location_t) 0), global_trees[TI_SIZE_TYPE
], se.string_length)
700 se.string_length)fold_convert_loc (((location_t) 0), global_trees[TI_SIZE_TYPE
], se.string_length)
,
701 boolean_false_nodeglobal_trees[TI_BOOLEAN_FALSE]);
702 }
703
704 gfc_add_expr_to_block (&se.pre, tmp);
705
706 gfc_add_block_to_block (&se.pre, &se.post);
707
708 return gfc_finish_block (&se.pre);
709}
710
711/* Translate the FAIL IMAGE statement. */
712
713tree
714gfc_trans_fail_image (gfc_code *code ATTRIBUTE_UNUSED__attribute__ ((__unused__)))
715{
716 if (flag_coarrayglobal_options.x_flag_coarray == GFC_FCOARRAY_LIB)
717 return build_call_expr_loc (input_location,
718 gfor_fndecl_caf_fail_image, 0);
719 else
720 {
721 const char *name = gfc_get_string (PREFIX ("exit_i%d")"_gfortran_" "exit_i%d", 4);
722 gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name);
723 tree tmp = gfc_get_symbol_decl (exsym);
724 return build_call_expr_loc (input_location, tmp, 1, integer_zero_nodeglobal_trees[TI_INTEGER_ZERO]);
725 }
726}
727
728/* Translate the FORM TEAM statement. */
729
730tree
731gfc_trans_form_team (gfc_code *code)
732{
733 if (flag_coarrayglobal_options.x_flag_coarray == GFC_FCOARRAY_LIB)
734 {
735 gfc_se se;
736 gfc_se argse1, argse2;
737 tree team_id, team_type, tmp;
738
739 gfc_init_se (&se, NULL__null);
740 gfc_init_se (&argse1, NULL__null);
741 gfc_init_se (&argse2, NULL__null);
742 gfc_start_block (&se.pre);
743
744 gfc_conv_expr_val (&argse1, code->expr1);
745 gfc_conv_expr_val (&argse2, code->expr2);
746 team_id = fold_convert (integer_type_node, argse1.expr)fold_convert_loc (((location_t) 0), integer_types[itk_int], argse1
.expr)
;
747 team_type = gfc_build_addr_expr (ppvoid_type_node, argse2.expr);
748
749 gfc_add_block_to_block (&se.pre, &argse1.pre);
750 gfc_add_block_to_block (&se.pre, &argse2.pre);
751 tmp = build_call_expr_loc (input_location,
752 gfor_fndecl_caf_form_team, 3,
753 team_id, team_type,
754 build_int_cst (integer_type_nodeinteger_types[itk_int], 0));
755 gfc_add_expr_to_block (&se.pre, tmp);
756 gfc_add_block_to_block (&se.pre, &argse1.post);
757 gfc_add_block_to_block (&se.pre, &argse2.post);
758 return gfc_finish_block (&se.pre);
759 }
760 else
761 {
762 const char *name = gfc_get_string (PREFIX ("exit_i%d")"_gfortran_" "exit_i%d", 4);
763 gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name);
764 tree tmp = gfc_get_symbol_decl (exsym);
765 return build_call_expr_loc (input_location, tmp, 1, integer_zero_nodeglobal_trees[TI_INTEGER_ZERO]);
766 }
767}
768
769/* Translate the CHANGE TEAM statement. */
770
771tree
772gfc_trans_change_team (gfc_code *code)
773{
774 if (flag_coarrayglobal_options.x_flag_coarray == GFC_FCOARRAY_LIB)
775 {
776 gfc_se argse;
777 tree team_type, tmp;
778
779 gfc_init_se (&argse, NULL__null);
780 gfc_conv_expr_val (&argse, code->expr1);
781 team_type = gfc_build_addr_expr (ppvoid_type_node, argse.expr);
782
783 tmp = build_call_expr_loc (input_location,
784 gfor_fndecl_caf_change_team, 2, team_type,
785 build_int_cst (integer_type_nodeinteger_types[itk_int], 0));
786 gfc_add_expr_to_block (&argse.pre, tmp);
787 gfc_add_block_to_block (&argse.pre, &argse.post);
788 return gfc_finish_block (&argse.pre);
789 }
790 else
791 {
792 const char *name = gfc_get_string (PREFIX ("exit_i%d")"_gfortran_" "exit_i%d", 4);
793 gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name);
794 tree tmp = gfc_get_symbol_decl (exsym);
795 return build_call_expr_loc (input_location, tmp, 1, integer_zero_nodeglobal_trees[TI_INTEGER_ZERO]);
796 }
797}
798
799/* Translate the END TEAM statement. */
800
801tree
802gfc_trans_end_team (gfc_code *code ATTRIBUTE_UNUSED__attribute__ ((__unused__)))
803{
804 if (flag_coarrayglobal_options.x_flag_coarray == GFC_FCOARRAY_LIB)
805 {
806 return build_call_expr_loc (input_location,
807 gfor_fndecl_caf_end_team, 1,
808 build_int_cst (pchar_type_node, 0));
809 }
810 else
811 {
812 const char *name = gfc_get_string (PREFIX ("exit_i%d")"_gfortran_" "exit_i%d", 4);
813 gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name);
814 tree tmp = gfc_get_symbol_decl (exsym);
815 return build_call_expr_loc (input_location, tmp, 1, integer_zero_nodeglobal_trees[TI_INTEGER_ZERO]);
816 }
817}
818
819/* Translate the SYNC TEAM statement. */
820
821tree
822gfc_trans_sync_team (gfc_code *code)
823{
824 if (flag_coarrayglobal_options.x_flag_coarray == GFC_FCOARRAY_LIB)
825 {
826 gfc_se argse;
827 tree team_type, tmp;
828
829 gfc_init_se (&argse, NULL__null);
830 gfc_conv_expr_val (&argse, code->expr1);
831 team_type = gfc_build_addr_expr (ppvoid_type_node, argse.expr);
832
833 tmp = build_call_expr_loc (input_location,
834 gfor_fndecl_caf_sync_team, 2,
835 team_type,
836 build_int_cst (integer_type_nodeinteger_types[itk_int], 0));
837 gfc_add_expr_to_block (&argse.pre, tmp);
838 gfc_add_block_to_block (&argse.pre, &argse.post);
839 return gfc_finish_block (&argse.pre);
840 }
841 else
842 {
843 const char *name = gfc_get_string (PREFIX ("exit_i%d")"_gfortran_" "exit_i%d", 4);
844 gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name);
845 tree tmp = gfc_get_symbol_decl (exsym);
846 return build_call_expr_loc (input_location, tmp, 1, integer_zero_nodeglobal_trees[TI_INTEGER_ZERO]);
847 }
848}
849
850tree
851gfc_trans_lock_unlock (gfc_code *code, gfc_exec_op op)
852{
853 gfc_se se, argse;
854 tree stat = NULL_TREE(tree) __null, stat2 = NULL_TREE(tree) __null;
855 tree lock_acquired = NULL_TREE(tree) __null, lock_acquired2 = NULL_TREE(tree) __null;
856
857 /* Short cut: For single images without STAT= or LOCK_ACQUIRED
858 return early. (ERRMSG= is always untouched for -fcoarray=single.) */
859 if (!code->expr2 && !code->expr4 && flag_coarrayglobal_options.x_flag_coarray != GFC_FCOARRAY_LIB)
860 return NULL_TREE(tree) __null;
861
862 if (code->expr2)
863 {
864 gcc_assert (code->expr2->expr_type == EXPR_VARIABLE)((void)(!(code->expr2->expr_type == EXPR_VARIABLE) ? fancy_abort
("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 864, __FUNCTION__), 0 : 0))
;
865 gfc_init_se (&argse, NULL__null);
866 gfc_conv_expr_val (&argse, code->expr2);
867 stat = argse.expr;
868 }
869 else if (flag_coarrayglobal_options.x_flag_coarray == GFC_FCOARRAY_LIB)
870 stat = null_pointer_nodeglobal_trees[TI_NULL_POINTER];
871
872 if (code->expr4)
873 {
874 gcc_assert (code->expr4->expr_type == EXPR_VARIABLE)((void)(!(code->expr4->expr_type == EXPR_VARIABLE) ? fancy_abort
("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 874, __FUNCTION__), 0 : 0))
;
875 gfc_init_se (&argse, NULL__null);
876 gfc_conv_expr_val (&argse, code->expr4);
877 lock_acquired = argse.expr;
878 }
879 else if (flag_coarrayglobal_options.x_flag_coarray == GFC_FCOARRAY_LIB)
880 lock_acquired = null_pointer_nodeglobal_trees[TI_NULL_POINTER];
881
882 gfc_start_block (&se.pre);
883 if (flag_coarrayglobal_options.x_flag_coarray == GFC_FCOARRAY_LIB)
884 {
885 tree tmp, token, image_index, errmsg, errmsg_len;
886 tree index = build_zero_cst (gfc_array_index_type);
887 tree caf_decl = gfc_get_tree_for_caf_expr (code->expr1);
888
889 if (code->expr1->symtree->n.sym->ts.type != BT_DERIVED
890 || code->expr1->symtree->n.sym->ts.u.derived->from_intmod
891 != INTMOD_ISO_FORTRAN_ENV
892 || code->expr1->symtree->n.sym->ts.u.derived->intmod_sym_id
893 != ISOFORTRAN_LOCK_TYPE)
894 {
895 gfc_error ("Sorry, the lock component of derived type at %L is not "
896 "yet supported", &code->expr1->where);
897 return NULL_TREE(tree) __null;
898 }
899
900 gfc_get_caf_token_offset (&se, &token, NULL__null, caf_decl, NULL_TREE(tree) __null,
901 code->expr1);
902
903 if (gfc_is_coindexed (code->expr1))
904 image_index = gfc_caf_get_image_index (&se.pre, code->expr1, caf_decl);
905 else
906 image_index = integer_zero_nodeglobal_trees[TI_INTEGER_ZERO];
907
908 /* For arrays, obtain the array index. */
909 if (gfc_expr_attr (code->expr1).dimension)
910 {
911 tree desc, tmp, extent, lbound, ubound;
912 gfc_array_ref *ar, ar2;
913 int i;
914
915 /* TODO: Extend this, once DT components are supported. */
916 ar = &code->expr1->ref->u.ar;
917 ar2 = *ar;
918 memset (ar, '\0', sizeof (*ar));
919 ar->as = ar2.as;
920 ar->type = AR_FULL;
921
922 gfc_init_se (&argse, NULL__null);
923 argse.descriptor_only = 1;
924 gfc_conv_expr_descriptor (&argse, code->expr1);
925 gfc_add_block_to_block (&se.pre, &argse.pre);
926 desc = argse.expr;
927 *ar = ar2;
928
929 extent = build_one_cst (gfc_array_index_type);
930 for (i = 0; i < ar->dimen; i++)
931 {
932 gfc_init_se (&argse, NULL__null);
933 gfc_conv_expr_type (&argse, ar->start[i], gfc_array_index_type);
934 gfc_add_block_to_block (&argse.pre, &argse.pre);
935 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
936 tmp = fold_build2_loc (input_location, MINUS_EXPR,
937 TREE_TYPE (lbound)((contains_struct_check ((lbound), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 937, __FUNCTION__))->typed.type)
, argse.expr, lbound);
938 tmp = fold_build2_loc (input_location, MULT_EXPR,
939 TREE_TYPE (tmp)((contains_struct_check ((tmp), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 939, __FUNCTION__))->typed.type)
, extent, tmp);
940 index = fold_build2_loc (input_location, PLUS_EXPR,
941 TREE_TYPE (tmp)((contains_struct_check ((tmp), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 941, __FUNCTION__))->typed.type)
, index, tmp);
942 if (i < ar->dimen - 1)
943 {
944 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
945 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL__null);
946 extent = fold_build2_loc (input_location, MULT_EXPR,
947 TREE_TYPE (tmp)((contains_struct_check ((tmp), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 947, __FUNCTION__))->typed.type)
, extent, tmp);
948 }
949 }
950 }
951
952 /* errmsg. */
953 if (code->expr3)
954 {
955 gfc_init_se (&argse, NULL__null);
956 argse.want_pointer = 1;
957 gfc_conv_expr (&argse, code->expr3);
958 gfc_add_block_to_block (&se.pre, &argse.pre);
959 errmsg = argse.expr;
960 errmsg_len = fold_convert (size_type_node, argse.string_length)fold_convert_loc (((location_t) 0), global_trees[TI_SIZE_TYPE
], argse.string_length)
;
961 }
962 else
963 {
964 errmsg = null_pointer_nodeglobal_trees[TI_NULL_POINTER];
965 errmsg_len = build_zero_cst (size_type_nodeglobal_trees[TI_SIZE_TYPE]);
966 }
967
968 if (stat != null_pointer_nodeglobal_trees[TI_NULL_POINTER] && TREE_TYPE (stat)((contains_struct_check ((stat), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 968, __FUNCTION__))->typed.type)
!= integer_type_nodeinteger_types[itk_int])
969 {
970 stat2 = stat;
971 stat = gfc_create_var (integer_type_nodeinteger_types[itk_int], "stat");
972 }
973
974 if (lock_acquired != null_pointer_nodeglobal_trees[TI_NULL_POINTER]
975 && TREE_TYPE (lock_acquired)((contains_struct_check ((lock_acquired), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 975, __FUNCTION__))->typed.type)
!= integer_type_nodeinteger_types[itk_int])
976 {
977 lock_acquired2 = lock_acquired;
978 lock_acquired = gfc_create_var (integer_type_nodeinteger_types[itk_int], "acquired");
979 }
980
981 index = fold_convert (size_type_node, index)fold_convert_loc (((location_t) 0), global_trees[TI_SIZE_TYPE
], index)
;
982 if (op == EXEC_LOCK)
983 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_lock, 7,
984 token, index, image_index,
985 lock_acquired != null_pointer_nodeglobal_trees[TI_NULL_POINTER]
986 ? gfc_build_addr_expr (NULL__null, lock_acquired)
987 : lock_acquired,
988 stat != null_pointer_nodeglobal_trees[TI_NULL_POINTER]
989 ? gfc_build_addr_expr (NULL__null, stat) : stat,
990 errmsg, errmsg_len);
991 else
992 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_unlock, 6,
993 token, index, image_index,
994 stat != null_pointer_nodeglobal_trees[TI_NULL_POINTER]
995 ? gfc_build_addr_expr (NULL__null, stat) : stat,
996 errmsg, errmsg_len);
997 gfc_add_expr_to_block (&se.pre, tmp);
998
999 /* It guarantees memory consistency within the same segment */
1000 tmp = gfc_build_string_const (strlen ("memory")+1, "memory"),
1001 tmp = build5_loc (input_location, ASM_EXPR, void_type_nodeglobal_trees[TI_VOID_TYPE],
1002 gfc_build_string_const (1, ""), NULL_TREE(tree) __null, NULL_TREE(tree) __null,
1003 tree_cons (NULL_TREE(tree) __null, tmp, NULL_TREE(tree) __null), NULL_TREE(tree) __null);
1004 ASM_VOLATILE_P (tmp)((tree_check ((tmp), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1004, __FUNCTION__, (ASM_EXPR)))->base.public_flag)
= 1;
1005
1006 gfc_add_expr_to_block (&se.pre, tmp);
1007
1008 if (stat2 != NULL_TREE(tree) __null)
1009 gfc_add_modify (&se.pre, stat2,
1010 fold_convert (TREE_TYPE (stat2), stat)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(stat2), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1010, __FUNCTION__))->typed.type), stat)
);
1011
1012 if (lock_acquired2 != NULL_TREE(tree) __null)
1013 gfc_add_modify (&se.pre, lock_acquired2,
1014 fold_convert (TREE_TYPE (lock_acquired2),fold_convert_loc (((location_t) 0), ((contains_struct_check (
(lock_acquired2), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1014, __FUNCTION__))->typed.type), lock_acquired)
1015 lock_acquired)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(lock_acquired2), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1014, __FUNCTION__))->typed.type), lock_acquired)
);
1016
1017 return gfc_finish_block (&se.pre);
1018 }
1019
1020 if (stat != NULL_TREE(tree) __null)
1021 gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat)((contains_struct_check ((stat), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1021, __FUNCTION__))->typed.type)
, 0));
1022
1023 if (lock_acquired != NULL_TREE(tree) __null)
1024 gfc_add_modify (&se.pre, lock_acquired,
1025 fold_convert (TREE_TYPE (lock_acquired),fold_convert_loc (((location_t) 0), ((contains_struct_check (
(lock_acquired), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1025, __FUNCTION__))->typed.type), global_trees[TI_BOOLEAN_TRUE
])
1026 boolean_true_node)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(lock_acquired), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1025, __FUNCTION__))->typed.type), global_trees[TI_BOOLEAN_TRUE
])
);
1027
1028 return gfc_finish_block (&se.pre);
1029}
1030
1031tree
1032gfc_trans_event_post_wait (gfc_code *code, gfc_exec_op op)
1033{
1034 gfc_se se, argse;
1035 tree stat = NULL_TREE(tree) __null, stat2 = NULL_TREE(tree) __null;
1036 tree until_count = NULL_TREE(tree) __null;
1037
1038 if (code->expr2)
1039 {
1040 gcc_assert (code->expr2->expr_type == EXPR_VARIABLE)((void)(!(code->expr2->expr_type == EXPR_VARIABLE) ? fancy_abort
("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1040, __FUNCTION__), 0 : 0))
;
1041 gfc_init_se (&argse, NULL__null);
1042 gfc_conv_expr_val (&argse, code->expr2);
1043 stat = argse.expr;
1044 }
1045 else if (flag_coarrayglobal_options.x_flag_coarray == GFC_FCOARRAY_LIB)
1046 stat = null_pointer_nodeglobal_trees[TI_NULL_POINTER];
1047
1048 if (code->expr4)
1049 {
1050 gfc_init_se (&argse, NULL__null);
1051 gfc_conv_expr_val (&argse, code->expr4);
1052 until_count = fold_convert (integer_type_node, argse.expr)fold_convert_loc (((location_t) 0), integer_types[itk_int], argse
.expr)
;
1053 }
1054 else
1055 until_count = integer_one_nodeglobal_trees[TI_INTEGER_ONE];
1056
1057 if (flag_coarrayglobal_options.x_flag_coarray != GFC_FCOARRAY_LIB)
1058 {
1059 gfc_start_block (&se.pre);
1060 gfc_init_se (&argse, NULL__null);
1061 gfc_conv_expr_val (&argse, code->expr1);
1062
1063 if (op == EXEC_EVENT_POST)
1064 gfc_add_modify (&se.pre, argse.expr,
1065 fold_build2_loc (input_location, PLUS_EXPR,
1066 TREE_TYPE (argse.expr)((contains_struct_check ((argse.expr), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1066, __FUNCTION__))->typed.type)
, argse.expr,
1067 build_int_cst (TREE_TYPE (argse.expr)((contains_struct_check ((argse.expr), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1067, __FUNCTION__))->typed.type)
, 1)));
1068 else
1069 gfc_add_modify (&se.pre, argse.expr,
1070 fold_build2_loc (input_location, MINUS_EXPR,
1071 TREE_TYPE (argse.expr)((contains_struct_check ((argse.expr), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1071, __FUNCTION__))->typed.type)
, argse.expr,
1072 fold_convert (TREE_TYPE (argse.expr),fold_convert_loc (((location_t) 0), ((contains_struct_check (
(argse.expr), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1072, __FUNCTION__))->typed.type), until_count)
1073 until_count)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(argse.expr), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1072, __FUNCTION__))->typed.type), until_count)
));
1074 if (stat != NULL_TREE(tree) __null)
1075 gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat)((contains_struct_check ((stat), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1075, __FUNCTION__))->typed.type)
, 0));
1076
1077 return gfc_finish_block (&se.pre);
1078 }
1079
1080 gfc_start_block (&se.pre);
1081 tree tmp, token, image_index, errmsg, errmsg_len;
1082 tree index = build_zero_cst (gfc_array_index_type);
1083 tree caf_decl = gfc_get_tree_for_caf_expr (code->expr1);
1084
1085 if (code->expr1->symtree->n.sym->ts.type != BT_DERIVED
1086 || code->expr1->symtree->n.sym->ts.u.derived->from_intmod
1087 != INTMOD_ISO_FORTRAN_ENV
1088 || code->expr1->symtree->n.sym->ts.u.derived->intmod_sym_id
1089 != ISOFORTRAN_EVENT_TYPE)
1090 {
1091 gfc_error ("Sorry, the event component of derived type at %L is not "
1092 "yet supported", &code->expr1->where);
1093 return NULL_TREE(tree) __null;
1094 }
1095
1096 gfc_init_se (&argse, NULL__null);
1097 gfc_get_caf_token_offset (&argse, &token, NULL__null, caf_decl, NULL_TREE(tree) __null,
1098 code->expr1);
1099 gfc_add_block_to_block (&se.pre, &argse.pre);
1100
1101 if (gfc_is_coindexed (code->expr1))
1102 image_index = gfc_caf_get_image_index (&se.pre, code->expr1, caf_decl);
1103 else
1104 image_index = integer_zero_nodeglobal_trees[TI_INTEGER_ZERO];
1105
1106 /* For arrays, obtain the array index. */
1107 if (gfc_expr_attr (code->expr1).dimension)
1108 {
1109 tree desc, tmp, extent, lbound, ubound;
1110 gfc_array_ref *ar, ar2;
1111 int i;
1112
1113 /* TODO: Extend this, once DT components are supported. */
1114 ar = &code->expr1->ref->u.ar;
1115 ar2 = *ar;
1116 memset (ar, '\0', sizeof (*ar));
1117 ar->as = ar2.as;
1118 ar->type = AR_FULL;
1119
1120 gfc_init_se (&argse, NULL__null);
1121 argse.descriptor_only = 1;
1122 gfc_conv_expr_descriptor (&argse, code->expr1);
1123 gfc_add_block_to_block (&se.pre, &argse.pre);
1124 desc = argse.expr;
1125 *ar = ar2;
1126
1127 extent = build_one_cst (gfc_array_index_type);
1128 for (i = 0; i < ar->dimen; i++)
1129 {
1130 gfc_init_se (&argse, NULL__null);
1131 gfc_conv_expr_type (&argse, ar->start[i], gfc_array_index_type);
1132 gfc_add_block_to_block (&argse.pre, &argse.pre);
1133 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
1134 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1135 TREE_TYPE (lbound)((contains_struct_check ((lbound), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1135, __FUNCTION__))->typed.type)
, argse.expr, lbound);
1136 tmp = fold_build2_loc (input_location, MULT_EXPR,
1137 TREE_TYPE (tmp)((contains_struct_check ((tmp), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1137, __FUNCTION__))->typed.type)
, extent, tmp);
1138 index = fold_build2_loc (input_location, PLUS_EXPR,
1139 TREE_TYPE (tmp)((contains_struct_check ((tmp), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1139, __FUNCTION__))->typed.type)
, index, tmp);
1140 if (i < ar->dimen - 1)
1141 {
1142 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
1143 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL__null);
1144 extent = fold_build2_loc (input_location, MULT_EXPR,
1145 TREE_TYPE (tmp)((contains_struct_check ((tmp), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1145, __FUNCTION__))->typed.type)
, extent, tmp);
1146 }
1147 }
1148 }
1149
1150 /* errmsg. */
1151 if (code->expr3)
1152 {
1153 gfc_init_se (&argse, NULL__null);
1154 argse.want_pointer = 1;
1155 gfc_conv_expr (&argse, code->expr3);
1156 gfc_add_block_to_block (&se.pre, &argse.pre);
1157 errmsg = argse.expr;
1158 errmsg_len = fold_convert (size_type_node, argse.string_length)fold_convert_loc (((location_t) 0), global_trees[TI_SIZE_TYPE
], argse.string_length)
;
1159 }
1160 else
1161 {
1162 errmsg = null_pointer_nodeglobal_trees[TI_NULL_POINTER];
1163 errmsg_len = build_zero_cst (size_type_nodeglobal_trees[TI_SIZE_TYPE]);
1164 }
1165
1166 if (stat != null_pointer_nodeglobal_trees[TI_NULL_POINTER] && TREE_TYPE (stat)((contains_struct_check ((stat), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1166, __FUNCTION__))->typed.type)
!= integer_type_nodeinteger_types[itk_int])
1167 {
1168 stat2 = stat;
1169 stat = gfc_create_var (integer_type_nodeinteger_types[itk_int], "stat");
1170 }
1171
1172 index = fold_convert (size_type_node, index)fold_convert_loc (((location_t) 0), global_trees[TI_SIZE_TYPE
], index)
;
1173 if (op == EXEC_EVENT_POST)
1174 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_event_post, 6,
1175 token, index, image_index,
1176 stat != null_pointer_nodeglobal_trees[TI_NULL_POINTER]
1177 ? gfc_build_addr_expr (NULL__null, stat) : stat,
1178 errmsg, errmsg_len);
1179 else
1180 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_event_wait, 6,
1181 token, index, until_count,
1182 stat != null_pointer_nodeglobal_trees[TI_NULL_POINTER]
1183 ? gfc_build_addr_expr (NULL__null, stat) : stat,
1184 errmsg, errmsg_len);
1185 gfc_add_expr_to_block (&se.pre, tmp);
1186
1187 /* It guarantees memory consistency within the same segment */
1188 tmp = gfc_build_string_const (strlen ("memory")+1, "memory"),
1189 tmp = build5_loc (input_location, ASM_EXPR, void_type_nodeglobal_trees[TI_VOID_TYPE],
1190 gfc_build_string_const (1, ""), NULL_TREE(tree) __null, NULL_TREE(tree) __null,
1191 tree_cons (NULL_TREE(tree) __null, tmp, NULL_TREE(tree) __null), NULL_TREE(tree) __null);
1192 ASM_VOLATILE_P (tmp)((tree_check ((tmp), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1192, __FUNCTION__, (ASM_EXPR)))->base.public_flag)
= 1;
1193 gfc_add_expr_to_block (&se.pre, tmp);
1194
1195 if (stat2 != NULL_TREE(tree) __null)
1196 gfc_add_modify (&se.pre, stat2, fold_convert (TREE_TYPE (stat2), stat)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(stat2), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1196, __FUNCTION__))->typed.type), stat)
);
1197
1198 return gfc_finish_block (&se.pre);
1199}
1200
1201tree
1202gfc_trans_sync (gfc_code *code, gfc_exec_op type)
1203{
1204 gfc_se se, argse;
1205 tree tmp;
1206 tree images = NULL_TREE(tree) __null, stat = NULL_TREE(tree) __null,
1207 errmsg = NULL_TREE(tree) __null, errmsglen = NULL_TREE(tree) __null;
1208
1209 /* Short cut: For single images without bound checking or without STAT=,
1210 return early. (ERRMSG= is always untouched for -fcoarray=single.) */
1211 if (!code->expr2 && !(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS(1<<0))
1212 && flag_coarrayglobal_options.x_flag_coarray != GFC_FCOARRAY_LIB)
1213 return NULL_TREE(tree) __null;
1214
1215 gfc_init_se (&se, NULL__null);
1216 gfc_start_block (&se.pre);
1217
1218 if (code->expr1 && code->expr1->rank == 0)
1219 {
1220 gfc_init_se (&argse, NULL__null);
1221 gfc_conv_expr_val (&argse, code->expr1);
1222 images = argse.expr;
1223 }
1224
1225 if (code->expr2)
1226 {
1227 gcc_assert (code->expr2->expr_type == EXPR_VARIABLE((void)(!(code->expr2->expr_type == EXPR_VARIABLE || code
->expr2->expr_type == EXPR_FUNCTION) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1228, __FUNCTION__), 0 : 0))
1228 || code->expr2->expr_type == EXPR_FUNCTION)((void)(!(code->expr2->expr_type == EXPR_VARIABLE || code
->expr2->expr_type == EXPR_FUNCTION) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1228, __FUNCTION__), 0 : 0))
;
1229 gfc_init_se (&argse, NULL__null);
1230 gfc_conv_expr_val (&argse, code->expr2);
1231 stat = argse.expr;
1232 }
1233 else
1234 stat = null_pointer_nodeglobal_trees[TI_NULL_POINTER];
1235
1236 if (code->expr3 && flag_coarrayglobal_options.x_flag_coarray == GFC_FCOARRAY_LIB)
1237 {
1238 gcc_assert (code->expr3->expr_type == EXPR_VARIABLE((void)(!(code->expr3->expr_type == EXPR_VARIABLE || code
->expr3->expr_type == EXPR_FUNCTION) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1239, __FUNCTION__), 0 : 0))
1239 || code->expr3->expr_type == EXPR_FUNCTION)((void)(!(code->expr3->expr_type == EXPR_VARIABLE || code
->expr3->expr_type == EXPR_FUNCTION) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1239, __FUNCTION__), 0 : 0))
;
1240 gfc_init_se (&argse, NULL__null);
1241 argse.want_pointer = 1;
1242 gfc_conv_expr (&argse, code->expr3);
1243 gfc_conv_string_parameter (&argse);
1244 errmsg = gfc_build_addr_expr (NULL__null, argse.expr);
1245 errmsglen = fold_convert (size_type_node, argse.string_length)fold_convert_loc (((location_t) 0), global_trees[TI_SIZE_TYPE
], argse.string_length)
;
1246 }
1247 else if (flag_coarrayglobal_options.x_flag_coarray == GFC_FCOARRAY_LIB)
1248 {
1249 errmsg = null_pointer_nodeglobal_trees[TI_NULL_POINTER];
1250 errmsglen = build_int_cst (size_type_nodeglobal_trees[TI_SIZE_TYPE], 0);
1251 }
1252
1253 /* Check SYNC IMAGES(imageset) for valid image index.
1254 FIXME: Add a check for image-set arrays. */
1255 if (code->expr1 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS(1<<0))
1256 && code->expr1->rank == 0)
1257 {
1258 tree images2 = fold_convert (integer_type_node, images)fold_convert_loc (((location_t) 0), integer_types[itk_int], images
)
;
1259 tree cond;
1260 if (flag_coarrayglobal_options.x_flag_coarray != GFC_FCOARRAY_LIB)
1261 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1262 images, build_int_cst (TREE_TYPE (images)((contains_struct_check ((images), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1262, __FUNCTION__))->typed.type)
, 1));
1263 else
1264 {
1265 tree cond2;
1266 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images,
1267 2, integer_zero_nodeglobal_trees[TI_INTEGER_ZERO],
1268 build_int_cst (integer_type_nodeinteger_types[itk_int], -1));
1269 cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
1270 images2, tmp);
1271 cond2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
1272 images,
1273 build_int_cst (TREE_TYPE (images)((contains_struct_check ((images), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1273, __FUNCTION__))->typed.type)
, 1));
1274 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1275 logical_type_node, cond, cond2);
1276 }
1277 gfc_trans_runtime_check (true, false, cond, &se.pre,
1278 &code->expr1->where, "Invalid image number "
1279 "%d in SYNC IMAGES", images2);
1280 }
1281
1282 /* Per F2008, 8.5.1, a SYNC MEMORY is implied by calling the
1283 image control statements SYNC IMAGES and SYNC ALL. */
1284 if (flag_coarrayglobal_options.x_flag_coarray == GFC_FCOARRAY_LIB)
1285 {
1286 tmp = gfc_build_string_const (strlen ("memory")+1, "memory"),
1287 tmp = build5_loc (input_location, ASM_EXPR, void_type_nodeglobal_trees[TI_VOID_TYPE],
1288 gfc_build_string_const (1, ""), NULL_TREE(tree) __null, NULL_TREE(tree) __null,
1289 tree_cons (NULL_TREE(tree) __null, tmp, NULL_TREE(tree) __null), NULL_TREE(tree) __null);
1290 ASM_VOLATILE_P (tmp)((tree_check ((tmp), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1290, __FUNCTION__, (ASM_EXPR)))->base.public_flag)
= 1;
1291 gfc_add_expr_to_block (&se.pre, tmp);
1292 }
1293
1294 if (flag_coarrayglobal_options.x_flag_coarray != GFC_FCOARRAY_LIB)
1295 {
1296 /* Set STAT to zero. */
1297 if (code->expr2)
1298 gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat)((contains_struct_check ((stat), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1298, __FUNCTION__))->typed.type)
, 0));
1299 }
1300 else if (type == EXEC_SYNC_ALL || type == EXEC_SYNC_MEMORY)
1301 {
1302 /* SYNC ALL => stat == null_pointer_node
1303 SYNC ALL(stat=s) => stat has an integer type
1304
1305 If "stat" has the wrong integer type, use a temp variable of
1306 the right type and later cast the result back into "stat". */
1307 if (stat == null_pointer_nodeglobal_trees[TI_NULL_POINTER] || TREE_TYPE (stat)((contains_struct_check ((stat), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1307, __FUNCTION__))->typed.type)
== integer_type_nodeinteger_types[itk_int])
1308 {
1309 if (TREE_TYPE (stat)((contains_struct_check ((stat), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1309, __FUNCTION__))->typed.type)
== integer_type_nodeinteger_types[itk_int])
1310 stat = gfc_build_addr_expr (NULL__null, stat);
1311
1312 if(type == EXEC_SYNC_MEMORY)
1313 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_memory,
1314 3, stat, errmsg, errmsglen);
1315 else
1316 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all,
1317 3, stat, errmsg, errmsglen);
1318
1319 gfc_add_expr_to_block (&se.pre, tmp);
1320 }
1321 else
1322 {
1323 tree tmp_stat = gfc_create_var (integer_type_nodeinteger_types[itk_int], "stat");
1324
1325 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all,
1326 3, gfc_build_addr_expr (NULL__null, tmp_stat),
1327 errmsg, errmsglen);
1328 gfc_add_expr_to_block (&se.pre, tmp);
1329
1330 gfc_add_modify (&se.pre, stat,
1331 fold_convert (TREE_TYPE (stat), tmp_stat)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(stat), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1331, __FUNCTION__))->typed.type), tmp_stat)
);
1332 }
1333 }
1334 else
1335 {
1336 tree len;
1337
1338 gcc_assert (type == EXEC_SYNC_IMAGES)((void)(!(type == EXEC_SYNC_IMAGES) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1338, __FUNCTION__), 0 : 0))
;
1339
1340 if (!code->expr1)
1341 {
1342 len = build_int_cst (integer_type_nodeinteger_types[itk_int], -1);
1343 images = null_pointer_nodeglobal_trees[TI_NULL_POINTER];
1344 }
1345 else if (code->expr1->rank == 0)
1346 {
1347 len = build_int_cst (integer_type_nodeinteger_types[itk_int], 1);
1348 images = gfc_build_addr_expr (NULL_TREE(tree) __null, images);
1349 }
1350 else
1351 {
1352 /* FIXME. */
1353 if (code->expr1->ts.kind != gfc_c_int_kind)
1354 gfc_fatal_error ("Sorry, only support for integer kind %d "
1355 "implemented for image-set at %L",
1356 gfc_c_int_kind, &code->expr1->where);
1357
1358 gfc_conv_array_parameter (&se, code->expr1, true, NULL__null, NULL__null, &len);
1359 images = se.expr;
1360
1361 tmp = gfc_typenode_for_spec (&code->expr1->ts);
1362 if (GFC_ARRAY_TYPE_P (tmp)((tree_class_check ((tmp), (tcc_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1362, __FUNCTION__))->type_common.lang_flag_2)
|| GFC_DESCRIPTOR_TYPE_P (tmp)((tree_class_check ((tmp), (tcc_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1362, __FUNCTION__))->type_common.lang_flag_1)
)
1363 tmp = gfc_get_element_type (tmp);
1364
1365 len = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
1366 TREE_TYPE (len)((contains_struct_check ((len), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1366, __FUNCTION__))->typed.type)
, len,
1367 fold_convert (TREE_TYPE (len),fold_convert_loc (((location_t) 0), ((contains_struct_check (
(len), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1367, __FUNCTION__))->typed.type), ((tree_class_check ((
tmp), (tcc_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1368, __FUNCTION__))->type_common.size_unit))
1368 TYPE_SIZE_UNIT (tmp))fold_convert_loc (((location_t) 0), ((contains_struct_check (
(len), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1367, __FUNCTION__))->typed.type), ((tree_class_check ((
tmp), (tcc_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1368, __FUNCTION__))->type_common.size_unit))
);
1369 len = fold_convert (integer_type_node, len)fold_convert_loc (((location_t) 0), integer_types[itk_int], len
)
;
1370 }
1371
1372 /* SYNC IMAGES(imgs) => stat == null_pointer_node
1373 SYNC IMAGES(imgs,stat=s) => stat has an integer type
1374
1375 If "stat" has the wrong integer type, use a temp variable of
1376 the right type and later cast the result back into "stat". */
1377 if (stat == null_pointer_nodeglobal_trees[TI_NULL_POINTER] || TREE_TYPE (stat)((contains_struct_check ((stat), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1377, __FUNCTION__))->typed.type)
== integer_type_nodeinteger_types[itk_int])
1378 {
1379 if (TREE_TYPE (stat)((contains_struct_check ((stat), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1379, __FUNCTION__))->typed.type)
== integer_type_nodeinteger_types[itk_int])
1380 stat = gfc_build_addr_expr (NULL__null, stat);
1381
1382 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_images,
1383 5, fold_convert (integer_type_node, len)fold_convert_loc (((location_t) 0), integer_types[itk_int], len
)
,
1384 images, stat, errmsg, errmsglen);
1385 gfc_add_expr_to_block (&se.pre, tmp);
1386 }
1387 else
1388 {
1389 tree tmp_stat = gfc_create_var (integer_type_nodeinteger_types[itk_int], "stat");
1390
1391 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_images,
1392 5, fold_convert (integer_type_node, len)fold_convert_loc (((location_t) 0), integer_types[itk_int], len
)
,
1393 images, gfc_build_addr_expr (NULL__null, tmp_stat),
1394 errmsg, errmsglen);
1395 gfc_add_expr_to_block (&se.pre, tmp);
1396
1397 gfc_add_modify (&se.pre, stat,
1398 fold_convert (TREE_TYPE (stat), tmp_stat)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(stat), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1398, __FUNCTION__))->typed.type), tmp_stat)
);
1399 }
1400 }
1401
1402 return gfc_finish_block (&se.pre);
1403}
1404
1405
1406/* Generate GENERIC for the IF construct. This function also deals with
1407 the simple IF statement, because the front end translates the IF
1408 statement into an IF construct.
1409
1410 We translate:
1411
1412 IF (cond) THEN
1413 then_clause
1414 ELSEIF (cond2)
1415 elseif_clause
1416 ELSE
1417 else_clause
1418 ENDIF
1419
1420 into:
1421
1422 pre_cond_s;
1423 if (cond_s)
1424 {
1425 then_clause;
1426 }
1427 else
1428 {
1429 pre_cond_s
1430 if (cond_s)
1431 {
1432 elseif_clause
1433 }
1434 else
1435 {
1436 else_clause;
1437 }
1438 }
1439
1440 where COND_S is the simplified version of the predicate. PRE_COND_S
1441 are the pre side-effects produced by the translation of the
1442 conditional.
1443 We need to build the chain recursively otherwise we run into
1444 problems with folding incomplete statements. */
1445
1446static tree
1447gfc_trans_if_1 (gfc_code * code)
1448{
1449 gfc_se if_se;
1450 tree stmt, elsestmt;
1451 locus saved_loc;
1452 location_t loc;
1453
1454 /* Check for an unconditional ELSE clause. */
1455 if (!code->expr1)
1456 return gfc_trans_code (code->next);
1457
1458 /* Initialize a statement builder for each block. Puts in NULL_TREEs. */
1459 gfc_init_se (&if_se, NULL__null);
1460 gfc_start_block (&if_se.pre);
1461
1462 /* Calculate the IF condition expression. */
1463 if (code->expr1->where.lb)
1464 {
1465 gfc_save_backend_locus (&saved_loc);
1466 gfc_set_backend_locus (&code->expr1->where);
1467 }
1468
1469 gfc_conv_expr_val (&if_se, code->expr1);
1470
1471 if (code->expr1->where.lb)
1472 gfc_restore_backend_locus (&saved_loc);
1473
1474 /* Translate the THEN clause. */
1475 stmt = gfc_trans_code (code->next);
1476
1477 /* Translate the ELSE clause. */
1478 if (code->block)
1479 elsestmt = gfc_trans_if_1 (code->block);
1480 else
1481 elsestmt = build_empty_stmt (input_location);
1482
1483 /* Build the condition expression and add it to the condition block. */
1484 loc = code->expr1->where.lb ? gfc_get_location (&code->expr1->where)
1485 : input_location;
1486 stmt = fold_build3_loc (loc, COND_EXPR, void_type_nodeglobal_trees[TI_VOID_TYPE], if_se.expr, stmt,
1487 elsestmt);
1488
1489 gfc_add_expr_to_block (&if_se.pre, stmt);
1490
1491 /* Finish off this statement. */
1492 return gfc_finish_block (&if_se.pre);
1493}
1494
1495tree
1496gfc_trans_if (gfc_code * code)
1497{
1498 stmtblock_t body;
1499 tree exit_label;
1500
1501 /* Create exit label so it is available for trans'ing the body code. */
1502 exit_label = gfc_build_label_decl (NULL_TREE(tree) __null);
1503 code->exit_label = exit_label;
1504
1505 /* Translate the actual code in code->block. */
1506 gfc_init_block (&body);
1507 gfc_add_expr_to_block (&body, gfc_trans_if_1 (code->block));
1508
1509 /* Add exit label. */
1510 gfc_add_expr_to_block (&body, build1_v (LABEL_EXPR, exit_label)fold_build1_loc (input_location, LABEL_EXPR, global_trees[TI_VOID_TYPE
], exit_label)
);
1511
1512 return gfc_finish_block (&body);
1513}
1514
1515
1516/* Translate an arithmetic IF expression.
1517
1518 IF (cond) label1, label2, label3 translates to
1519
1520 if (cond <= 0)
1521 {
1522 if (cond < 0)
1523 goto label1;
1524 else // cond == 0
1525 goto label2;
1526 }
1527 else // cond > 0
1528 goto label3;
1529
1530 An optimized version can be generated in case of equal labels.
1531 E.g., if label1 is equal to label2, we can translate it to
1532
1533 if (cond <= 0)
1534 goto label1;
1535 else
1536 goto label3;
1537*/
1538
1539tree
1540gfc_trans_arithmetic_if (gfc_code * code)
1541{
1542 gfc_se se;
1543 tree tmp;
1544 tree branch1;
1545 tree branch2;
1546 tree zero;
1547
1548 /* Start a new block. */
1549 gfc_init_se (&se, NULL__null);
1550 gfc_start_block (&se.pre);
1551
1552 /* Pre-evaluate COND. */
1553 gfc_conv_expr_val (&se, code->expr1);
1554 se.expr = gfc_evaluate_now (se.expr, &se.pre);
1555
1556 /* Build something to compare with. */
1557 zero = gfc_build_const (TREE_TYPE (se.expr)((contains_struct_check ((se.expr), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1557, __FUNCTION__))->typed.type)
, integer_zero_nodeglobal_trees[TI_INTEGER_ZERO]);
1558
1559 if (code->label1->value != code->label2->value)
1560 {
1561 /* If (cond < 0) take branch1 else take branch2.
1562 First build jumps to the COND .LT. 0 and the COND .EQ. 0 cases. */
1563 branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label1))fold_build1_loc (input_location, GOTO_EXPR, global_trees[TI_VOID_TYPE
], gfc_get_label_decl (code->label1))
;
1564 branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label2))fold_build1_loc (input_location, GOTO_EXPR, global_trees[TI_VOID_TYPE
], gfc_get_label_decl (code->label2))
;
1565
1566 if (code->label1->value != code->label3->value)
1567 tmp = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
1568 se.expr, zero);
1569 else
1570 tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1571 se.expr, zero);
1572
1573 branch1 = fold_build3_loc (input_location, COND_EXPR, void_type_nodeglobal_trees[TI_VOID_TYPE],
1574 tmp, branch1, branch2);
1575 }
1576 else
1577 branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label1))fold_build1_loc (input_location, GOTO_EXPR, global_trees[TI_VOID_TYPE
], gfc_get_label_decl (code->label1))
;
1578
1579 if (code->label1->value != code->label3->value
1580 && code->label2->value != code->label3->value)
1581 {
1582 /* if (cond <= 0) take branch1 else take branch2. */
1583 branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label3))fold_build1_loc (input_location, GOTO_EXPR, global_trees[TI_VOID_TYPE
], gfc_get_label_decl (code->label3))
;
1584 tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
1585 se.expr, zero);
1586 branch1 = fold_build3_loc (input_location, COND_EXPR, void_type_nodeglobal_trees[TI_VOID_TYPE],
1587 tmp, branch1, branch2);
1588 }
1589
1590 /* Append the COND_EXPR to the evaluation of COND, and return. */
1591 gfc_add_expr_to_block (&se.pre, branch1);
1592 return gfc_finish_block (&se.pre);
1593}
1594
1595
1596/* Translate a CRITICAL block. */
1597tree
1598gfc_trans_critical (gfc_code *code)
1599{
1600 stmtblock_t block;
1601 tree tmp, token = NULL_TREE(tree) __null;
1602
1603 gfc_start_block (&block);
1604
1605 if (flag_coarrayglobal_options.x_flag_coarray == GFC_FCOARRAY_LIB)
1606 {
1607 tree zero_size = build_zero_cst (size_type_nodeglobal_trees[TI_SIZE_TYPE]);
1608 token = gfc_get_symbol_decl (code->resolved_sym);
1609 token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (token))(((tree_class_check ((((contains_struct_check ((token), (TS_TYPED
), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1609, __FUNCTION__))->typed.type)), (tcc_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1609, __FUNCTION__))->type_with_lang_specific.lang_specific
)->caf_token)
;
1610 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_lock, 7,
1611 token, zero_size, integer_one_nodeglobal_trees[TI_INTEGER_ONE],
1612 null_pointer_nodeglobal_trees[TI_NULL_POINTER], null_pointer_nodeglobal_trees[TI_NULL_POINTER],
1613 null_pointer_nodeglobal_trees[TI_NULL_POINTER], zero_size);
1614 gfc_add_expr_to_block (&block, tmp);
1615
1616 /* It guarantees memory consistency within the same segment */
1617 tmp = gfc_build_string_const (strlen ("memory")+1, "memory"),
1618 tmp = build5_loc (input_location, ASM_EXPR, void_type_nodeglobal_trees[TI_VOID_TYPE],
1619 gfc_build_string_const (1, ""),
1620 NULL_TREE(tree) __null, NULL_TREE(tree) __null,
1621 tree_cons (NULL_TREE(tree) __null, tmp, NULL_TREE(tree) __null),
1622 NULL_TREE(tree) __null);
1623 ASM_VOLATILE_P (tmp)((tree_check ((tmp), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1623, __FUNCTION__, (ASM_EXPR)))->base.public_flag)
= 1;
1624
1625 gfc_add_expr_to_block (&block, tmp);
1626 }
1627
1628 tmp = gfc_trans_code (code->block->next);
1629 gfc_add_expr_to_block (&block, tmp);
1630
1631 if (flag_coarrayglobal_options.x_flag_coarray == GFC_FCOARRAY_LIB)
1632 {
1633 tree zero_size = build_zero_cst (size_type_nodeglobal_trees[TI_SIZE_TYPE]);
1634 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_unlock, 6,
1635 token, zero_size, integer_one_nodeglobal_trees[TI_INTEGER_ONE],
1636 null_pointer_nodeglobal_trees[TI_NULL_POINTER], null_pointer_nodeglobal_trees[TI_NULL_POINTER],
1637 zero_size);
1638 gfc_add_expr_to_block (&block, tmp);
1639
1640 /* It guarantees memory consistency within the same segment */
1641 tmp = gfc_build_string_const (strlen ("memory")+1, "memory"),
1642 tmp = build5_loc (input_location, ASM_EXPR, void_type_nodeglobal_trees[TI_VOID_TYPE],
1643 gfc_build_string_const (1, ""),
1644 NULL_TREE(tree) __null, NULL_TREE(tree) __null,
1645 tree_cons (NULL_TREE(tree) __null, tmp, NULL_TREE(tree) __null),
1646 NULL_TREE(tree) __null);
1647 ASM_VOLATILE_P (tmp)((tree_check ((tmp), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1647, __FUNCTION__, (ASM_EXPR)))->base.public_flag)
= 1;
1648
1649 gfc_add_expr_to_block (&block, tmp);
1650 }
1651
1652 return gfc_finish_block (&block);
1653}
1654
1655
1656/* Return true, when the class has a _len component. */
1657
1658static bool
1659class_has_len_component (gfc_symbol *sym)
1660{
1661 gfc_component *comp = sym->ts.u.derived->components;
1662 while (comp)
1663 {
1664 if (strcmp (comp->name, "_len") == 0)
1665 return true;
1666 comp = comp->next;
1667 }
1668 return false;
1669}
1670
1671
1672static void
1673copy_descriptor (stmtblock_t *block, tree dst, tree src, int rank)
1674{
1675 int n;
1676 tree dim;
1677 tree tmp;
1678 tree tmp2;
1679 tree size;
1680 tree offset;
1681
1682 offset = gfc_index_zero_nodegfc_rank_cst[0];
1683
1684 /* Use memcpy to copy the descriptor. The size is the minimum of
1685 the sizes of 'src' and 'dst'. This avoids a non-trivial conversion. */
1686 tmp = TYPE_SIZE_UNIT (TREE_TYPE (src))((tree_class_check ((((contains_struct_check ((src), (TS_TYPED
), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1686, __FUNCTION__))->typed.type)), (tcc_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1686, __FUNCTION__))->type_common.size_unit)
;
1687 tmp2 = TYPE_SIZE_UNIT (TREE_TYPE (dst))((tree_class_check ((((contains_struct_check ((dst), (TS_TYPED
), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1687, __FUNCTION__))->typed.type)), (tcc_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1687, __FUNCTION__))->type_common.size_unit)
;
1688 size = fold_build2_loc (input_location, MIN_EXPR,
1689 TREE_TYPE (tmp)((contains_struct_check ((tmp), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1689, __FUNCTION__))->typed.type)
, tmp, tmp2);
1690 tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
1691 tmp = build_call_expr_loc (input_location, tmp, 3,
1692 gfc_build_addr_expr (NULL_TREE(tree) __null, dst),
1693 gfc_build_addr_expr (NULL_TREE(tree) __null, src),
1694 fold_convert (size_type_node, size)fold_convert_loc (((location_t) 0), global_trees[TI_SIZE_TYPE
], size)
);
1695 gfc_add_expr_to_block (block, tmp);
1696
1697 /* Set the offset correctly. */
1698 for (n = 0; n < rank; n++)
1699 {
1700 dim = gfc_rank_cst[n];
1701 tmp = gfc_conv_descriptor_lbound_get (src, dim);
1702 tmp2 = gfc_conv_descriptor_stride_get (src, dim);
1703 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp)((contains_struct_check ((tmp), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1703, __FUNCTION__))->typed.type)
,
1704 tmp, tmp2);
1705 offset = fold_build2_loc (input_location, MINUS_EXPR,
1706 TREE_TYPE (offset)((contains_struct_check ((offset), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1706, __FUNCTION__))->typed.type)
, offset, tmp);
1707 offset = gfc_evaluate_now (offset, block);
1708 }
1709
1710 gfc_conv_descriptor_offset_set (block, dst, offset);
1711}
1712
1713
1714/* Do proper initialization for ASSOCIATE names. */
1715
1716static void
1717trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
1718{
1719 gfc_expr *e;
1720 tree tmp;
1721 bool class_target;
1722 bool unlimited;
1723 tree desc;
1724 tree offset;
1725 tree dim;
1726 int n;
1727 tree charlen;
1728 bool need_len_assign;
1729 bool whole_array = true;
1730 gfc_ref *ref;
1731 gfc_symbol *sym2;
1732
1733 gcc_assert (sym->assoc)((void)(!(sym->assoc) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1733, __FUNCTION__), 0 : 0))
;
1734 e = sym->assoc->target;
1735
1736 class_target = (e->expr_type == EXPR_VARIABLE)
1737 && (gfc_is_class_scalar_expr (e)
1738 || gfc_is_class_array_ref (e, NULL__null));
1739
1740 unlimited = UNLIMITED_POLY (e)(e != __null && e->ts.type == BT_CLASS && e
->ts.u.derived->components && e->ts.u.derived
->components->ts.u.derived && e->ts.u.derived
->components->ts.u.derived->attr.unlimited_polymorphic
)
;
1741
1742 for (ref = e->ref; ref; ref = ref->next)
1743 if (ref->type == REF_ARRAY
1744 && ref->u.ar.type == AR_FULL
1745 && ref->next)
1746 {
1747 whole_array = false;
1748 break;
1749 }
1750
1751 /* Assignments to the string length need to be generated, when
1752 ( sym is a char array or
1753 sym has a _len component)
1754 and the associated expression is unlimited polymorphic, which is
1755 not (yet) correctly in 'unlimited', because for an already associated
1756 BT_DERIVED the u-poly flag is not set, i.e.,
1757 __tmp_CHARACTER_0_1 => w => arg
1758 ^ generated temp ^ from code, the w does not have the u-poly
1759 flag set, where UNLIMITED_POLY(e) expects it. */
1760 need_len_assign = ((unlimited || (e->ts.type == BT_DERIVED
1761 && e->ts.u.derived->attr.unlimited_polymorphic))
1762 && (sym->ts.type == BT_CHARACTER
1763 || ((sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED)
1764 && class_has_len_component (sym)))
1765 && !sym->attr.select_rank_temporary);
1766
1767 /* Do a `pointer assignment' with updated descriptor (or assign descriptor
1768 to array temporary) for arrays with either unknown shape or if associating
1769 to a variable. Select rank temporaries need somewhat different treatment
1770 to other associate names and case temporaries. This because the selector
1771 is assumed rank and so the offset in particular has to be changed. Also,
1772 the case temporaries carry both allocatable and target attributes if
1773 present in the selector. This means that an allocatation or change of
1774 association can occur and so has to be dealt with. */
1775 if (sym->attr.select_rank_temporary)
1776 {
1777 gfc_se se;
1778 tree class_decl = NULL_TREE(tree) __null;
1779 int rank = 0;
1780 bool class_ptr;
1781
1782 sym2 = e->symtree->n.sym;
1783 gfc_init_se (&se, NULL__null);
1784 if (e->ts.type == BT_CLASS)
1785 {
1786 /* Go straight to the class data. */
1787 if (sym2->attr.dummy && !sym2->attr.optional)
1788 {
1789 class_decl = sym2->backend_decl;
1790 if (DECL_LANG_SPECIFIC (class_decl)((contains_struct_check ((class_decl), (TS_DECL_COMMON), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1790, __FUNCTION__))->decl_common.lang_specific)
1791 && GFC_DECL_SAVED_DESCRIPTOR (class_decl)(((contains_struct_check ((class_decl), (TS_DECL_COMMON), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1791, __FUNCTION__))->decl_common.lang_specific)->saved_descriptor
)
)
1792 class_decl = GFC_DECL_SAVED_DESCRIPTOR (class_decl)(((contains_struct_check ((class_decl), (TS_DECL_COMMON), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1792, __FUNCTION__))->decl_common.lang_specific)->saved_descriptor
)
;
1793 if (POINTER_TYPE_P (TREE_TYPE (class_decl))(((enum tree_code) (((contains_struct_check ((class_decl), (TS_TYPED
), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1793, __FUNCTION__))->typed.type))->base.code) == POINTER_TYPE
|| ((enum tree_code) (((contains_struct_check ((class_decl),
(TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1793, __FUNCTION__))->typed.type))->base.code) == REFERENCE_TYPE
)
)
1794 class_decl = build_fold_indirect_ref_loc (input_location,
1795 class_decl);
1796 gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (class_decl)))((void)(!(((tree_class_check ((((contains_struct_check ((class_decl
), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1796, __FUNCTION__))->typed.type)), (tcc_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1796, __FUNCTION__))->type_common.lang_flag_4)) ? fancy_abort
("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1796, __FUNCTION__), 0 : 0))
;
1797 se.expr = gfc_class_data_get (class_decl);
1798 }
1799 else
1800 {
1801 class_decl = sym2->backend_decl;
1802 gfc_conv_expr_descriptor (&se, e);
1803 if (POINTER_TYPE_P (TREE_TYPE (se.expr))(((enum tree_code) (((contains_struct_check ((se.expr), (TS_TYPED
), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1803, __FUNCTION__))->typed.type))->base.code) == POINTER_TYPE
|| ((enum tree_code) (((contains_struct_check ((se.expr), (TS_TYPED
), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1803, __FUNCTION__))->typed.type))->base.code) == REFERENCE_TYPE
)
)
1804 se.expr = build_fold_indirect_ref_loc (input_location,
1805 se.expr);
1806 }
1807
1808 if (CLASS_DATA (sym)sym->ts.u.derived->components->as && CLASS_DATA (sym)sym->ts.u.derived->components->as->rank > 0)
1809 rank = CLASS_DATA (sym)sym->ts.u.derived->components->as->rank;
1810 }
1811 else
1812 {
1813 gfc_conv_expr_descriptor (&se, e);
1814 if (sym->as && sym->as->rank > 0)
1815 rank = sym->as->rank;
1816 }
1817
1818 desc = sym->backend_decl;
1819
1820 /* The SELECT TYPE mechanisms turn class temporaries into pointers, which
1821 point to the selector. */
1822 class_ptr = class_decl != NULL_TREE(tree) __null && POINTER_TYPE_P (TREE_TYPE (desc))(((enum tree_code) (((contains_struct_check ((desc), (TS_TYPED
), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1822, __FUNCTION__))->typed.type))->base.code) == POINTER_TYPE
|| ((enum tree_code) (((contains_struct_check ((desc), (TS_TYPED
), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1822, __FUNCTION__))->typed.type))->base.code) == REFERENCE_TYPE
)
;
1823 if (class_ptr)
1824 {
1825 tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (desc))((contains_struct_check ((((contains_struct_check ((desc), (TS_TYPED
), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1825, __FUNCTION__))->typed.type)), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1825, __FUNCTION__))->typed.type)
, "class");
1826 tmp = gfc_build_addr_expr (NULL__null, tmp);
1827 gfc_add_modify (&se.pre, desc, tmp);
1828
1829 tmp = gfc_class_vptr_get (class_decl);
1830 gfc_add_modify (&se.pre, gfc_class_vptr_get (desc), tmp);
1831 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
)
)
1832 gfc_add_modify (&se.pre, gfc_class_len_get (desc),
1833 gfc_class_len_get (class_decl));
1834
1835 desc = gfc_class_data_get (desc);
1836 }
1837
1838 /* SELECT RANK temporaries can carry the allocatable and pointer
1839 attributes so the selector descriptor must be copied in and
1840 copied out. */
1841 if (rank > 0)
1842 copy_descriptor (&se.pre, desc, se.expr, rank);
1843 else
1844 {
1845 tmp = gfc_conv_descriptor_data_get (se.expr);
1846 gfc_add_modify (&se.pre, desc,
1847 fold_convert (TREE_TYPE (desc), tmp)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(desc), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1847, __FUNCTION__))->typed.type), tmp)
);
1848 }
1849
1850 /* Deal with associate_name => selector. Class associate names are
1851 treated in the same way as in SELECT TYPE. */
1852 sym2 = sym->assoc->target->symtree->n.sym;
1853 if (sym2->assoc && sym->assoc->target && sym2->ts.type != BT_CLASS)
1854 {
1855 sym2 = sym2->assoc->target->symtree->n.sym;
1856 se.expr = sym2->backend_decl;
1857
1858 if (POINTER_TYPE_P (TREE_TYPE (se.expr))(((enum tree_code) (((contains_struct_check ((se.expr), (TS_TYPED
), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1858, __FUNCTION__))->typed.type))->base.code) == POINTER_TYPE
|| ((enum tree_code) (((contains_struct_check ((se.expr), (TS_TYPED
), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1858, __FUNCTION__))->typed.type))->base.code) == REFERENCE_TYPE
)
)
1859 se.expr = build_fold_indirect_ref_loc (input_location,
1860 se.expr);
1861 }
1862
1863 /* There could have been reallocation. Copy descriptor back to the
1864 selector and update the offset. */
1865 if (sym->attr.allocatable || sym->attr.pointer
1866 || (sym->ts.type == BT_CLASS
1867 && (CLASS_DATA (sym)sym->ts.u.derived->components->attr.allocatable
1868 || CLASS_DATA (sym)sym->ts.u.derived->components->attr.pointer)))
1869 {
1870 if (rank > 0)
1871 copy_descriptor (&se.post, se.expr, desc, rank);
1872 else
1873 gfc_conv_descriptor_data_set (&se.post, se.expr, desc);
1874
1875 /* The dynamic type could have changed too. */
1876 if (sym->ts.type == BT_CLASS)
1877 {
1878 tmp = sym->backend_decl;
1879 if (class_ptr)
1880 tmp = build_fold_indirect_ref_loc (input_location, tmp);
1881 gfc_add_modify (&se.post, gfc_class_vptr_get (class_decl),
1882 gfc_class_vptr_get (tmp));
1883 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
)
)
1884 gfc_add_modify (&se.post, gfc_class_len_get (class_decl),
1885 gfc_class_len_get (tmp));
1886 }
1887 }
1888
1889 tmp = gfc_finish_block (&se.post);
1890
1891 gfc_add_init_cleanup (block, gfc_finish_block (&se.pre), tmp);
1892 }
1893 /* Now all the other kinds of associate variable. */
1894 else if (sym->attr.dimension && !class_target
1895 && (sym->as->type == AS_DEFERRED || sym->assoc->variable))
1896 {
1897 gfc_se se;
1898 tree desc;
1899 bool cst_array_ctor;
1900
1901 desc = sym->backend_decl;
1902 cst_array_ctor = e->expr_type == EXPR_ARRAY
1903 && gfc_constant_array_constructor_p (e->value.constructor)
1904 && e->ts.type != BT_CHARACTER;
1905
1906 /* If association is to an expression, evaluate it and create temporary.
1907 Otherwise, get descriptor of target for pointer assignment. */
1908 gfc_init_se (&se, NULL__null);
1909
1910 if (sym->assoc->variable || cst_array_ctor)
1911 {
1912 se.direct_byref = 1;
1913 se.use_offset = 1;
1914 se.expr = desc;
1915 GFC_DECL_PTR_ARRAY_P (sym->backend_decl)((contains_struct_check ((sym->backend_decl), (TS_DECL_COMMON
), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1915, __FUNCTION__))->decl_common.lang_flag_6)
= 1;
1916 }
1917
1918 gfc_conv_expr_descriptor (&se, e);
1919
1920 if (sym->ts.type == BT_CHARACTER
1921 && !se.direct_byref && sym->ts.deferred
1922 && !sym->attr.select_type_temporary
1923 && VAR_P (sym->ts.u.cl->backend_decl)(((enum tree_code) (sym->ts.u.cl->backend_decl)->base
.code) == VAR_DECL)
1924 && se.string_length != sym->ts.u.cl->backend_decl)
1925 {
1926 gfc_add_modify (&se.pre, sym->ts.u.cl->backend_decl,
1927 fold_convert (TREE_TYPE (sym->ts.u.cl->backend_decl),fold_convert_loc (((location_t) 0), ((contains_struct_check (
(sym->ts.u.cl->backend_decl), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1927, __FUNCTION__))->typed.type), se.string_length)
1928 se.string_length)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(sym->ts.u.cl->backend_decl), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1927, __FUNCTION__))->typed.type), se.string_length)
);
1929 }
1930
1931 /* If we didn't already do the pointer assignment, set associate-name
1932 descriptor to the one generated for the temporary. */
1933 if ((!sym->assoc->variable && !cst_array_ctor)
1934 || !whole_array)
1935 {
1936 int dim;
1937
1938 if (whole_array)
1939 gfc_add_modify (&se.pre, desc, se.expr);
1940
1941 /* The generated descriptor has lower bound zero (as array
1942 temporary), shift bounds so we get lower bounds of 1. */
1943 for (dim = 0; dim < e->rank; ++dim)
1944 gfc_conv_shift_descriptor_lbound (&se.pre, desc,
1945 dim, gfc_index_one_nodegfc_rank_cst[1]);
1946 }
1947
1948 /* If this is a subreference array pointer associate name use the
1949 associate variable element size for the value of 'span'. */
1950 if (sym->attr.subref_array_pointer && !se.direct_byref)
1951 {
1952 gcc_assert (e->expr_type == EXPR_VARIABLE)((void)(!(e->expr_type == EXPR_VARIABLE) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1952, __FUNCTION__), 0 : 0))
;
1953 tmp = gfc_get_array_span (se.expr, e);
1954
1955 gfc_conv_descriptor_span_set (&se.pre, desc, tmp);
1956 }
1957
1958 if (e->expr_type == EXPR_FUNCTION
1959 && sym->ts.type == BT_DERIVED
1960 && sym->ts.u.derived
1961 && sym->ts.u.derived->attr.pdt_type)
1962 {
1963 tmp = gfc_deallocate_pdt_comp (sym->ts.u.derived, se.expr,
1964 sym->as->rank);
1965 gfc_add_expr_to_block (&se.post, tmp);
1966 }
1967
1968 /* Done, register stuff as init / cleanup code. */
1969 gfc_add_init_cleanup (block, gfc_finish_block (&se.pre),
1970 gfc_finish_block (&se.post));
1971 }
1972
1973 /* Temporaries, arising from TYPE IS, just need the descriptor of class
1974 arrays to be assigned directly. */
1975 else if (class_target && sym->attr.dimension
1976 && (sym->ts.type == BT_DERIVED || unlimited))
1977 {
1978 gfc_se se;
1979
1980 gfc_init_se (&se, NULL__null);
1981 se.descriptor_only = 1;
1982 /* In a select type the (temporary) associate variable shall point to
1983 a standard fortran array (lower bound == 1), but conv_expr ()
1984 just maps to the input array in the class object, whose lbound may
1985 be arbitrary. conv_expr_descriptor solves this by inserting a
1986 temporary array descriptor. */
1987 gfc_conv_expr_descriptor (&se, e);
1988
1989 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))((void)(!(((tree_class_check ((((contains_struct_check ((se.expr
), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1989, __FUNCTION__))->typed.type)), (tcc_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1989, __FUNCTION__))->type_common.lang_flag_1) || ((tree_class_check
((((contains_struct_check ((se.expr), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1990, __FUNCTION__))->typed.type)), (tcc_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1990, __FUNCTION__))->type_common.lang_flag_2)) ? fancy_abort
("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1990, __FUNCTION__), 0 : 0))
1990 || GFC_ARRAY_TYPE_P (TREE_TYPE (se.expr)))((void)(!(((tree_class_check ((((contains_struct_check ((se.expr
), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1989, __FUNCTION__))->typed.type)), (tcc_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1989, __FUNCTION__))->type_common.lang_flag_1) || ((tree_class_check
((((contains_struct_check ((se.expr), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1990, __FUNCTION__))->typed.type)), (tcc_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1990, __FUNCTION__))->type_common.lang_flag_2)) ? fancy_abort
("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1990, __FUNCTION__), 0 : 0))
;
1991 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym->backend_decl)))((void)(!(((tree_class_check ((((contains_struct_check ((sym->
backend_decl), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1991, __FUNCTION__))->typed.type)), (tcc_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1991, __FUNCTION__))->type_common.lang_flag_1)) ? fancy_abort
("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1991, __FUNCTION__), 0 : 0))
;
1992
1993 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se.expr))((tree_class_check ((((contains_struct_check ((se.expr), (TS_TYPED
), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1993, __FUNCTION__))->typed.type)), (tcc_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1993, __FUNCTION__))->type_common.lang_flag_2)
)
1994 {
1995 if (INDIRECT_REF_P (se.expr)(((enum tree_code) (se.expr)->base.code) == INDIRECT_REF))
1996 tmp = TREE_OPERAND (se.expr, 0)(*((const_cast<tree*> (tree_operand_check ((se.expr), (
0), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 1996, __FUNCTION__)))))
;
1997 else
1998 tmp = se.expr;
1999
2000 gfc_add_modify (&se.pre, sym->backend_decl,
2001 gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (tmp)(((contains_struct_check ((tmp), (TS_DECL_COMMON), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2001, __FUNCTION__))->decl_common.lang_specific)->saved_descriptor
)
));
2002 }
2003 else
2004 gfc_add_modify (&se.pre, sym->backend_decl, se.expr);
2005
2006 if (unlimited)
2007 {
2008 /* Recover the dtype, which has been overwritten by the
2009 assignment from an unlimited polymorphic object. */
2010 tmp = gfc_conv_descriptor_dtype (sym->backend_decl);
2011 gfc_add_modify (&se.pre, tmp,
2012 gfc_get_dtype (TREE_TYPE (sym->backend_decl)((contains_struct_check ((sym->backend_decl), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2012, __FUNCTION__))->typed.type)
));
2013 }
2014
2015 gfc_add_init_cleanup (block, gfc_finish_block (&se.pre),
2016 gfc_finish_block (&se.post));
2017 }
2018
2019 /* Do a scalar pointer assignment; this is for scalar variable targets. */
2020 else if (gfc_is_associate_pointer (sym))
2021 {
2022 gfc_se se;
2023
2024 gcc_assert (!sym->attr.dimension)((void)(!(!sym->attr.dimension) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2024, __FUNCTION__), 0 : 0))
;
2025
2026 gfc_init_se (&se, NULL__null);
2027
2028 /* Class associate-names come this way because they are
2029 unconditionally associate pointers and the symbol is scalar. */
2030 if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)sym->ts.u.derived->components->attr.dimension)
2031 {
2032 tree target_expr;
2033 /* For a class array we need a descriptor for the selector. */
2034 gfc_conv_expr_descriptor (&se, e);
2035 /* Needed to get/set the _len component below. */
2036 target_expr = se.expr;
2037
2038 /* Obtain a temporary class container for the result. */
2039 gfc_conv_class_to_class (&se, e, sym->ts, false, true, false, false);
2040 se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
2041
2042 /* Set the offset. */
2043 desc = gfc_class_data_get (se.expr);
2044 offset = gfc_index_zero_nodegfc_rank_cst[0];
2045 for (n = 0; n < e->rank; n++)
2046 {
2047 dim = gfc_rank_cst[n];
2048 tmp = fold_build2_loc (input_location, MULT_EXPR,
2049 gfc_array_index_type,
2050 gfc_conv_descriptor_stride_get (desc, dim),
2051 gfc_conv_descriptor_lbound_get (desc, dim));
2052 offset = fold_build2_loc (input_location, MINUS_EXPR,
2053 gfc_array_index_type,
2054 offset, tmp);
2055 }
2056 if (need_len_assign)
2057 {
2058 if (e->symtree
2059 && DECL_LANG_SPECIFIC (e->symtree->n.sym->backend_decl)((contains_struct_check ((e->symtree->n.sym->backend_decl
), (TS_DECL_COMMON), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2059, __FUNCTION__))->decl_common.lang_specific)
2060 && GFC_DECL_SAVED_DESCRIPTOR (e->symtree->n.sym->backend_decl)(((contains_struct_check ((e->symtree->n.sym->backend_decl
), (TS_DECL_COMMON), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2060, __FUNCTION__))->decl_common.lang_specific)->saved_descriptor
)
2061 && TREE_CODE (target_expr)((enum tree_code) (target_expr)->base.code) != COMPONENT_REF)
2062 /* Use the original class descriptor stored in the saved
2063 descriptor to get the target_expr. */
2064 target_expr =
2065 GFC_DECL_SAVED_DESCRIPTOR (e->symtree->n.sym->backend_decl)(((contains_struct_check ((e->symtree->n.sym->backend_decl
), (TS_DECL_COMMON), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2065, __FUNCTION__))->decl_common.lang_specific)->saved_descriptor
)
;
2066 else
2067 /* Strip the _data component from the target_expr. */
2068 target_expr = TREE_OPERAND (target_expr, 0)(*((const_cast<tree*> (tree_operand_check ((target_expr
), (0), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2068, __FUNCTION__)))))
;
2069 /* Add a reference to the _len comp to the target expr. */
2070 tmp = gfc_class_len_get (target_expr);
2071 /* Get the component-ref for the temp structure's _len comp. */
2072 charlen = gfc_class_len_get (se.expr);
2073 /* Add the assign to the beginning of the block... */
2074 gfc_add_modify (&se.pre, charlen,
2075 fold_convert (TREE_TYPE (charlen), tmp)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(charlen), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2075, __FUNCTION__))->typed.type), tmp)
);
2076 /* and the oposite way at the end of the block, to hand changes
2077 on the string length back. */
2078 gfc_add_modify (&se.post, tmp,
2079 fold_convert (TREE_TYPE (tmp), charlen)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(tmp), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2079, __FUNCTION__))->typed.type), charlen)
);
2080 /* Length assignment done, prevent adding it again below. */
2081 need_len_assign = false;
2082 }
2083 gfc_conv_descriptor_offset_set (&se.pre, desc, offset);
2084 }
2085 else if (sym->ts.type == BT_CLASS && e->ts.type == BT_CLASS
2086 && CLASS_DATA (e)e->ts.u.derived->components->attr.dimension)
2087 {
2088 /* This is bound to be a class array element. */
2089 gfc_conv_expr_reference (&se, e);
2090 /* Get the _vptr component of the class object. */
2091 tmp = gfc_get_vptr_from_expr (se.expr);
2092 /* Obtain a temporary class container for the result. */
2093 gfc_conv_derived_to_class (&se, e, sym->ts, tmp, false, false);
2094 se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
2095 need_len_assign = false;
2096 }
2097 else
2098 {
2099 /* For BT_CLASS and BT_DERIVED, this boils down to a pointer assign,
2100 which has the string length included. For CHARACTERS it is still
2101 needed and will be done at the end of this routine. */
2102 gfc_conv_expr (&se, e);
2103 need_len_assign = need_len_assign && sym->ts.type == BT_CHARACTER;
2104 }
2105
2106 if (sym->ts.type == BT_CHARACTER
2107 && !sym->attr.select_type_temporary
2108 && VAR_P (sym->ts.u.cl->backend_decl)(((enum tree_code) (sym->ts.u.cl->backend_decl)->base
.code) == VAR_DECL)
2109 && se.string_length != sym->ts.u.cl->backend_decl)
2110 {
2111 gfc_add_modify (&se.pre, sym->ts.u.cl->backend_decl,
2112 fold_convert (TREE_TYPE (sym->ts.u.cl->backend_decl),fold_convert_loc (((location_t) 0), ((contains_struct_check (
(sym->ts.u.cl->backend_decl), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2112, __FUNCTION__))->typed.type), se.string_length)
2113 se.string_length)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(sym->ts.u.cl->backend_decl), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2112, __FUNCTION__))->typed.type), se.string_length)
);
2114 if (e->expr_type == EXPR_FUNCTION)
2115 {
2116 tmp = gfc_call_free (sym->backend_decl);
2117 gfc_add_expr_to_block (&se.post, tmp);
2118 }
2119 }
2120
2121 if (sym->ts.type == BT_CHARACTER && e->ts.type == BT_CHARACTER
2122 && POINTER_TYPE_P (TREE_TYPE (se.expr))(((enum tree_code) (((contains_struct_check ((se.expr), (TS_TYPED
), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2122, __FUNCTION__))->typed.type))->base.code) == POINTER_TYPE
|| ((enum tree_code) (((contains_struct_check ((se.expr), (TS_TYPED
), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2122, __FUNCTION__))->typed.type))->base.code) == REFERENCE_TYPE
)
)
2123 {
2124 /* These are pointer types already. */
2125 tmp = fold_convert (TREE_TYPE (sym->backend_decl), se.expr)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(sym->backend_decl), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2125, __FUNCTION__))->typed.type), se.expr)
;
2126 }
2127 else
2128 {
2129 tree ctree = gfc_get_class_from_expr (se.expr);
2130 tmp = TREE_TYPE (sym->backend_decl)((contains_struct_check ((sym->backend_decl), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2130, __FUNCTION__))->typed.type)
;
2131
2132 /* Coarray scalar component expressions can emerge from
2133 the front end as array elements of the _data field. */
2134 if (sym->ts.type == BT_CLASS
2135 && e->ts.type == BT_CLASS && e->rank == 0
2136 && !GFC_CLASS_TYPE_P (TREE_TYPE (se.expr))((tree_class_check ((((contains_struct_check ((se.expr), (TS_TYPED
), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2136, __FUNCTION__))->typed.type)), (tcc_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2136, __FUNCTION__))->type_common.lang_flag_4)
&& ctree)
2137 {
2138 tree stmp;
2139 tree dtmp;
2140
2141 se.expr = ctree;
2142 dtmp = TREE_TYPE (TREE_TYPE (sym->backend_decl))((contains_struct_check ((((contains_struct_check ((sym->backend_decl
), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2142, __FUNCTION__))->typed.type)), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2142, __FUNCTION__))->typed.type)
;
2143 ctree = gfc_create_var (dtmp, "class");
2144
2145 stmp = gfc_class_data_get (se.expr);
2146 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (stmp)))((void)(!(((tree_class_check ((((contains_struct_check ((stmp
), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2146, __FUNCTION__))->typed.type)), (tcc_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2146, __FUNCTION__))->type_common.lang_flag_1)) ? fancy_abort
("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2146, __FUNCTION__), 0 : 0))
;
2147
2148 /* Set the fields of the target class variable. */
2149 stmp = gfc_conv_descriptor_data_get (stmp);
2150 dtmp = gfc_class_data_get (ctree);
2151 stmp = fold_convert (TREE_TYPE (dtmp), stmp)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(dtmp), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2151, __FUNCTION__))->typed.type), stmp)
;
2152 gfc_add_modify (&se.pre, dtmp, stmp);
2153 stmp = gfc_class_vptr_get (se.expr);
2154 dtmp = gfc_class_vptr_get (ctree);
2155 stmp = fold_convert (TREE_TYPE (dtmp), stmp)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(dtmp), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2155, __FUNCTION__))->typed.type), stmp)
;
2156 gfc_add_modify (&se.pre, dtmp, stmp);
2157 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
)
)
2158 {
2159 stmp = gfc_class_len_get (se.expr);
2160 dtmp = gfc_class_len_get (ctree);
2161 stmp = fold_convert (TREE_TYPE (dtmp), stmp)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(dtmp), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2161, __FUNCTION__))->typed.type), stmp)
;
2162 gfc_add_modify (&se.pre, dtmp, stmp);
2163 }
2164 se.expr = ctree;
2165 }
2166 tmp = gfc_build_addr_expr (tmp, se.expr);
2167 }
2168
2169 gfc_add_modify (&se.pre, sym->backend_decl, tmp);
2170
2171 gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
2172 gfc_finish_block (&se.post));
2173 }
2174
2175 /* Do a simple assignment. This is for scalar expressions, where we
2176 can simply use expression assignment. */
2177 else
2178 {
2179 gfc_expr *lhs;
2180 tree res;
2181 gfc_se se;
2182
2183 gfc_init_se (&se, NULL__null);
2184
2185 /* resolve.c converts some associate names to allocatable so that
2186 allocation can take place automatically in gfc_trans_assignment.
2187 The frontend prevents them from being either allocated,
2188 deallocated or reallocated. */
2189 if (sym->attr.allocatable)
2190 {
2191 tmp = sym->backend_decl;
2192 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp))((tree_class_check ((((contains_struct_check ((tmp), (TS_TYPED
), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2192, __FUNCTION__))->typed.type)), (tcc_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2192, __FUNCTION__))->type_common.lang_flag_1)
)
2193 tmp = gfc_conv_descriptor_data_get (tmp);
2194 gfc_add_modify (&se.pre, tmp, fold_convert (TREE_TYPE (tmp),fold_convert_loc (((location_t) 0), ((contains_struct_check (
(tmp), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2194, __FUNCTION__))->typed.type), global_trees[TI_NULL_POINTER
])
2195 null_pointer_node)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(tmp), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2194, __FUNCTION__))->typed.type), global_trees[TI_NULL_POINTER
])
);
2196 }
2197
2198 lhs = gfc_lval_expr_from_sym (sym);
2199 res = gfc_trans_assignment (lhs, e, false, true);
2200 gfc_add_expr_to_block (&se.pre, res);
2201
2202 tmp = sym->backend_decl;
2203 if (e->expr_type == EXPR_FUNCTION
2204 && sym->ts.type == BT_DERIVED
2205 && sym->ts.u.derived
2206 && sym->ts.u.derived->attr.pdt_type)
2207 {
2208 tmp = gfc_deallocate_pdt_comp (sym->ts.u.derived, tmp,
2209 0);
2210 }
2211 else if (e->expr_type == EXPR_FUNCTION
2212 && sym->ts.type == BT_CLASS
2213 && CLASS_DATA (sym)sym->ts.u.derived->components->ts.u.derived
2214 && CLASS_DATA (sym)sym->ts.u.derived->components->ts.u.derived->attr.pdt_type)
2215 {
2216 tmp = gfc_class_data_get (tmp);
2217 tmp = gfc_deallocate_pdt_comp (CLASS_DATA (sym)sym->ts.u.derived->components->ts.u.derived,
2218 tmp, 0);
2219 }
2220 else if (sym->attr.allocatable)
2221 {
2222 tmp = sym->backend_decl;
2223
2224 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp))((tree_class_check ((((contains_struct_check ((tmp), (TS_TYPED
), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2224, __FUNCTION__))->typed.type)), (tcc_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2224, __FUNCTION__))->type_common.lang_flag_1)
)
2225 tmp = gfc_conv_descriptor_data_get (tmp);
2226
2227 /* A simple call to free suffices here. */
2228 tmp = gfc_call_free (tmp);
2229
2230 /* Make sure that reallocation on assignment cannot occur. */
2231 sym->attr.allocatable = 0;
2232 }
2233 else
2234 tmp = NULL_TREE(tree) __null;
2235
2236 res = gfc_finish_block (&se.pre);
2237 gfc_add_init_cleanup (block, res, tmp);
2238 gfc_free_expr (lhs);
2239 }
2240
2241 /* Set the stringlength, when needed. */
2242 if (need_len_assign)
2243 {
2244 gfc_se se;
2245 gfc_init_se (&se, NULL__null);
2246 if (e->symtree->n.sym->ts.type == BT_CHARACTER)
2247 {
2248 /* Deferred strings are dealt with in the preceeding. */
2249 gcc_assert (!e->symtree->n.sym->ts.deferred)((void)(!(!e->symtree->n.sym->ts.deferred) ? fancy_abort
("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2249, __FUNCTION__), 0 : 0))
;
2250 tmp = e->symtree->n.sym->ts.u.cl->backend_decl;
2251 }
2252 else if (e->symtree->n.sym->attr.function
2253 && e->symtree->n.sym == e->symtree->n.sym->result)
2254 {
2255 tmp = gfc_get_fake_result_decl (e->symtree->n.sym, 0);
2256 tmp = gfc_class_len_get (tmp);
2257 }
2258 else
2259 tmp = gfc_class_len_get (gfc_get_symbol_decl (e->symtree->n.sym));
2260 gfc_get_symbol_decl (sym);
2261 charlen = sym->ts.type == BT_CHARACTER ? sym->ts.u.cl->backend_decl
2262 : gfc_class_len_get (sym->backend_decl);
2263 /* Prevent adding a noop len= len. */
2264 if (tmp != charlen)
2265 {
2266 gfc_add_modify (&se.pre, charlen,
2267 fold_convert (TREE_TYPE (charlen), tmp)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(charlen), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2267, __FUNCTION__))->typed.type), tmp)
);
2268 gfc_add_init_cleanup (block, gfc_finish_block (&se.pre),
2269 gfc_finish_block (&se.post));
2270 }
2271 }
2272}
2273
2274
2275/* Translate a BLOCK construct. This is basically what we would do for a
2276 procedure body. */
2277
2278tree
2279gfc_trans_block_construct (gfc_code* code)
2280{
2281 gfc_namespace* ns;
2282 gfc_symbol* sym;
2283 gfc_wrapped_block block;
2284 tree exit_label;
2285 stmtblock_t body;
2286 gfc_association_list *ass;
2287
2288 ns = code->ext.block.ns;
2289 gcc_assert (ns)((void)(!(ns) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2289, __FUNCTION__), 0 : 0))
;
2290 sym = ns->proc_name;
2291 gcc_assert (sym)((void)(!(sym) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2291, __FUNCTION__), 0 : 0))
;
2292
2293 /* Process local variables. */
2294 gcc_assert (!sym->tlink)((void)(!(!sym->tlink) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2294, __FUNCTION__), 0 : 0))
;
2295 sym->tlink = sym;
2296 gfc_process_block_locals (ns);
2297
2298 /* Generate code including exit-label. */
2299 gfc_init_block (&body);
2300 exit_label = gfc_build_label_decl (NULL_TREE(tree) __null);
2301 code->exit_label = exit_label;
2302
2303 finish_oacc_declare (ns, sym, true);
2304
2305 gfc_add_expr_to_block (&body, gfc_trans_code (ns->code));
2306 gfc_add_expr_to_block (&body, build1_v (LABEL_EXPR, exit_label)fold_build1_loc (input_location, LABEL_EXPR, global_trees[TI_VOID_TYPE
], exit_label)
);
2307
2308 /* Finish everything. */
2309 gfc_start_wrapped_block (&block, gfc_finish_block (&body));
2310 gfc_trans_deferred_vars (sym, &block);
2311 for (ass = code->ext.block.assoc; ass; ass = ass->next)
2312 trans_associate_var (ass->st->n.sym, &block);
2313
2314 return gfc_finish_wrapped_block (&block);
2315}
2316
2317/* Translate the simple DO construct in a C-style manner.
2318 This is where the loop variable has integer type and step +-1.
2319 Following code will generate infinite loop in case where TO is INT_MAX
2320 (for +1 step) or INT_MIN (for -1 step)
2321
2322 We translate a do loop from:
2323
2324 DO dovar = from, to, step
2325 body
2326 END DO
2327
2328 to:
2329
2330 [Evaluate loop bounds and step]
2331 dovar = from;
2332 for (;;)
2333 {
2334 if (dovar > to)
2335 goto end_label;
2336 body;
2337 cycle_label:
2338 dovar += step;
2339 }
2340 end_label:
2341
2342 This helps the optimizers by avoiding the extra pre-header condition and
2343 we save a register as we just compare the updated IV (not a value in
2344 previous step). */
2345
2346static tree
2347gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar,
2348 tree from, tree to, tree step, tree exit_cond)
2349{
2350 stmtblock_t body;
2351 tree type;
2352 tree cond;
2353 tree tmp;
2354 tree saved_dovar = NULL__null;
2355 tree cycle_label;
2356 tree exit_label;
2357 location_t loc;
2358 type = TREE_TYPE (dovar)((contains_struct_check ((dovar), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2358, __FUNCTION__))->typed.type)
;
2359 bool is_step_positive = tree_int_cst_sgn (step) > 0;
2360
2361 loc = gfc_get_location (&code->ext.iterator->start->where);
2362
2363 /* Initialize the DO variable: dovar = from. */
2364 gfc_add_modify_loc (loc, pblock, dovar,
2365 fold_convert (TREE_TYPE (dovar), from)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(dovar), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2365, __FUNCTION__))->typed.type), from)
);
2366
2367 /* Save value for do-tinkering checking. */
2368 if (gfc_option.rtcheck & GFC_RTCHECK_DO(1<<3))
2369 {
2370 saved_dovar = gfc_create_var (type, ".saved_dovar");
2371 gfc_add_modify_loc (loc, pblock, saved_dovar, dovar);
2372 }
2373
2374 /* Cycle and exit statements are implemented with gotos. */
2375 cycle_label = gfc_build_label_decl (NULL_TREE(tree) __null);
2376 exit_label = gfc_build_label_decl (NULL_TREE(tree) __null);
2377
2378 /* Put the labels where they can be found later. See gfc_trans_do(). */
2379 code->cycle_label = cycle_label;
2380 code->exit_label = exit_label;
2381
2382 /* Loop body. */
2383 gfc_start_block (&body);
2384
2385 /* Exit the loop if there is an I/O result condition or error. */
2386 if (exit_cond)
2387 {
2388 tmp = build1_v (GOTO_EXPR, exit_label)fold_build1_loc (input_location, GOTO_EXPR, global_trees[TI_VOID_TYPE
], exit_label)
;
2389 tmp = fold_build3_loc (loc, COND_EXPR, void_type_nodeglobal_trees[TI_VOID_TYPE],
2390 exit_cond, tmp,
2391 build_empty_stmt (loc));
2392 gfc_add_expr_to_block (&body, tmp);
2393 }
2394
2395 /* Evaluate the loop condition. */
2396 if (is_step_positive)
2397 cond = fold_build2_loc (loc, GT_EXPR, logical_type_node, dovar,
2398 fold_convert (type, to)fold_convert_loc (((location_t) 0), type, to));
2399 else
2400 cond = fold_build2_loc (loc, LT_EXPR, logical_type_node, dovar,
2401 fold_convert (type, to)fold_convert_loc (((location_t) 0), type, to));
2402
2403 cond = gfc_evaluate_now_loc (loc, cond, &body);
2404 if (code->ext.iterator->unroll && cond != error_mark_nodeglobal_trees[TI_ERROR_MARK])
2405 cond
2406 = build3 (ANNOTATE_EXPR, TREE_TYPE (cond)((contains_struct_check ((cond), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2406, __FUNCTION__))->typed.type)
, cond,
2407 build_int_cst (integer_type_nodeinteger_types[itk_int], annot_expr_unroll_kind),
2408 build_int_cst (integer_type_nodeinteger_types[itk_int], code->ext.iterator->unroll));
2409
2410 if (code->ext.iterator->ivdep && cond != error_mark_nodeglobal_trees[TI_ERROR_MARK])
2411 cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond)((contains_struct_check ((cond), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2411, __FUNCTION__))->typed.type)
, cond,
2412 build_int_cst (integer_type_nodeinteger_types[itk_int], annot_expr_ivdep_kind),
2413 integer_zero_nodeglobal_trees[TI_INTEGER_ZERO]);
2414 if (code->ext.iterator->vector && cond != error_mark_nodeglobal_trees[TI_ERROR_MARK])
2415 cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond)((contains_struct_check ((cond), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2415, __FUNCTION__))->typed.type)
, cond,
2416 build_int_cst (integer_type_nodeinteger_types[itk_int], annot_expr_vector_kind),
2417 integer_zero_nodeglobal_trees[TI_INTEGER_ZERO]);
2418 if (code->ext.iterator->novector && cond != error_mark_nodeglobal_trees[TI_ERROR_MARK])
2419 cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond)((contains_struct_check ((cond), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2419, __FUNCTION__))->typed.type)
, cond,
2420 build_int_cst (integer_type_nodeinteger_types[itk_int], annot_expr_no_vector_kind),
2421 integer_zero_nodeglobal_trees[TI_INTEGER_ZERO]);
2422
2423 /* The loop exit. */
2424 tmp = fold_build1_loc (loc, GOTO_EXPR, void_type_nodeglobal_trees[TI_VOID_TYPE], exit_label);
2425 TREE_USED (exit_label)((exit_label)->base.used_flag) = 1;
2426 tmp = fold_build3_loc (loc, COND_EXPR, void_type_nodeglobal_trees[TI_VOID_TYPE],
2427 cond, tmp, build_empty_stmt (loc));
2428 gfc_add_expr_to_block (&body, tmp);
2429
2430 /* Check whether the induction variable is equal to INT_MAX
2431 (respectively to INT_MIN). */
2432 if (gfc_option.rtcheck & GFC_RTCHECK_DO(1<<3))
2433 {
2434 tree boundary = is_step_positive ? TYPE_MAX_VALUE (type)((tree_check5 ((type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2434, __FUNCTION__, (INTEGER_TYPE), (ENUMERAL_TYPE), (BOOLEAN_TYPE
), (REAL_TYPE), (FIXED_POINT_TYPE)))->type_non_common.maxval
)
2435 : TYPE_MIN_VALUE (type)((tree_check5 ((type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2435, __FUNCTION__, (INTEGER_TYPE), (ENUMERAL_TYPE), (BOOLEAN_TYPE
), (REAL_TYPE), (FIXED_POINT_TYPE)))->type_non_common.minval
)
;
2436
2437 tmp = fold_build2_loc (loc, EQ_EXPR, logical_type_node,
2438 dovar, boundary);
2439 gfc_trans_runtime_check (true, false, tmp, &body, &code->loc,
2440 "Loop iterates infinitely");
2441 }
2442
2443 /* Main loop body. */
2444 tmp = gfc_trans_code_cond (code->block->next, exit_cond);
2445 gfc_add_expr_to_block (&body, tmp);
2446
2447 /* Label for cycle statements (if needed). */
2448 if (TREE_USED (cycle_label)((cycle_label)->base.used_flag))
2449 {
2450 tmp = build1_v (LABEL_EXPR, cycle_label)fold_build1_loc (input_location, LABEL_EXPR, global_trees[TI_VOID_TYPE
], cycle_label)
;
2451 gfc_add_expr_to_block (&body, tmp);
2452 }
2453
2454 /* Check whether someone has modified the loop variable. */
2455 if (gfc_option.rtcheck & GFC_RTCHECK_DO(1<<3))
2456 {
2457 tmp = fold_build2_loc (loc, NE_EXPR, logical_type_node,
2458 dovar, saved_dovar);
2459 gfc_trans_runtime_check (true, false, tmp, &body, &code->loc,
2460 "Loop variable has been modified");
2461 }
2462
2463 /* Increment the loop variable. */
2464 tmp = fold_build2_loc (loc, PLUS_EXPR, type, dovar, step);
2465 gfc_add_modify_loc (loc, &body, dovar, tmp);
2466
2467 if (gfc_option.rtcheck & GFC_RTCHECK_DO(1<<3))
2468 gfc_add_modify_loc (loc, &body, saved_dovar, dovar);
2469
2470 /* Finish the loop body. */
2471 tmp = gfc_finish_block (&body);
2472 tmp = fold_build1_loc (loc, LOOP_EXPR, void_type_nodeglobal_trees[TI_VOID_TYPE], tmp);
2473
2474 gfc_add_expr_to_block (pblock, tmp);
2475
2476 /* Add the exit label. */
2477 tmp = build1_v (LABEL_EXPR, exit_label)fold_build1_loc (input_location, LABEL_EXPR, global_trees[TI_VOID_TYPE
], exit_label)
;
2478 gfc_add_expr_to_block (pblock, tmp);
2479
2480 return gfc_finish_block (pblock);
2481}
2482
2483/* Translate the DO construct. This obviously is one of the most
2484 important ones to get right with any compiler, but especially
2485 so for Fortran.
2486
2487 We special case some loop forms as described in gfc_trans_simple_do.
2488 For other cases we implement them with a separate loop count,
2489 as described in the standard.
2490
2491 We translate a do loop from:
2492
2493 DO dovar = from, to, step
2494 body
2495 END DO
2496
2497 to:
2498
2499 [evaluate loop bounds and step]
2500 empty = (step > 0 ? to < from : to > from);
2501 countm1 = (to - from) / step;
2502 dovar = from;
2503 if (empty) goto exit_label;
2504 for (;;)
2505 {
2506 body;
2507cycle_label:
2508 dovar += step
2509 countm1t = countm1;
2510 countm1--;
2511 if (countm1t == 0) goto exit_label;
2512 }
2513exit_label:
2514
2515 countm1 is an unsigned integer. It is equal to the loop count minus one,
2516 because the loop count itself can overflow. */
2517
2518tree
2519gfc_trans_do (gfc_code * code, tree exit_cond)
2520{
2521 gfc_se se;
2522 tree dovar;
2523 tree saved_dovar = NULL__null;
2524 tree from;
2525 tree to;
2526 tree step;
2527 tree countm1;
2528 tree type;
2529 tree utype;
2530 tree cond;
2531 tree cycle_label;
2532 tree exit_label;
2533 tree tmp;
2534 stmtblock_t block;
2535 stmtblock_t body;
2536 location_t loc;
2537
2538 gfc_start_block (&block);
2539
2540 loc = gfc_get_location (&code->ext.iterator->start->where);
2541
2542 /* Evaluate all the expressions in the iterator. */
2543 gfc_init_se (&se, NULL__null);
2544 gfc_conv_expr_lhs (&se, code->ext.iterator->var);
2545 gfc_add_block_to_block (&block, &se.pre);
2546 dovar = se.expr;
2547 type = TREE_TYPE (dovar)((contains_struct_check ((dovar), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2547, __FUNCTION__))->typed.type)
;
2548
2549 gfc_init_se (&se, NULL__null);
2550 gfc_conv_expr_val (&se, code->ext.iterator->start);
2551 gfc_add_block_to_block (&block, &se.pre);
2552 from = gfc_evaluate_now (se.expr, &block);
2553
2554 gfc_init_se (&se, NULL__null);
2555 gfc_conv_expr_val (&se, code->ext.iterator->end);
2556 gfc_add_block_to_block (&block, &se.pre);
2557 to = gfc_evaluate_now (se.expr, &block);
2558
2559 gfc_init_se (&se, NULL__null);
2560 gfc_conv_expr_val (&se, code->ext.iterator->step);
2561 gfc_add_block_to_block (&block, &se.pre);
2562 step = gfc_evaluate_now (se.expr, &block);
2563
2564 if (gfc_option.rtcheck & GFC_RTCHECK_DO(1<<3))
2565 {
2566 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, step,
2567 build_zero_cst (type));
2568 gfc_trans_runtime_check (true, false, tmp, &block, &code->loc,
2569 "DO step value is zero");
2570 }
2571
2572 /* Special case simple loops. */
2573 if (TREE_CODE (type)((enum tree_code) (type)->base.code) == INTEGER_TYPE
2574 && (integer_onep (step)
2575 || tree_int_cst_equal (step, integer_minus_one_nodeglobal_trees[TI_INTEGER_MINUS_ONE])))
2576 return gfc_trans_simple_do (code, &block, dovar, from, to, step,
2577 exit_cond);
2578
2579 if (TREE_CODE (type)((enum tree_code) (type)->base.code) == INTEGER_TYPE)
2580 utype = unsigned_type_for (type);
2581 else
2582 utype = unsigned_type_for (gfc_array_index_type);
2583 countm1 = gfc_create_var (utype, "countm1");
2584
2585 /* Cycle and exit statements are implemented with gotos. */
2586 cycle_label = gfc_build_label_decl (NULL_TREE(tree) __null);
2587 exit_label = gfc_build_label_decl (NULL_TREE(tree) __null);
2588 TREE_USED (exit_label)((exit_label)->base.used_flag) = 1;
2589
2590 /* Put these labels where they can be found later. */
2591 code->cycle_label = cycle_label;
2592 code->exit_label = exit_label;
2593
2594 /* Initialize the DO variable: dovar = from. */
2595 gfc_add_modify (&block, dovar, from);
2596
2597 /* Save value for do-tinkering checking. */
2598 if (gfc_option.rtcheck & GFC_RTCHECK_DO(1<<3))
2599 {
2600 saved_dovar = gfc_create_var (type, ".saved_dovar");
2601 gfc_add_modify_loc (loc, &block, saved_dovar, dovar);
2602 }
2603
2604 /* Initialize loop count and jump to exit label if the loop is empty.
2605 This code is executed before we enter the loop body. We generate:
2606 if (step > 0)
2607 {
2608 countm1 = (to - from) / step;
2609 if (to < from)
2610 goto exit_label;
2611 }
2612 else
2613 {
2614 countm1 = (from - to) / -step;
2615 if (to > from)
2616 goto exit_label;
2617 }
2618 */
2619
2620 if (TREE_CODE (type)((enum tree_code) (type)->base.code) == INTEGER_TYPE)
2621 {
2622 tree pos, neg, tou, fromu, stepu, tmp2;
2623
2624 /* The distance from FROM to TO cannot always be represented in a signed
2625 type, thus use unsigned arithmetic, also to avoid any undefined
2626 overflow issues. */
2627 tou = fold_convert (utype, to)fold_convert_loc (((location_t) 0), utype, to);
2628 fromu = fold_convert (utype, from)fold_convert_loc (((location_t) 0), utype, from);
2629 stepu = fold_convert (utype, step)fold_convert_loc (((location_t) 0), utype, step);
2630
2631 /* For a positive step, when to < from, exit, otherwise compute
2632 countm1 = ((unsigned)to - (unsigned)from) / (unsigned)step */
2633 tmp = fold_build2_loc (loc, LT_EXPR, logical_type_node, to, from);
2634 tmp2 = fold_build2_loc (loc, TRUNC_DIV_EXPR, utype,
2635 fold_build2_loc (loc, MINUS_EXPR, utype,
2636 tou, fromu),
2637 stepu);
2638 pos = build2 (COMPOUND_EXPR, void_type_nodeglobal_trees[TI_VOID_TYPE],
2639 fold_build2 (MODIFY_EXPR, void_type_node,fold_build2_loc (((location_t) 0), MODIFY_EXPR, global_trees[
TI_VOID_TYPE], countm1, tmp2 )
2640 countm1, tmp2)fold_build2_loc (((location_t) 0), MODIFY_EXPR, global_trees[
TI_VOID_TYPE], countm1, tmp2 )
,
2641 build3_loc (loc, COND_EXPR, void_type_nodeglobal_trees[TI_VOID_TYPE],
2642 gfc_unlikely (tmp, PRED_FORTRAN_LOOP_PREHEADER),
2643 build1_loc (loc, GOTO_EXPR, void_type_nodeglobal_trees[TI_VOID_TYPE],
2644 exit_label), NULL_TREE(tree) __null));
2645
2646 /* For a negative step, when to > from, exit, otherwise compute
2647 countm1 = ((unsigned)from - (unsigned)to) / -(unsigned)step */
2648 tmp = fold_build2_loc (loc, GT_EXPR, logical_type_node, to, from);
2649 tmp2 = fold_build2_loc (loc, TRUNC_DIV_EXPR, utype,
2650 fold_build2_loc (loc, MINUS_EXPR, utype,
2651 fromu, tou),
2652 fold_build1_loc (loc, NEGATE_EXPR, utype, stepu));
2653 neg = build2 (COMPOUND_EXPR, void_type_nodeglobal_trees[TI_VOID_TYPE],
2654 fold_build2 (MODIFY_EXPR, void_type_node,fold_build2_loc (((location_t) 0), MODIFY_EXPR, global_trees[
TI_VOID_TYPE], countm1, tmp2 )
2655 countm1, tmp2)fold_build2_loc (((location_t) 0), MODIFY_EXPR, global_trees[
TI_VOID_TYPE], countm1, tmp2 )
,
2656 build3_loc (loc, COND_EXPR, void_type_nodeglobal_trees[TI_VOID_TYPE],
2657 gfc_unlikely (tmp, PRED_FORTRAN_LOOP_PREHEADER),
2658 build1_loc (loc, GOTO_EXPR, void_type_nodeglobal_trees[TI_VOID_TYPE],
2659 exit_label), NULL_TREE(tree) __null));
2660
2661 tmp = fold_build2_loc (loc, LT_EXPR, logical_type_node, step,
2662 build_int_cst (TREE_TYPE (step)((contains_struct_check ((step), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2662, __FUNCTION__))->typed.type)
, 0));
2663 tmp = fold_build3_loc (loc, COND_EXPR, void_type_nodeglobal_trees[TI_VOID_TYPE], tmp, neg, pos);
2664
2665 gfc_add_expr_to_block (&block, tmp);
2666 }
2667 else
2668 {
2669 tree pos_step;
2670
2671 /* TODO: We could use the same width as the real type.
2672 This would probably cause more problems that it solves
2673 when we implement "long double" types. */
2674
2675 tmp = fold_build2_loc (loc, MINUS_EXPR, type, to, from);
2676 tmp = fold_build2_loc (loc, RDIV_EXPR, type, tmp, step);
2677 tmp = fold_build1_loc (loc, FIX_TRUNC_EXPR, utype, tmp);
2678 gfc_add_modify (&block, countm1, tmp);
2679
2680 /* We need a special check for empty loops:
2681 empty = (step > 0 ? to < from : to > from); */
2682 pos_step = fold_build2_loc (loc, GT_EXPR, logical_type_node, step,
2683 build_zero_cst (type));
2684 tmp = fold_build3_loc (loc, COND_EXPR, logical_type_node, pos_step,
2685 fold_build2_loc (loc, LT_EXPR,
2686 logical_type_node, to, from),
2687 fold_build2_loc (loc, GT_EXPR,
2688 logical_type_node, to, from));
2689 /* If the loop is empty, go directly to the exit label. */
2690 tmp = fold_build3_loc (loc, COND_EXPR, void_type_nodeglobal_trees[TI_VOID_TYPE], tmp,
2691 build1_v (GOTO_EXPR, exit_label)fold_build1_loc (input_location, GOTO_EXPR, global_trees[TI_VOID_TYPE
], exit_label)
,
2692 build_empty_stmt (input_location));
2693 gfc_add_expr_to_block (&block, tmp);
2694 }
2695
2696 /* Loop body. */
2697 gfc_start_block (&body);
2698
2699 /* Main loop body. */
2700 tmp = gfc_trans_code_cond (code->block->next, exit_cond);
2701 gfc_add_expr_to_block (&body, tmp);
2702
2703 /* Label for cycle statements (if needed). */
2704 if (TREE_USED (cycle_label)((cycle_label)->base.used_flag))
2705 {
2706 tmp = build1_v (LABEL_EXPR, cycle_label)fold_build1_loc (input_location, LABEL_EXPR, global_trees[TI_VOID_TYPE
], cycle_label)
;
2707 gfc_add_expr_to_block (&body, tmp);
2708 }
2709
2710 /* Check whether someone has modified the loop variable. */
2711 if (gfc_option.rtcheck & GFC_RTCHECK_DO(1<<3))
2712 {
2713 tmp = fold_build2_loc (loc, NE_EXPR, logical_type_node, dovar,
2714 saved_dovar);
2715 gfc_trans_runtime_check (true, false, tmp, &body, &code->loc,
2716 "Loop variable has been modified");
2717 }
2718
2719 /* Exit the loop if there is an I/O result condition or error. */
2720 if (exit_cond)
2721 {
2722 tmp = build1_v (GOTO_EXPR, exit_label)fold_build1_loc (input_location, GOTO_EXPR, global_trees[TI_VOID_TYPE
], exit_label)
;
2723 tmp = fold_build3_loc (loc, COND_EXPR, void_type_nodeglobal_trees[TI_VOID_TYPE],
2724 exit_cond, tmp,
2725 build_empty_stmt (input_location));
2726 gfc_add_expr_to_block (&body, tmp);
2727 }
2728
2729 /* Increment the loop variable. */
2730 tmp = fold_build2_loc (loc, PLUS_EXPR, type, dovar, step);
2731 gfc_add_modify_loc (loc, &body, dovar, tmp);
2732
2733 if (gfc_option.rtcheck & GFC_RTCHECK_DO(1<<3))
2734 gfc_add_modify_loc (loc, &body, saved_dovar, dovar);
2735
2736 /* Initialize countm1t. */
2737 tree countm1t = gfc_create_var (utype, "countm1t");
2738 gfc_add_modify_loc (loc, &body, countm1t, countm1);
2739
2740 /* Decrement the loop count. */
2741 tmp = fold_build2_loc (loc, MINUS_EXPR, utype, countm1,
2742 build_int_cst (utype, 1));
2743 gfc_add_modify_loc (loc, &body, countm1, tmp);
2744
2745 /* End with the loop condition. Loop until countm1t == 0. */
2746 cond = fold_build2_loc (loc, EQ_EXPR, logical_type_node, countm1t,
2747 build_int_cst (utype, 0));
2748 if (code->ext.iterator->unroll && cond != error_mark_nodeglobal_trees[TI_ERROR_MARK])
2749 cond
2750 = build3 (ANNOTATE_EXPR, TREE_TYPE (cond)((contains_struct_check ((cond), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2750, __FUNCTION__))->typed.type)
, cond,
2751 build_int_cst (integer_type_nodeinteger_types[itk_int], annot_expr_unroll_kind),
2752 build_int_cst (integer_type_nodeinteger_types[itk_int], code->ext.iterator->unroll));
2753
2754 if (code->ext.iterator->ivdep && cond != error_mark_nodeglobal_trees[TI_ERROR_MARK])
2755 cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond)((contains_struct_check ((cond), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2755, __FUNCTION__))->typed.type)
, cond,
2756 build_int_cst (integer_type_nodeinteger_types[itk_int], annot_expr_ivdep_kind),
2757 integer_zero_nodeglobal_trees[TI_INTEGER_ZERO]);
2758 if (code->ext.iterator->vector && cond != error_mark_nodeglobal_trees[TI_ERROR_MARK])
2759 cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond)((contains_struct_check ((cond), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2759, __FUNCTION__))->typed.type)
, cond,
2760 build_int_cst (integer_type_nodeinteger_types[itk_int], annot_expr_vector_kind),
2761 integer_zero_nodeglobal_trees[TI_INTEGER_ZERO]);
2762 if (code->ext.iterator->novector && cond != error_mark_nodeglobal_trees[TI_ERROR_MARK])
2763 cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond)((contains_struct_check ((cond), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2763, __FUNCTION__))->typed.type)
, cond,
2764 build_int_cst (integer_type_nodeinteger_types[itk_int], annot_expr_no_vector_kind),
2765 integer_zero_nodeglobal_trees[TI_INTEGER_ZERO]);
2766
2767 tmp = fold_build1_loc (loc, GOTO_EXPR, void_type_nodeglobal_trees[TI_VOID_TYPE], exit_label);
2768 tmp = fold_build3_loc (loc, COND_EXPR, void_type_nodeglobal_trees[TI_VOID_TYPE],
2769 cond, tmp, build_empty_stmt (loc));
2770 gfc_add_expr_to_block (&body, tmp);
2771
2772 /* End of loop body. */
2773 tmp = gfc_finish_block (&body);
2774
2775 /* The for loop itself. */
2776 tmp = fold_build1_loc (loc, LOOP_EXPR, void_type_nodeglobal_trees[TI_VOID_TYPE], tmp);
2777 gfc_add_expr_to_block (&block, tmp);
2778
2779 /* Add the exit label. */
2780 tmp = build1_v (LABEL_EXPR, exit_label)fold_build1_loc (input_location, LABEL_EXPR, global_trees[TI_VOID_TYPE
], exit_label)
;
2781 gfc_add_expr_to_block (&block, tmp);
2782
2783 return gfc_finish_block (&block);
2784}
2785
2786
2787/* Translate the DO WHILE construct.
2788
2789 We translate
2790
2791 DO WHILE (cond)
2792 body
2793 END DO
2794
2795 to:
2796
2797 for ( ; ; )
2798 {
2799 pre_cond;
2800 if (! cond) goto exit_label;
2801 body;
2802cycle_label:
2803 }
2804exit_label:
2805
2806 Because the evaluation of the exit condition `cond' may have side
2807 effects, we can't do much for empty loop bodies. The backend optimizers
2808 should be smart enough to eliminate any dead loops. */
2809
2810tree
2811gfc_trans_do_while (gfc_code * code)
2812{
2813 gfc_se cond;
2814 tree tmp;
2815 tree cycle_label;
2816 tree exit_label;
2817 stmtblock_t block;
2818
2819 /* Everything we build here is part of the loop body. */
2820 gfc_start_block (&block);
2821
2822 /* Cycle and exit statements are implemented with gotos. */
2823 cycle_label = gfc_build_label_decl (NULL_TREE(tree) __null);
2824 exit_label = gfc_build_label_decl (NULL_TREE(tree) __null);
2825
2826 /* Put the labels where they can be found later. See gfc_trans_do(). */
2827 code->cycle_label = cycle_label;
2828 code->exit_label = exit_label;
2829
2830 /* Create a GIMPLE version of the exit condition. */
2831 gfc_init_se (&cond, NULL__null);
2832 gfc_conv_expr_val (&cond, code->expr1);
2833 gfc_add_block_to_block (&block, &cond.pre);
2834 cond.expr = fold_build1_loc (gfc_get_location (&code->expr1->where),
2835 TRUTH_NOT_EXPR, TREE_TYPE (cond.expr)((contains_struct_check ((cond.expr), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2835, __FUNCTION__))->typed.type)
,
2836 cond.expr);
2837
2838 /* Build "IF (! cond) GOTO exit_label". */
2839 tmp = build1_v (GOTO_EXPR, exit_label)fold_build1_loc (input_location, GOTO_EXPR, global_trees[TI_VOID_TYPE
], exit_label)
;
2840 TREE_USED (exit_label)((exit_label)->base.used_flag) = 1;
2841 tmp = fold_build3_loc (gfc_get_location (&code->expr1->where), COND_EXPR,
2842 void_type_nodeglobal_trees[TI_VOID_TYPE], cond.expr, tmp,
2843 build_empty_stmt (gfc_get_location (
2844 &code->expr1->where)));
2845 gfc_add_expr_to_block (&block, tmp);
2846
2847 /* The main body of the loop. */
2848 tmp = gfc_trans_code (code->block->next);
2849 gfc_add_expr_to_block (&block, tmp);
2850
2851 /* Label for cycle statements (if needed). */
2852 if (TREE_USED (cycle_label)((cycle_label)->base.used_flag))
2853 {
2854 tmp = build1_v (LABEL_EXPR, cycle_label)fold_build1_loc (input_location, LABEL_EXPR, global_trees[TI_VOID_TYPE
], cycle_label)
;
2855 gfc_add_expr_to_block (&block, tmp);
2856 }
2857
2858 /* End of loop body. */
2859 tmp = gfc_finish_block (&block);
2860
2861 gfc_init_block (&block);
2862 /* Build the loop. */
2863 tmp = fold_build1_loc (gfc_get_location (&code->expr1->where), LOOP_EXPR,
2864 void_type_nodeglobal_trees[TI_VOID_TYPE], tmp);
2865 gfc_add_expr_to_block (&block, tmp);
2866
2867 /* Add the exit label. */
2868 tmp = build1_v (LABEL_EXPR, exit_label)fold_build1_loc (input_location, LABEL_EXPR, global_trees[TI_VOID_TYPE
], exit_label)
;
2869 gfc_add_expr_to_block (&block, tmp);
2870
2871 return gfc_finish_block (&block);
2872}
2873
2874
2875/* Deal with the particular case of SELECT_TYPE, where the vtable
2876 addresses are used for the selection. Since these are not sorted,
2877 the selection has to be made by a series of if statements. */
2878
2879static tree
2880gfc_trans_select_type_cases (gfc_code * code)
2881{
2882 gfc_code *c;
2883 gfc_case *cp;
2884 tree tmp;
2885 tree cond;
2886 tree low;
2887 tree high;
2888 gfc_se se;
2889 gfc_se cse;
2890 stmtblock_t block;
2891 stmtblock_t body;
2892 bool def = false;
2893 gfc_expr *e;
2894 gfc_start_block (&block);
2895
2896 /* Calculate the switch expression. */
2897 gfc_init_se (&se, NULL__null);
2898 gfc_conv_expr_val (&se, code->expr1);
2899 gfc_add_block_to_block (&block, &se.pre);
2900
2901 /* Generate an expression for the selector hash value, for
2902 use to resolve character cases. */
2903 e = gfc_copy_expr (code->expr1->value.function.actual->expr);
2904 gfc_add_hash_component (e)gfc_add_component_ref(e,"_hash");
2905
2906 TREE_USED (code->exit_label)((code->exit_label)->base.used_flag) = 0;
2907
2908repeat:
2909 for (c = code->block; c; c = c->block)
2910 {
2911 cp = c->ext.block.case_list;
2912
2913 /* Assume it's the default case. */
2914 low = NULL_TREE(tree) __null;
2915 high = NULL_TREE(tree) __null;
2916 tmp = NULL_TREE(tree) __null;
2917
2918 /* Put the default case at the end. */
2919 if ((!def && !cp->low) || (def && cp->low))
2920 continue;
2921
2922 if (cp->low && (cp->ts.type == BT_CLASS
2923 || cp->ts.type == BT_DERIVED))
2924 {
2925 gfc_init_se (&cse, NULL__null);
2926 gfc_conv_expr_val (&cse, cp->low);
2927 gfc_add_block_to_block (&block, &cse.pre);
2928 low = cse.expr;
2929 }
2930 else if (cp->ts.type != BT_UNKNOWN)
2931 {
2932 gcc_assert (cp->high)((void)(!(cp->high) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2932, __FUNCTION__), 0 : 0))
;
2933 gfc_init_se (&cse, NULL__null);
2934 gfc_conv_expr_val (&cse, cp->high);
2935 gfc_add_block_to_block (&block, &cse.pre);
2936 high = cse.expr;
2937 }
2938
2939 gfc_init_block (&body);
2940
2941 /* Add the statements for this case. */
2942 tmp = gfc_trans_code (c->next);
2943 gfc_add_expr_to_block (&body, tmp);
2944
2945 /* Break to the end of the SELECT TYPE construct. The default
2946 case just falls through. */
2947 if (!def)
2948 {
2949 TREE_USED (code->exit_label)((code->exit_label)->base.used_flag) = 1;
2950 tmp = build1_v (GOTO_EXPR, code->exit_label)fold_build1_loc (input_location, GOTO_EXPR, global_trees[TI_VOID_TYPE
], code->exit_label)
;
2951 gfc_add_expr_to_block (&body, tmp);
2952 }
2953
2954 tmp = gfc_finish_block (&body);
2955
2956 if (low != NULL_TREE(tree) __null)
2957 {
2958 /* Compare vtable pointers. */
2959 cond = fold_build2_loc (input_location, EQ_EXPR,
2960 TREE_TYPE (se.expr)((contains_struct_check ((se.expr), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2960, __FUNCTION__))->typed.type)
, se.expr, low);
2961 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_nodeglobal_trees[TI_VOID_TYPE],
2962 cond, tmp,
2963 build_empty_stmt (input_location));
2964 }
2965 else if (high != NULL_TREE(tree) __null)
2966 {
2967 /* Compare hash values for character cases. */
2968 gfc_init_se (&cse, NULL__null);
2969 gfc_conv_expr_val (&cse, e);
2970 gfc_add_block_to_block (&block, &cse.pre);
2971
2972 cond = fold_build2_loc (input_location, EQ_EXPR,
2973 TREE_TYPE (se.expr)((contains_struct_check ((se.expr), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 2973, __FUNCTION__))->typed.type)
, high, cse.expr);
2974 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_nodeglobal_trees[TI_VOID_TYPE],
2975 cond, tmp,
2976 build_empty_stmt (input_location));
2977 }
2978
2979 gfc_add_expr_to_block (&block, tmp);
2980 }
2981
2982 if (!def)
2983 {
2984 def = true;
2985 goto repeat;
2986 }
2987
2988 gfc_free_expr (e);
2989
2990 return gfc_finish_block (&block);
2991}
2992
2993
2994/* Translate the SELECT CASE construct for INTEGER case expressions,
2995 without killing all potential optimizations. The problem is that
2996 Fortran allows unbounded cases, but the back-end does not, so we
2997 need to intercept those before we enter the equivalent SWITCH_EXPR
2998 we can build.
2999
3000 For example, we translate this,
3001
3002 SELECT CASE (expr)
3003 CASE (:100,101,105:115)
3004 block_1
3005 CASE (190:199,200:)
3006 block_2
3007 CASE (300)
3008 block_3
3009 CASE DEFAULT
3010 block_4
3011 END SELECT
3012
3013 to the GENERIC equivalent,
3014
3015 switch (expr)
3016 {
3017 case (minimum value for typeof(expr) ... 100:
3018 case 101:
3019 case 105 ... 114:
3020 block1:
3021 goto end_label;
3022
3023 case 200 ... (maximum value for typeof(expr):
3024 case 190 ... 199:
3025 block2;
3026 goto end_label;
3027
3028 case 300:
3029 block_3;
3030 goto end_label;
3031
3032 default:
3033 block_4;
3034 goto end_label;
3035 }
3036
3037 end_label: */
3038
3039static tree
3040gfc_trans_integer_select (gfc_code * code)
3041{
3042 gfc_code *c;
3043 gfc_case *cp;
3044 tree end_label;
3045 tree tmp;
3046 gfc_se se;
3047 stmtblock_t block;
3048 stmtblock_t body;
3049
3050 gfc_start_block (&block);
3051
3052 /* Calculate the switch expression. */
3053 gfc_init_se (&se, NULL__null);
3054 gfc_conv_expr_val (&se, code->expr1);
3055 gfc_add_block_to_block (&block, &se.pre);
3056
3057 end_label = gfc_build_label_decl (NULL_TREE(tree) __null);
3058
3059 gfc_init_block (&body);
3060
3061 for (c = code->block; c; c = c->block)
3062 {
3063 for (cp = c->ext.block.case_list; cp; cp = cp->next)
3064 {
3065 tree low, high;
3066 tree label;
3067
3068 /* Assume it's the default case. */
3069 low = high = NULL_TREE(tree) __null;
3070
3071 if (cp->low)
3072 {
3073 low = gfc_conv_mpz_to_tree (cp->low->value.integer,
3074 cp->low->ts.kind);
3075
3076 /* If there's only a lower bound, set the high bound to the
3077 maximum value of the case expression. */
3078 if (!cp->high)
3079 high = TYPE_MAX_VALUE (TREE_TYPE (se.expr))((tree_check5 ((((contains_struct_check ((se.expr), (TS_TYPED
), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 3079, __FUNCTION__))->typed.type)), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 3079, __FUNCTION__, (INTEGER_TYPE), (ENUMERAL_TYPE), (BOOLEAN_TYPE
), (REAL_TYPE), (FIXED_POINT_TYPE)))->type_non_common.maxval
)
;
3080 }
3081
3082 if (cp->high)
3083 {
3084 /* Three cases are possible here:
3085
3086 1) There is no lower bound, e.g. CASE (:N).
3087 2) There is a lower bound .NE. high bound, that is
3088 a case range, e.g. CASE (N:M) where M>N (we make
3089 sure that M>N during type resolution).
3090 3) There is a lower bound, and it has the same value
3091 as the high bound, e.g. CASE (N:N). This is our
3092 internal representation of CASE(N).
3093
3094 In the first and second case, we need to set a value for
3095 high. In the third case, we don't because the GCC middle
3096 end represents a single case value by just letting high be
3097 a NULL_TREE. We can't do that because we need to be able
3098 to represent unbounded cases. */
3099
3100 if (!cp->low
3101 || (mpz_cmp__gmpz_cmp (cp->low->value.integer,
3102 cp->high->value.integer) != 0))
3103 high = gfc_conv_mpz_to_tree (cp->high->value.integer,
3104 cp->high->ts.kind);
3105
3106 /* Unbounded case. */
3107 if (!cp->low)
3108 low = TYPE_MIN_VALUE (TREE_TYPE (se.expr))((tree_check5 ((((contains_struct_check ((se.expr), (TS_TYPED
), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 3108, __FUNCTION__))->typed.type)), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 3108, __FUNCTION__, (INTEGER_TYPE), (ENUMERAL_TYPE), (BOOLEAN_TYPE
), (REAL_TYPE), (FIXED_POINT_TYPE)))->type_non_common.minval
)
;
3109 }
3110
3111 /* Build a label. */
3112 label = gfc_build_label_decl (NULL_TREE(tree) __null);
3113
3114 /* Add this case label.
3115 Add parameter 'label', make it match GCC backend. */
3116 tmp = build_case_label (low, high, label);
3117 gfc_add_expr_to_block (&body, tmp);
3118 }
3119
3120 /* Add the statements for this case. */
3121 tmp = gfc_trans_code (c->next);
3122 gfc_add_expr_to_block (&body, tmp);
3123
3124 /* Break to the end of the construct. */
3125 tmp = build1_v (GOTO_EXPR, end_label)fold_build1_loc (input_location, GOTO_EXPR, global_trees[TI_VOID_TYPE
], end_label)
;
3126 gfc_add_expr_to_block (&body, tmp);
3127 }
3128
3129 tmp = gfc_finish_block (&body);
3130 tmp = fold_build2_loc (input_location, SWITCH_EXPR, NULL_TREE(tree) __null, se.expr, tmp);
3131 gfc_add_expr_to_block (&block, tmp);
3132
3133 tmp = build1_v (LABEL_EXPR, end_label)fold_build1_loc (input_location, LABEL_EXPR, global_trees[TI_VOID_TYPE
], end_label)
;
3134 gfc_add_expr_to_block (&block, tmp);
3135
3136 return gfc_finish_block (&block);
3137}
3138
3139
3140/* Translate the SELECT CASE construct for LOGICAL case expressions.
3141
3142 There are only two cases possible here, even though the standard
3143 does allow three cases in a LOGICAL SELECT CASE construct: .TRUE.,
3144 .FALSE., and DEFAULT.
3145
3146 We never generate more than two blocks here. Instead, we always
3147 try to eliminate the DEFAULT case. This way, we can translate this
3148 kind of SELECT construct to a simple
3149
3150 if {} else {};
3151
3152 expression in GENERIC. */
3153
3154static tree
3155gfc_trans_logical_select (gfc_code * code)
3156{
3157 gfc_code *c;
3158 gfc_code *t, *f, *d;
3159 gfc_case *cp;
3160 gfc_se se;
3161 stmtblock_t block;
3162
3163 /* Assume we don't have any cases at all. */
3164 t = f = d = NULL__null;
3165
3166 /* Now see which ones we actually do have. We can have at most two
3167 cases in a single case list: one for .TRUE. and one for .FALSE.
3168 The default case is always separate. If the cases for .TRUE. and
3169 .FALSE. are in the same case list, the block for that case list
3170 always executed, and we don't generate code a COND_EXPR. */
3171 for (c = code->block; c; c = c->block)
3172 {
3173 for (cp = c->ext.block.case_list; cp; cp = cp->next)
3174 {
3175 if (cp->low)
3176 {
3177 if (cp->low->value.logical == 0) /* .FALSE. */
3178 f = c;
3179 else /* if (cp->value.logical != 0), thus .TRUE. */
3180 t = c;
3181 }
3182 else
3183 d = c;
3184 }
3185 }
3186
3187 /* Start a new block. */
3188 gfc_start_block (&block);
3189
3190 /* Calculate the switch expression. We always need to do this
3191 because it may have side effects. */
3192 gfc_init_se (&se, NULL__null);
3193 gfc_conv_expr_val (&se, code->expr1);
3194 gfc_add_block_to_block (&block, &se.pre);
3195
3196 if (t == f && t != NULL__null)
3197 {
3198 /* Cases for .TRUE. and .FALSE. are in the same block. Just
3199 translate the code for these cases, append it to the current
3200 block. */
3201 gfc_add_expr_to_block (&block, gfc_trans_code (t->next));
3202 }
3203 else
3204 {
3205 tree true_tree, false_tree, stmt;
3206
3207 true_tree = build_empty_stmt (input_location);
3208 false_tree = build_empty_stmt (input_location);
3209
3210 /* If we have a case for .TRUE. and for .FALSE., discard the default case.
3211 Otherwise, if .TRUE. or .FALSE. is missing and there is a default case,
3212 make the missing case the default case. */
3213 if (t != NULL__null && f != NULL__null)
3214 d = NULL__null;
3215 else if (d != NULL__null)
3216 {
3217 if (t == NULL__null)
3218 t = d;
3219 else
3220 f = d;
3221 }
3222
3223 /* Translate the code for each of these blocks, and append it to
3224 the current block. */
3225 if (t != NULL__null)
3226 true_tree = gfc_trans_code (t->next);
3227
3228 if (f != NULL__null)
3229 false_tree = gfc_trans_code (f->next);
3230
3231 stmt = fold_build3_loc (input_location, COND_EXPR, void_type_nodeglobal_trees[TI_VOID_TYPE],
3232 se.expr, true_tree, false_tree);
3233 gfc_add_expr_to_block (&block, stmt);
3234 }
3235
3236 return gfc_finish_block (&block);
3237}
3238
3239
3240/* The jump table types are stored in static variables to avoid
3241 constructing them from scratch every single time. */
3242static GTY(()) tree select_struct[2];
3243
3244/* Translate the SELECT CASE construct for CHARACTER case expressions.
3245 Instead of generating compares and jumps, it is far simpler to
3246 generate a data structure describing the cases in order and call a
3247 library subroutine that locates the right case.
3248 This is particularly true because this is the only case where we
3249 might have to dispose of a temporary.
3250 The library subroutine returns a pointer to jump to or NULL if no
3251 branches are to be taken. */
3252
3253static tree
3254gfc_trans_character_select (gfc_code *code)
3255{
3256 tree init, end_label, tmp, type, case_num, label, fndecl;
3257 stmtblock_t block, body;
3258 gfc_case *cp, *d;
3259 gfc_code *c;
3260 gfc_se se, expr1se;
3261 int n, k;
3262 vec<constructor_elt, va_gc> *inits = NULL__null;
3263
3264 tree pchartype = gfc_get_pchar_type (code->expr1->ts.kind);
3265
3266 /* The jump table types are stored in static variables to avoid
3267 constructing them from scratch every single time. */
3268 static tree ss_string1[2], ss_string1_len[2];
3269 static tree ss_string2[2], ss_string2_len[2];
3270 static tree ss_target[2];
3271
3272 cp = code->block->ext.block.case_list;
3273 while (cp->left != NULL__null)
1
Assuming field 'left' is equal to NULL
2
Loop condition is false. Execution continues on line 3277
3274 cp = cp->left;
3275
3276 /* Generate the body */
3277 gfc_start_block (&block);
3278 gfc_init_se (&expr1se, NULL__null);
3279 gfc_conv_expr_reference (&expr1se, code->expr1);
3280
3281 gfc_add_block_to_block (&block, &expr1se.pre);
3282
3283 end_label = gfc_build_label_decl (NULL_TREE(tree) __null);
3284
3285 gfc_init_block (&body);
3286
3287 /* Attempt to optimize length 1 selects. */
3288 if (integer_onep (expr1se.string_length))
3
Assuming the condition is false
4
Taking false branch
3289 {
3290 for (d = cp; d; d = d->right)
3291 {
3292 gfc_charlen_t i;
3293 if (d->low)
3294 {
3295 gcc_assert (d->low->expr_type == EXPR_CONSTANT((void)(!(d->low->expr_type == EXPR_CONSTANT &&
d->low->ts.type == BT_CHARACTER) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 3296, __FUNCTION__), 0 : 0))
3296 && d->low->ts.type == BT_CHARACTER)((void)(!(d->low->expr_type == EXPR_CONSTANT &&
d->low->ts.type == BT_CHARACTER) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 3296, __FUNCTION__), 0 : 0))
;
3297 if (d->low->value.character.length > 1)
3298 {
3299 for (i = 1; i < d->low->value.character.length; i++)
3300 if (d->low->value.character.string[i] != ' ')
3301 break;
3302 if (i != d->low->value.character.length)
3303 {
3304 if (optimizeglobal_options.x_optimize && d->high && i == 1)
3305 {
3306 gcc_assert (d->high->expr_type == EXPR_CONSTANT((void)(!(d->high->expr_type == EXPR_CONSTANT &&
d->high->ts.type == BT_CHARACTER) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 3307, __FUNCTION__), 0 : 0))
3307 && d->high->ts.type == BT_CHARACTER)((void)(!(d->high->expr_type == EXPR_CONSTANT &&
d->high->ts.type == BT_CHARACTER) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 3307, __FUNCTION__), 0 : 0))
;
3308 if (d->high->value.character.length > 1
3309 && (d->low->value.character.string[0]
3310 == d->high->value.character.string[0])
3311 && d->high->value.character.string[1] != ' '
3312 && ((d->low->value.character.string[1] < ' ')
3313 == (d->high->value.character.string[1]
3314 < ' ')))
3315 continue;
3316 }
3317 break;
3318 }
3319 }
3320 }
3321 if (d->high)
3322 {
3323 gcc_assert (d->high->expr_type == EXPR_CONSTANT((void)(!(d->high->expr_type == EXPR_CONSTANT &&
d->high->ts.type == BT_CHARACTER) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 3324, __FUNCTION__), 0 : 0))
3324 && d->high->ts.type == BT_CHARACTER)((void)(!(d->high->expr_type == EXPR_CONSTANT &&
d->high->ts.type == BT_CHARACTER) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 3324, __FUNCTION__), 0 : 0))
;
3325 if (d->high->value.character.length > 1)
3326 {
3327 for (i = 1; i < d->high->value.character.length; i++)
3328 if (d->high->value.character.string[i] != ' ')
3329 break;
3330 if (i != d->high->value.character.length)
3331 break;
3332 }
3333 }
3334 }
3335 if (d == NULL__null)
3336 {
3337 tree ctype = gfc_get_char_type (code->expr1->ts.kind);
3338
3339 for (c = code->block; c; c = c->block)
3340 {
3341 for (cp = c->ext.block.case_list; cp; cp = cp->next)
3342 {
3343 tree low, high;
3344 tree label;
3345 gfc_char_t r;
3346
3347 /* Assume it's the default case. */
3348 low = high = NULL_TREE(tree) __null;
3349
3350 if (cp->low)
3351 {
3352 /* CASE ('ab') or CASE ('ab':'az') will never match
3353 any length 1 character. */
3354 if (cp->low->value.character.length > 1
3355 && cp->low->value.character.string[1] != ' ')
3356 continue;
3357
3358 if (cp->low->value.character.length > 0)
3359 r = cp->low->value.character.string[0];
3360 else
3361 r = ' ';
3362 low = build_int_cst (ctype, r);
3363
3364 /* If there's only a lower bound, set the high bound
3365 to the maximum value of the case expression. */
3366 if (!cp->high)
3367 high = TYPE_MAX_VALUE (ctype)((tree_check5 ((ctype), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 3367, __FUNCTION__, (INTEGER_TYPE), (ENUMERAL_TYPE), (BOOLEAN_TYPE
), (REAL_TYPE), (FIXED_POINT_TYPE)))->type_non_common.maxval
)
;
3368 }
3369
3370 if (cp->high)
3371 {
3372 if (!cp->low
3373 || (cp->low->value.character.string[0]
3374 != cp->high->value.character.string[0]))
3375 {
3376 if (cp->high->value.character.length > 0)
3377 r = cp->high->value.character.string[0];
3378 else
3379 r = ' ';
3380 high = build_int_cst (ctype, r);
3381 }
3382
3383 /* Unbounded case. */
3384 if (!cp->low)
3385 low = TYPE_MIN_VALUE (ctype)((tree_check5 ((ctype), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 3385, __FUNCTION__, (INTEGER_TYPE), (ENUMERAL_TYPE), (BOOLEAN_TYPE
), (REAL_TYPE), (FIXED_POINT_TYPE)))->type_non_common.minval
)
;
3386 }
3387
3388 /* Build a label. */
3389 label = gfc_build_label_decl (NULL_TREE(tree) __null);
3390
3391 /* Add this case label.
3392 Add parameter 'label', make it match GCC backend. */
3393 tmp = build_case_label (low, high, label);
3394 gfc_add_expr_to_block (&body, tmp);
3395 }
3396
3397 /* Add the statements for this case. */
3398 tmp = gfc_trans_code (c->next);
3399 gfc_add_expr_to_block (&body, tmp);
3400
3401 /* Break to the end of the construct. */
3402 tmp = build1_v (GOTO_EXPR, end_label)fold_build1_loc (input_location, GOTO_EXPR, global_trees[TI_VOID_TYPE
], end_label)
;
3403 gfc_add_expr_to_block (&body, tmp);
3404 }
3405
3406 tmp = gfc_string_to_single_character (expr1se.string_length,
3407 expr1se.expr,
3408 code->expr1->ts.kind);
3409 case_num = gfc_create_var (ctype, "case_num");
3410 gfc_add_modify (&block, case_num, tmp);
3411
3412 gfc_add_block_to_block (&block, &expr1se.post);
3413
3414 tmp = gfc_finish_block (&body);
3415 tmp = fold_build2_loc (input_location, SWITCH_EXPR, NULL_TREE(tree) __null,
3416 case_num, tmp);
3417 gfc_add_expr_to_block (&block, tmp);
3418
3419 tmp = build1_v (LABEL_EXPR, end_label)fold_build1_loc (input_location, LABEL_EXPR, global_trees[TI_VOID_TYPE
], end_label)
;
3420 gfc_add_expr_to_block (&block, tmp);
3421
3422 return gfc_finish_block (&block);
3423 }
3424 }
3425
3426 if (code->expr1->ts.kind == 1)
5
Assuming field 'kind' is not equal to 1
6
Taking false branch
3427 k = 0;
3428 else if (code->expr1->ts.kind == 4)
7
Assuming field 'kind' is equal to 4
8
Taking true branch
3429 k = 1;
3430 else
3431 gcc_unreachable ()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 3431, __FUNCTION__))
;
3432
3433 if (select_struct[k] == NULL__null)
9
Assuming the condition is false
10
Taking false branch
3434 {
3435 tree *chain = NULL__null;
3436 select_struct[k] = make_node (RECORD_TYPE);
3437
3438 if (code->expr1->ts.kind == 1)
3439 TYPE_NAME (select_struct[k])((tree_class_check ((select_struct[k]), (tcc_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 3439, __FUNCTION__))->type_common.name)
= get_identifier ("_jump_struct_char1")(__builtin_constant_p ("_jump_struct_char1") ? get_identifier_with_length
(("_jump_struct_char1"), strlen ("_jump_struct_char1")) : get_identifier
("_jump_struct_char1"))
;
3440 else if (code->expr1->ts.kind == 4)
3441 TYPE_NAME (select_struct[k])((tree_class_check ((select_struct[k]), (tcc_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 3441, __FUNCTION__))->type_common.name)
= get_identifier ("_jump_struct_char4")(__builtin_constant_p ("_jump_struct_char4") ? get_identifier_with_length
(("_jump_struct_char4"), strlen ("_jump_struct_char4")) : get_identifier
("_jump_struct_char4"))
;
3442 else
3443 gcc_unreachable ()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 3443, __FUNCTION__))
;
3444
3445#undef ADD_FIELD
3446#define ADD_FIELD(NAME, TYPE) \
3447 ss_##NAME[k] = gfc_add_field_to_struct (select_struct[k], \
3448 get_identifier (stringize(NAME))(__builtin_constant_p ("NAME") ? get_identifier_with_length (
("NAME"), strlen ("NAME")) : get_identifier ("NAME"))
, \
3449 TYPE, \
3450 &chain)
3451
3452 ADD_FIELD (string1, pchartype);
3453 ADD_FIELD (string1_len, gfc_charlen_type_node);
3454
3455 ADD_FIELD (string2, pchartype);
3456 ADD_FIELD (string2_len, gfc_charlen_type_node);
3457
3458 ADD_FIELD (target, integer_type_nodeinteger_types[itk_int]);
3459#undef ADD_FIELD
3460
3461 gfc_finish_type (select_struct[k]);
3462 }
3463
3464 n = 0;
3465 for (d = cp; d; d = d->right)
11
Loop condition is true. Entering loop body
12
Loop condition is false. Execution continues on line 3468
3466 d->n = n++;
3467
3468 for (c = code->block; c; c = c->block)
13
Loop condition is true. Entering loop body
19
Loop condition is false. Execution continues on line 3488
3469 {
3470 for (d = c->ext.block.case_list; d; d = d->next)
14
Loop condition is true. Entering loop body
18
Loop condition is false. Execution continues on line 3480
3471 {
3472 label = gfc_build_label_decl (NULL_TREE(tree) __null);
3473 tmp = build_case_label ((d->low == NULL__null && d->high == NULL__null)
15
Assuming field 'low' is equal to NULL
16
Assuming field 'high' is equal to NULL
17
'?' condition is true
3474 ? NULL__null
3475 : build_int_cst (integer_type_nodeinteger_types[itk_int], d->n),
3476 NULL__null, label);
3477 gfc_add_expr_to_block (&body, tmp);
3478 }
3479
3480 tmp = gfc_trans_code (c->next);
3481 gfc_add_expr_to_block (&body, tmp);
3482
3483 tmp = build1_v (GOTO_EXPR, end_label)fold_build1_loc (input_location, GOTO_EXPR, global_trees[TI_VOID_TYPE
], end_label)
;
3484 gfc_add_expr_to_block (&body, tmp);
3485 }
3486
3487 /* Generate the structure describing the branches */
3488 for (d = cp; d; d = d->right)
20
Loop condition is true. Entering loop body
3489 {
3490 vec<constructor_elt, va_gc> *node = NULL__null;
3491
3492 gfc_init_se (&se, NULL__null);
3493
3494 if (d->low
20.1
Field 'low' is equal to NULL
20.1
Field 'low' is equal to NULL
== NULL__null)
21
Taking true branch
3495 {
3496 CONSTRUCTOR_APPEND_ELT (node, ss_string1[k], null_pointer_node)do { constructor_elt _ce___ = {ss_string1[k], global_trees[TI_NULL_POINTER
]}; vec_safe_push ((node), _ce___); } while (0)
;
22
Calling 'vec_safe_push<constructor_elt, va_gc>'
43
Returning from 'vec_safe_push<constructor_elt, va_gc>'
44
Loop condition is false. Exiting loop
3497 CONSTRUCTOR_APPEND_ELT (node, ss_string1_len[k], build_zero_cst (gfc_charlen_type_node))do { constructor_elt _ce___ = {ss_string1_len[k], build_zero_cst
(gfc_charlen_type_node)}; vec_safe_push ((node), _ce___); } while
(0)
;
45
Passing value via 1st parameter 'v'
46
Calling 'vec_safe_push<constructor_elt, va_gc>'
3498 }
3499 else
3500 {
3501 gfc_conv_expr_reference (&se, d->low);
3502
3503 CONSTRUCTOR_APPEND_ELT (node, ss_string1[k], se.expr)do { constructor_elt _ce___ = {ss_string1[k], se.expr}; vec_safe_push
((node), _ce___); } while (0)
;
3504 CONSTRUCTOR_APPEND_ELT (node, ss_string1_len[k], se.string_length)do { constructor_elt _ce___ = {ss_string1_len[k], se.string_length
}; vec_safe_push ((node), _ce___); } while (0)
;
3505 }
3506
3507 if (d->high == NULL__null)
3508 {
3509 CONSTRUCTOR_APPEND_ELT (node, ss_string2[k], null_pointer_node)do { constructor_elt _ce___ = {ss_string2[k], global_trees[TI_NULL_POINTER
]}; vec_safe_push ((node), _ce___); } while (0)
;
3510 CONSTRUCTOR_APPEND_ELT (node, ss_string2_len[k], build_zero_cst (gfc_charlen_type_node))do { constructor_elt _ce___ = {ss_string2_len[k], build_zero_cst
(gfc_charlen_type_node)}; vec_safe_push ((node), _ce___); } while
(0)
;
3511 }
3512 else
3513 {
3514 gfc_init_se (&se, NULL__null);
3515 gfc_conv_expr_reference (&se, d->high);
3516
3517 CONSTRUCTOR_APPEND_ELT (node, ss_string2[k], se.expr)do { constructor_elt _ce___ = {ss_string2[k], se.expr}; vec_safe_push
((node), _ce___); } while (0)
;
3518 CONSTRUCTOR_APPEND_ELT (node, ss_string2_len[k], se.string_length)do { constructor_elt _ce___ = {ss_string2_len[k], se.string_length
}; vec_safe_push ((node), _ce___); } while (0)
;
3519 }
3520
3521 CONSTRUCTOR_APPEND_ELT (node, ss_target[k],do { constructor_elt _ce___ = {ss_target[k], build_int_cst (integer_types
[itk_int], d->n)}; vec_safe_push ((node), _ce___); } while
(0)
3522 build_int_cst (integer_type_node, d->n))do { constructor_elt _ce___ = {ss_target[k], build_int_cst (integer_types
[itk_int], d->n)}; vec_safe_push ((node), _ce___); } while
(0)
;
3523
3524 tmp = build_constructor (select_struct[k], node);
3525 CONSTRUCTOR_APPEND_ELT (inits, NULL_TREE, tmp)do { constructor_elt _ce___ = {(tree) __null, tmp}; vec_safe_push
((inits), _ce___); } while (0)
;
3526 }
3527
3528 type = build_array_type (select_struct[k],
3529 build_index_type (size_int (n-1)size_int_kind (n-1, stk_sizetype)));
3530
3531 init = build_constructor (type, inits);
3532 TREE_CONSTANT (init)((non_type_check ((init), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 3532, __FUNCTION__))->base.constant_flag)
= 1;
3533 TREE_STATIC (init)((init)->base.static_flag) = 1;
3534 /* Create a static variable to hold the jump table. */
3535 tmp = gfc_create_var (type, "jumptable");
3536 TREE_CONSTANT (tmp)((non_type_check ((tmp), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 3536, __FUNCTION__))->base.constant_flag)
= 1;
3537 TREE_STATIC (tmp)((tmp)->base.static_flag) = 1;
3538 TREE_READONLY (tmp)((non_type_check ((tmp), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 3538, __FUNCTION__))->base.readonly_flag)
= 1;
3539 DECL_INITIAL (tmp)((contains_struct_check ((tmp), (TS_DECL_COMMON), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 3539, __FUNCTION__))->decl_common.initial)
= init;
3540 init = tmp;
3541
3542 /* Build the library call */
3543 init = gfc_build_addr_expr (pvoid_type_node, init);
3544
3545 if (code->expr1->ts.kind == 1)
3546 fndecl = gfor_fndecl_select_string;
3547 else if (code->expr1->ts.kind == 4)
3548 fndecl = gfor_fndecl_select_string_char4;
3549 else
3550 gcc_unreachable ()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 3550, __FUNCTION__))
;
3551
3552 tmp = build_call_expr_loc (input_location,
3553 fndecl, 4, init,
3554 build_int_cst (gfc_charlen_type_node, n),
3555 expr1se.expr, expr1se.string_length);
3556 case_num = gfc_create_var (integer_type_nodeinteger_types[itk_int], "case_num");
3557 gfc_add_modify (&block, case_num, tmp);
3558
3559 gfc_add_block_to_block (&block, &expr1se.post);
3560
3561 tmp = gfc_finish_block (&body);
3562 tmp = fold_build2_loc (input_location, SWITCH_EXPR, NULL_TREE(tree) __null,
3563 case_num, tmp);
3564 gfc_add_expr_to_block (&block, tmp);
3565
3566 tmp = build1_v (LABEL_EXPR, end_label)fold_build1_loc (input_location, LABEL_EXPR, global_trees[TI_VOID_TYPE
], end_label)
;
3567 gfc_add_expr_to_block (&block, tmp);
3568
3569 return gfc_finish_block (&block);
3570}
3571
3572
3573/* Translate the three variants of the SELECT CASE construct.
3574
3575 SELECT CASEs with INTEGER case expressions can be translated to an
3576 equivalent GENERIC switch statement, and for LOGICAL case
3577 expressions we build one or two if-else compares.
3578
3579 SELECT CASEs with CHARACTER case expressions are a whole different
3580 story, because they don't exist in GENERIC. So we sort them and
3581 do a binary search at runtime.
3582
3583 Fortran has no BREAK statement, and it does not allow jumps from
3584 one case block to another. That makes things a lot easier for
3585 the optimizers. */
3586
3587tree
3588gfc_trans_select (gfc_code * code)
3589{
3590 stmtblock_t block;
3591 tree body;
3592 tree exit_label;
3593
3594 gcc_assert (code && code->expr1)((void)(!(code && code->expr1) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 3594, __FUNCTION__), 0 : 0))
;
3595 gfc_init_block (&block);
3596
3597 /* Build the exit label and hang it in. */
3598 exit_label = gfc_build_label_decl (NULL_TREE(tree) __null);
3599 code->exit_label = exit_label;
3600
3601 /* Empty SELECT constructs are legal. */
3602 if (code->block == NULL__null)
3603 body = build_empty_stmt (input_location);
3604
3605 /* Select the correct translation function. */
3606 else
3607 switch (code->expr1->ts.type)
3608 {
3609 case BT_LOGICAL:
3610 body = gfc_trans_logical_select (code);
3611 break;
3612
3613 case BT_INTEGER:
3614 body = gfc_trans_integer_select (code);
3615 break;
3616
3617 case BT_CHARACTER:
3618 body = gfc_trans_character_select (code);
3619 break;
3620
3621 default:
3622 gfc_internal_error ("gfc_trans_select(): Bad type for case expr.");
3623 /* Not reached */
3624 }
3625
3626 /* Build everything together. */
3627 gfc_add_expr_to_block (&block, body);
3628 gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, exit_label)fold_build1_loc (input_location, LABEL_EXPR, global_trees[TI_VOID_TYPE
], exit_label)
);
3629
3630 return gfc_finish_block (&block);
3631}
3632
3633tree
3634gfc_trans_select_type (gfc_code * code)
3635{
3636 stmtblock_t block;
3637 tree body;
3638 tree exit_label;
3639
3640 gcc_assert (code && code->expr1)((void)(!(code && code->expr1) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 3640, __FUNCTION__), 0 : 0))
;
3641 gfc_init_block (&block);
3642
3643 /* Build the exit label and hang it in. */
3644 exit_label = gfc_build_label_decl (NULL_TREE(tree) __null);
3645 code->exit_label = exit_label;
3646
3647 /* Empty SELECT constructs are legal. */
3648 if (code->block == NULL__null)
3649 body = build_empty_stmt (input_location);
3650 else
3651 body = gfc_trans_select_type_cases (code);
3652
3653 /* Build everything together. */
3654 gfc_add_expr_to_block (&block, body);
3655
3656 if (TREE_USED (exit_label)((exit_label)->base.used_flag))
3657 gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, exit_label)fold_build1_loc (input_location, LABEL_EXPR, global_trees[TI_VOID_TYPE
], exit_label)
);
3658
3659 return gfc_finish_block (&block);
3660}
3661
3662
3663static tree
3664gfc_trans_select_rank_cases (gfc_code * code)
3665{
3666 gfc_code *c;
3667 gfc_case *cp;
3668 tree tmp;
3669 tree cond;
3670 tree low;
3671 tree rank;
3672 gfc_se se;
3673 gfc_se cse;
3674 stmtblock_t block;
3675 stmtblock_t body;
3676 bool def = false;
3677
3678 gfc_start_block (&block);
3679
3680 /* Calculate the switch expression. */
3681 gfc_init_se (&se, NULL__null);
3682 gfc_conv_expr_descriptor (&se, code->expr1);
3683 rank = gfc_conv_descriptor_rank (se.expr);
3684 rank = gfc_evaluate_now (rank, &block);
3685 symbol_attribute attr = gfc_expr_attr (code->expr1);
3686 if (!attr.pointer && !attr.allocatable)
3687 {
3688 /* Special case for assumed-rank ('rank(*)', internally -1):
3689 rank = (rank == 0 || ubound[rank-1] != -1) ? rank : -1. */
3690 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3691 rank, build_int_cst (TREE_TYPE (rank)((contains_struct_check ((rank), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 3691, __FUNCTION__))->typed.type)
, 0));
3692 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
3693 fold_convert (gfc_array_index_type, rank)fold_convert_loc (((location_t) 0), gfc_array_index_type, rank
)
,
3694 gfc_index_one_nodegfc_rank_cst[1]);
3695 tmp = gfc_conv_descriptor_ubound_get (se.expr, tmp);
3696 tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
3697 tmp, build_int_cst (TREE_TYPE (tmp)((contains_struct_check ((tmp), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 3697, __FUNCTION__))->typed.type)
, -1));
3698 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
3699 logical_type_node, cond, tmp);
3700 tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (rank)((contains_struct_check ((rank), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 3700, __FUNCTION__))->typed.type)
,
3701 cond, rank, build_int_cst (TREE_TYPE (rank)((contains_struct_check ((rank), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 3701, __FUNCTION__))->typed.type)
, -1));
3702 rank = gfc_evaluate_now (tmp, &block);
3703 }
3704 TREE_USED (code->exit_label)((code->exit_label)->base.used_flag) = 0;
3705
3706repeat:
3707 for (c = code->block; c; c = c->block)
3708 {
3709 cp = c->ext.block.case_list;
3710
3711 /* Assume it's the default case. */
3712 low = NULL_TREE(tree) __null;
3713 tmp = NULL_TREE(tree) __null;
3714
3715 /* Put the default case at the end. */
3716 if ((!def && !cp->low) || (def && cp->low))
3717 continue;
3718
3719 if (cp->low)
3720 {
3721 gfc_init_se (&cse, NULL__null);
3722 gfc_conv_expr_val (&cse, cp->low);
3723 gfc_add_block_to_block (&block, &cse.pre);
3724 low = cse.expr;
3725 }
3726
3727 gfc_init_block (&body);
3728
3729 /* Add the statements for this case. */
3730 tmp = gfc_trans_code (c->next);
3731 gfc_add_expr_to_block (&body, tmp);
3732
3733 /* Break to the end of the SELECT RANK construct. The default
3734 case just falls through. */
3735 if (!def)
3736 {
3737 TREE_USED (code->exit_label)((code->exit_label)->base.used_flag) = 1;
3738 tmp = build1_v (GOTO_EXPR, code->exit_label)fold_build1_loc (input_location, GOTO_EXPR, global_trees[TI_VOID_TYPE
], code->exit_label)
;
3739 gfc_add_expr_to_block (&body, tmp);
3740 }
3741
3742 tmp = gfc_finish_block (&body);
3743
3744 if (low != NULL_TREE(tree) __null)
3745 {
3746 cond = fold_build2_loc (input_location, EQ_EXPR,
3747 TREE_TYPE (rank)((contains_struct_check ((rank), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 3747, __FUNCTION__))->typed.type)
, rank,
3748 fold_convert (TREE_TYPE (rank), low)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(rank), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 3748, __FUNCTION__))->typed.type), low)
);
3749 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_nodeglobal_trees[TI_VOID_TYPE],
3750 cond, tmp,
3751 build_empty_stmt (input_location));
3752 }
3753
3754 gfc_add_expr_to_block (&block, tmp);
3755 }
3756
3757 if (!def)
3758 {
3759 def = true;
3760 goto repeat;
3761 }
3762
3763 return gfc_finish_block (&block);
3764}
3765
3766
3767tree
3768gfc_trans_select_rank (gfc_code * code)
3769{
3770 stmtblock_t block;
3771 tree body;
3772 tree exit_label;
3773
3774 gcc_assert (code && code->expr1)((void)(!(code && code->expr1) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 3774, __FUNCTION__), 0 : 0))
;
3775 gfc_init_block (&block);
3776
3777 /* Build the exit label and hang it in. */
3778 exit_label = gfc_build_label_decl (NULL_TREE(tree) __null);
3779 code->exit_label = exit_label;
3780
3781 /* Empty SELECT constructs are legal. */
3782 if (code->block == NULL__null)
3783 body = build_empty_stmt (input_location);
3784 else
3785 body = gfc_trans_select_rank_cases (code);
3786
3787 /* Build everything together. */
3788 gfc_add_expr_to_block (&block, body);
3789
3790 if (TREE_USED (exit_label)((exit_label)->base.used_flag))
3791 gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, exit_label)fold_build1_loc (input_location, LABEL_EXPR, global_trees[TI_VOID_TYPE
], exit_label)
);
3792
3793 return gfc_finish_block (&block);
3794}
3795
3796
3797/* Traversal function to substitute a replacement symtree if the symbol
3798 in the expression is the same as that passed. f == 2 signals that
3799 that variable itself is not to be checked - only the references.
3800 This group of functions is used when the variable expression in a
3801 FORALL assignment has internal references. For example:
3802 FORALL (i = 1:4) p(p(i)) = i
3803 The only recourse here is to store a copy of 'p' for the index
3804 expression. */
3805
3806static gfc_symtree *new_symtree;
3807static gfc_symtree *old_symtree;
3808
3809static bool
3810forall_replace (gfc_expr *expr, gfc_symbol *sym, int *f)
3811{
3812 if (expr->expr_type != EXPR_VARIABLE)
3813 return false;
3814
3815 if (*f == 2)
3816 *f = 1;
3817 else if (expr->symtree->n.sym == sym)
3818 expr->symtree = new_symtree;
3819
3820 return false;
3821}
3822
3823static void
3824forall_replace_symtree (gfc_expr *e, gfc_symbol *sym, int f)
3825{
3826 gfc_traverse_expr (e, sym, forall_replace, f);
3827}
3828
3829static bool
3830forall_restore (gfc_expr *expr,
3831 gfc_symbol *sym ATTRIBUTE_UNUSED__attribute__ ((__unused__)),
3832 int *f ATTRIBUTE_UNUSED__attribute__ ((__unused__)))
3833{
3834 if (expr->expr_type != EXPR_VARIABLE)
3835 return false;
3836
3837 if (expr->symtree == new_symtree)
3838 expr->symtree = old_symtree;
3839
3840 return false;
3841}
3842
3843static void
3844forall_restore_symtree (gfc_expr *e)
3845{
3846 gfc_traverse_expr (e, NULL__null, forall_restore, 0);
3847}
3848
3849static void
3850forall_make_variable_temp (gfc_code *c, stmtblock_t *pre, stmtblock_t *post)
3851{
3852 gfc_se tse;
3853 gfc_se rse;
3854 gfc_expr *e;
3855 gfc_symbol *new_sym;
3856 gfc_symbol *old_sym;
3857 gfc_symtree *root;
3858 tree tmp;
3859
3860 /* Build a copy of the lvalue. */
3861 old_symtree = c->expr1->symtree;
3862 old_sym = old_symtree->n.sym;
3863 e = gfc_lval_expr_from_sym (old_sym);
3864 if (old_sym->attr.dimension)
3865 {
3866 gfc_init_se (&tse, NULL__null);
3867 gfc_conv_subref_array_arg (&tse, e, 0, INTENT_IN, false);
3868 gfc_add_block_to_block (pre, &tse.pre);
3869 gfc_add_block_to_block (post, &tse.post);
3870 tse.expr = build_fold_indirect_ref_loc (input_location, tse.expr);
3871
3872 if (c->expr1->ref->u.ar.type != AR_SECTION)
3873 {
3874 /* Use the variable offset for the temporary. */
3875 tmp = gfc_conv_array_offset (old_sym->backend_decl);
3876 gfc_conv_descriptor_offset_set (pre, tse.expr, tmp);
3877 }
3878 }
3879 else
3880 {
3881 gfc_init_se (&tse, NULL__null);
3882 gfc_init_se (&rse, NULL__null);
3883 gfc_conv_expr (&rse, e);
3884 if (e->ts.type == BT_CHARACTER)
3885 {
3886 tse.string_length = rse.string_length;
3887 tmp = gfc_get_character_type_len (gfc_default_character_kind,
3888 tse.string_length);
3889 tse.expr = gfc_conv_string_tmp (&tse, build_pointer_type (tmp),
3890 rse.string_length);
3891 gfc_add_block_to_block (pre, &tse.pre);
3892 gfc_add_block_to_block (post, &tse.post);
3893 }
3894 else
3895 {
3896 tmp = gfc_typenode_for_spec (&e->ts);
3897 tse.expr = gfc_create_var (tmp, "temp");
3898 }
3899
3900 tmp = gfc_trans_scalar_assign (&tse, &rse, e->ts,
3901 e->expr_type == EXPR_VARIABLE, false);
3902 gfc_add_expr_to_block (pre, tmp);
3903 }
3904 gfc_free_expr (e);
3905
3906 /* Create a new symbol to represent the lvalue. */
3907 new_sym = gfc_new_symbol (old_sym->name, NULL__null);
3908 new_sym->ts = old_sym->ts;
3909 new_sym->attr.referenced = 1;
3910 new_sym->attr.temporary = 1;
3911 new_sym->attr.dimension = old_sym->attr.dimension;
3912 new_sym->attr.flavor = old_sym->attr.flavor;
3913
3914 /* Use the temporary as the backend_decl. */
3915 new_sym->backend_decl = tse.expr;
3916
3917 /* Create a fake symtree for it. */
3918 root = NULL__null;
3919 new_symtree = gfc_new_symtree (&root, old_sym->name);
3920 new_symtree->n.sym = new_sym;
3921 gcc_assert (new_symtree == root)((void)(!(new_symtree == root) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 3921, __FUNCTION__), 0 : 0))
;
3922
3923 /* Go through the expression reference replacing the old_symtree
3924 with the new. */
3925 forall_replace_symtree (c->expr1, old_sym, 2);
3926
3927 /* Now we have made this temporary, we might as well use it for
3928 the right hand side. */
3929 forall_replace_symtree (c->expr2, old_sym, 1);
3930}
3931
3932
3933/* Handles dependencies in forall assignments. */
3934static int
3935check_forall_dependencies (gfc_code *c, stmtblock_t *pre, stmtblock_t *post)
3936{
3937 gfc_ref *lref;
3938 gfc_ref *rref;
3939 int need_temp;
3940 gfc_symbol *lsym;
3941
3942 lsym = c->expr1->symtree->n.sym;
3943 need_temp = gfc_check_dependency (c->expr1, c->expr2, 0);
3944
3945 /* Now check for dependencies within the 'variable'
3946 expression itself. These are treated by making a complete
3947 copy of variable and changing all the references to it
3948 point to the copy instead. Note that the shallow copy of
3949 the variable will not suffice for derived types with
3950 pointer components. We therefore leave these to their
3951 own devices. Likewise for allocatable components. */
3952 if (lsym->ts.type == BT_DERIVED
3953 && (lsym->ts.u.derived->attr.pointer_comp
3954 || lsym->ts.u.derived->attr.alloc_comp))
3955 return need_temp;
3956
3957 new_symtree = NULL__null;
3958 if (find_forall_index (c->expr1, lsym, 2))
3959 {
3960 forall_make_variable_temp (c, pre, post);
3961 need_temp = 0;
3962 }
3963
3964 /* Substrings with dependencies are treated in the same
3965 way. */
3966 if (c->expr1->ts.type == BT_CHARACTER
3967 && c->expr1->ref
3968 && c->expr2->expr_type == EXPR_VARIABLE
3969 && lsym == c->expr2->symtree->n.sym)
3970 {
3971 for (lref = c->expr1->ref; lref; lref = lref->next)
3972 if (lref->type == REF_SUBSTRING)
3973 break;
3974 for (rref = c->expr2->ref; rref; rref = rref->next)
3975 if (rref->type == REF_SUBSTRING)
3976 break;
3977
3978 if (rref && lref
3979 && gfc_dep_compare_expr (rref->u.ss.start, lref->u.ss.start) < 0)
3980 {
3981 forall_make_variable_temp (c, pre, post);
3982 need_temp = 0;
3983 }
3984 }
3985 return need_temp;
3986}
3987
3988
3989static void
3990cleanup_forall_symtrees (gfc_code *c)
3991{
3992 forall_restore_symtree (c->expr1);
3993 forall_restore_symtree (c->expr2);
3994 free (new_symtree->n.sym);
3995 free (new_symtree);
3996}
3997
3998
3999/* Generate the loops for a FORALL block, specified by FORALL_TMP. BODY
4000 is the contents of the FORALL block/stmt to be iterated. MASK_FLAG
4001 indicates whether we should generate code to test the FORALLs mask
4002 array. OUTER is the loop header to be used for initializing mask
4003 indices.
4004
4005 The generated loop format is:
4006 count = (end - start + step) / step
4007 loopvar = start
4008 while (1)
4009 {
4010 if (count <=0 )
4011 goto end_of_loop
4012 <body>
4013 loopvar += step
4014 count --
4015 }
4016 end_of_loop: */
4017
4018static tree
4019gfc_trans_forall_loop (forall_info *forall_tmp, tree body,
4020 int mask_flag, stmtblock_t *outer)
4021{
4022 int n, nvar;
4023 tree tmp;
4024 tree cond;
4025 stmtblock_t block;
4026 tree exit_label;
4027 tree count;
4028 tree var, start, end, step;
4029 iter_info *iter;
4030
4031 /* Initialize the mask index outside the FORALL nest. */
4032 if (mask_flag && forall_tmp->mask)
4033 gfc_add_modify (outer, forall_tmp->maskindex, gfc_index_zero_nodegfc_rank_cst[0]);
4034
4035 iter = forall_tmp->this_loop;
4036 nvar = forall_tmp->nvar;
4037 for (n = 0; n < nvar; n++)
4038 {
4039 var = iter->var;
4040 start = iter->start;
4041 end = iter->end;
4042 step = iter->step;
4043
4044 exit_label = gfc_build_label_decl (NULL_TREE(tree) __null);
4045 TREE_USED (exit_label)((exit_label)->base.used_flag) = 1;
4046
4047 /* The loop counter. */
4048 count = gfc_create_var (TREE_TYPE (var)((contains_struct_check ((var), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 4048, __FUNCTION__))->typed.type)
, "count");
4049
4050 /* The body of the loop. */
4051 gfc_init_block (&block);
4052
4053 /* The exit condition. */
4054 cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
4055 count, build_int_cst (TREE_TYPE (count)((contains_struct_check ((count), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 4055, __FUNCTION__))->typed.type)
, 0));
4056
4057 /* PR 83064 means that we cannot use annot_expr_parallel_kind until
4058 the autoparallelizer can hande this. */
4059 if (forall_tmp->do_concurrent)
4060 cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond)((contains_struct_check ((cond), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 4060, __FUNCTION__))->typed.type)
, cond,
4061 build_int_cst (integer_type_nodeinteger_types[itk_int],
4062 annot_expr_ivdep_kind),
4063 integer_zero_nodeglobal_trees[TI_INTEGER_ZERO]);
4064
4065 tmp = build1_v (GOTO_EXPR, exit_label)fold_build1_loc (input_location, GOTO_EXPR, global_trees[TI_VOID_TYPE
], exit_label)
;
4066 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_nodeglobal_trees[TI_VOID_TYPE],
4067 cond, tmp, build_empty_stmt (input_location));
4068 gfc_add_expr_to_block (&block, tmp);
4069
4070 /* The main loop body. */
4071 gfc_add_expr_to_block (&block, body);
4072
4073 /* Increment the loop variable. */
4074 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var)((contains_struct_check ((var), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 4074, __FUNCTION__))->typed.type)
, var,
4075 step);
4076 gfc_add_modify (&block, var, tmp);
4077
4078 /* Advance to the next mask element. Only do this for the
4079 innermost loop. */
4080 if (n == 0 && mask_flag && forall_tmp->mask)
4081 {
4082 tree maskindex = forall_tmp->maskindex;
4083 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4084 maskindex, gfc_index_one_nodegfc_rank_cst[1]);
4085 gfc_add_modify (&block, maskindex, tmp);
4086 }
4087
4088 /* Decrement the loop counter. */
4089 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (var)((contains_struct_check ((var), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 4089, __FUNCTION__))->typed.type)
, count,
4090 build_int_cst (TREE_TYPE (var)((contains_struct_check ((var), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 4090, __FUNCTION__))->typed.type)
, 1));
4091 gfc_add_modify (&block, count, tmp);
4092
4093 body = gfc_finish_block (&block);
4094
4095 /* Loop var initialization. */
4096 gfc_init_block (&block);
4097 gfc_add_modify (&block, var, start);
4098
4099
4100 /* Initialize the loop counter. */
4101 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (var)((contains_struct_check ((var), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 4101, __FUNCTION__))->typed.type)
, step,
4102 start);
4103 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var)((contains_struct_check ((var), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 4103, __FUNCTION__))->typed.type)
, end,
4104 tmp);
4105 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, TREE_TYPE (var)((contains_struct_check ((var), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 4105, __FUNCTION__))->typed.type)
,
4106 tmp, step);
4107 gfc_add_modify (&block, count, tmp);
4108
4109 /* The loop expression. */
4110 tmp = build1_v (LOOP_EXPR, body)fold_build1_loc (input_location, LOOP_EXPR, global_trees[TI_VOID_TYPE
], body)
;
4111 gfc_add_expr_to_block (&block, tmp);
4112
4113 /* The exit label. */
4114 tmp = build1_v (LABEL_EXPR, exit_label)fold_build1_loc (input_location, LABEL_EXPR, global_trees[TI_VOID_TYPE
], exit_label)
;
4115 gfc_add_expr_to_block (&block, tmp);
4116
4117 body = gfc_finish_block (&block);
4118 iter = iter->next;
4119 }
4120 return body;
4121}
4122
4123
4124/* Generate the body and loops according to MASK_FLAG. If MASK_FLAG
4125 is nonzero, the body is controlled by all masks in the forall nest.
4126 Otherwise, the innermost loop is not controlled by it's mask. This
4127 is used for initializing that mask. */
4128
4129static tree
4130gfc_trans_nested_forall_loop (forall_info * nested_forall_info, tree body,
4131 int mask_flag)
4132{
4133 tree tmp;
4134 stmtblock_t header;
4135 forall_info *forall_tmp;
4136 tree mask, maskindex;
4137
4138 gfc_start_block (&header);
4139
4140 forall_tmp = nested_forall_info;
4141 while (forall_tmp != NULL__null)
4142 {
4143 /* Generate body with masks' control. */
4144 if (mask_flag)
4145 {
4146 mask = forall_tmp->mask;
4147 maskindex = forall_tmp->maskindex;
4148
4149 /* If a mask was specified make the assignment conditional. */
4150 if (mask)
4151 {
4152 tmp = gfc_build_array_ref (mask, maskindex, NULL__null);
4153 body = build3_v (COND_EXPR, tmp, body,fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], tmp, body, build_empty_stmt (input_location))
4154 build_empty_stmt (input_location))fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], tmp, body, build_empty_stmt (input_location))
;
4155 }
4156 }
4157 body = gfc_trans_forall_loop (forall_tmp, body, mask_flag, &header);
4158 forall_tmp = forall_tmp->prev_nest;
4159 mask_flag = 1;
4160 }
4161
4162 gfc_add_expr_to_block (&header, body);
4163 return gfc_finish_block (&header);
4164}
4165
4166
4167/* Allocate data for holding a temporary array. Returns either a local
4168 temporary array or a pointer variable. */
4169
4170static tree
4171gfc_do_allocate (tree bytesize, tree size, tree * pdata, stmtblock_t * pblock,
4172 tree elem_type)
4173{
4174 tree tmpvar;
4175 tree type;
4176 tree tmp;
4177
4178 if (INTEGER_CST_P (size)(((enum tree_code) (size)->base.code) == INTEGER_CST))
4179 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4180 size, gfc_index_one_nodegfc_rank_cst[1]);
4181 else
4182 tmp = NULL_TREE(tree) __null;
4183
4184 type = build_range_type (gfc_array_index_type, gfc_index_zero_nodegfc_rank_cst[0], tmp);
4185 type = build_array_type (elem_type, type);
4186 if (gfc_can_put_var_on_stack (bytesize) && INTEGER_CST_P (size)(((enum tree_code) (size)->base.code) == INTEGER_CST))
4187 {
4188 tmpvar = gfc_create_var (type, "temp");
4189 *pdata = NULL_TREE(tree) __null;
4190 }
4191 else
4192 {
4193 tmpvar = gfc_create_var (build_pointer_type (type), "temp");
4194 *pdata = convert (pvoid_type_node, tmpvar);
4195
4196 tmp = gfc_call_malloc (pblock, TREE_TYPE (tmpvar)((contains_struct_check ((tmpvar), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 4196, __FUNCTION__))->typed.type)
, bytesize);
4197 gfc_add_modify (pblock, tmpvar, tmp);
4198 }
4199 return tmpvar;
4200}
4201
4202
4203/* Generate codes to copy the temporary to the actual lhs. */
4204
4205static tree
4206generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree count3,
4207 tree count1,
4208 gfc_ss *lss, gfc_ss *rss,
4209 tree wheremask, bool invert)
4210{
4211 stmtblock_t block, body1;
4212 gfc_loopinfo loop;
4213 gfc_se lse;
4214 gfc_se rse;
4215 tree tmp;
4216 tree wheremaskexpr;
4217
4218 (void) rss; /* TODO: unused. */
4219
4220 gfc_start_block (&block);
4221
4222 gfc_init_se (&rse, NULL__null);
4223 gfc_init_se (&lse, NULL__null);
4224
4225 if (lss == gfc_ss_terminator)
4226 {
4227 gfc_init_block (&body1);
4228 gfc_conv_expr (&lse, expr);
4229 rse.expr = gfc_build_array_ref (tmp1, count1, NULL__null);
4230 }
4231 else
4232 {
4233 /* Initialize the loop. */
4234 gfc_init_loopinfo (&loop);
4235
4236 /* We may need LSS to determine the shape of the expression. */
4237 gfc_add_ss_to_loop (&loop, lss);
4238
4239 gfc_conv_ss_startstride (&loop);
4240 gfc_conv_loop_setup (&loop, &expr->where);
4241
4242 gfc_mark_ss_chain_used (lss, 1);
4243 /* Start the loop body. */
4244 gfc_start_scalarized_body (&loop, &body1);
4245
4246 /* Translate the expression. */
4247 gfc_copy_loopinfo_to_se (&lse, &loop);
4248 lse.ss = lss;
4249 gfc_conv_expr (&lse, expr);
4250
4251 /* Form the expression of the temporary. */
4252 rse.expr = gfc_build_array_ref (tmp1, count1, NULL__null);
4253 }
4254
4255 /* Use the scalar assignment. */
4256 rse.string_length = lse.string_length;
4257 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts,
4258 expr->expr_type == EXPR_VARIABLE, false);
4259
4260 /* Form the mask expression according to the mask tree list. */
4261 if (wheremask)
4262 {
4263 wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL__null);
4264 if (invert)
4265 wheremaskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
4266 TREE_TYPE (wheremaskexpr)((contains_struct_check ((wheremaskexpr), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 4266, __FUNCTION__))->typed.type)
,
4267 wheremaskexpr);
4268 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_nodeglobal_trees[TI_VOID_TYPE],
4269 wheremaskexpr, tmp,
4270 build_empty_stmt (input_location));
4271 }
4272
4273 gfc_add_expr_to_block (&body1, tmp);
4274
4275 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (count1)((contains_struct_check ((count1), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 4275, __FUNCTION__))->typed.type)
,
4276 count1, gfc_index_one_nodegfc_rank_cst[1]);
4277 gfc_add_modify (&body1, count1, tmp);
4278
4279 if (lss == gfc_ss_terminator)
4280 gfc_add_block_to_block (&block, &body1);
4281 else
4282 {
4283 /* Increment count3. */
4284 if (count3)
4285 {
4286 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4287 gfc_array_index_type,
4288 count3, gfc_index_one_nodegfc_rank_cst[1]);
4289 gfc_add_modify (&body1, count3, tmp);
4290 }
4291
4292 /* Generate the copying loops. */
4293 gfc_trans_scalarizing_loops (&loop, &body1);
4294
4295 gfc_add_block_to_block (&block, &loop.pre);
4296 gfc_add_block_to_block (&block, &loop.post);
4297
4298 gfc_cleanup_loop (&loop);
4299 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
4300 as tree nodes in SS may not be valid in different scope. */
4301 }
4302
4303 tmp = gfc_finish_block (&block);
4304 return tmp;
4305}
4306
4307
4308/* Generate codes to copy rhs to the temporary. TMP1 is the address of
4309 temporary, LSS and RSS are formed in function compute_inner_temp_size(),
4310 and should not be freed. WHEREMASK is the conditional execution mask
4311 whose sense may be inverted by INVERT. */
4312
4313static tree
4314generate_loop_for_rhs_to_temp (gfc_expr *expr2, tree tmp1, tree count3,
4315 tree count1, gfc_ss *lss, gfc_ss *rss,
4316 tree wheremask, bool invert)
4317{
4318 stmtblock_t block, body1;
4319 gfc_loopinfo loop;
4320 gfc_se lse;
4321 gfc_se rse;
4322 tree tmp;
4323 tree wheremaskexpr;
4324
4325 gfc_start_block (&block);
4326
4327 gfc_init_se (&rse, NULL__null);
4328 gfc_init_se (&lse, NULL__null);
4329
4330 if (lss == gfc_ss_terminator)
4331 {
4332 gfc_init_block (&body1);
4333 gfc_conv_expr (&rse, expr2);
4334 lse.expr = gfc_build_array_ref (tmp1, count1, NULL__null);
4335 }
4336 else
4337 {
4338 /* Initialize the loop. */
4339 gfc_init_loopinfo (&loop);
4340
4341 /* We may need LSS to determine the shape of the expression. */
4342 gfc_add_ss_to_loop (&loop, lss);
4343 gfc_add_ss_to_loop (&loop, rss);
4344
4345 gfc_conv_ss_startstride (&loop);
4346 gfc_conv_loop_setup (&loop, &expr2->where);
4347
4348 gfc_mark_ss_chain_used (rss, 1);
4349 /* Start the loop body. */
4350 gfc_start_scalarized_body (&loop, &body1);
4351
4352 /* Translate the expression. */
4353 gfc_copy_loopinfo_to_se (&rse, &loop);
4354 rse.ss = rss;
4355 gfc_conv_expr (&rse, expr2);
4356
4357 /* Form the expression of the temporary. */
4358 lse.expr = gfc_build_array_ref (tmp1, count1, NULL__null);
4359 }
4360
4361 /* Use the scalar assignment. */
4362 lse.string_length = rse.string_length;
4363 tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts,
4364 expr2->expr_type == EXPR_VARIABLE, false);
4365
4366 /* Form the mask expression according to the mask tree list. */
4367 if (wheremask)
4368 {
4369 wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL__null);
4370 if (invert)
4371 wheremaskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
4372 TREE_TYPE (wheremaskexpr)((contains_struct_check ((wheremaskexpr), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 4372, __FUNCTION__))->typed.type)
,
4373 wheremaskexpr);
4374 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_nodeglobal_trees[TI_VOID_TYPE],
4375 wheremaskexpr, tmp,
4376 build_empty_stmt (input_location));
4377 }
4378
4379 gfc_add_expr_to_block (&body1, tmp);
4380
4381 if (lss == gfc_ss_terminator)
4382 {
4383 gfc_add_block_to_block (&block, &body1);
4384
4385 /* Increment count1. */
4386 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (count1)((contains_struct_check ((count1), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 4386, __FUNCTION__))->typed.type)
,
4387 count1, gfc_index_one_nodegfc_rank_cst[1]);
4388 gfc_add_modify (&block, count1, tmp);
4389 }
4390 else
4391 {
4392 /* Increment count1. */
4393 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4394 count1, gfc_index_one_nodegfc_rank_cst[1]);
4395 gfc_add_modify (&body1, count1, tmp);
4396
4397 /* Increment count3. */
4398 if (count3)
4399 {
4400 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4401 gfc_array_index_type,
4402 count3, gfc_index_one_nodegfc_rank_cst[1]);
4403 gfc_add_modify (&body1, count3, tmp);
4404 }
4405
4406 /* Generate the copying loops. */
4407 gfc_trans_scalarizing_loops (&loop, &body1);
4408
4409 gfc_add_block_to_block (&block, &loop.pre);
4410 gfc_add_block_to_block (&block, &loop.post);
4411
4412 gfc_cleanup_loop (&loop);
4413 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
4414 as tree nodes in SS may not be valid in different scope. */
4415 }
4416
4417 tmp = gfc_finish_block (&block);
4418 return tmp;
4419}
4420
4421
4422/* Calculate the size of temporary needed in the assignment inside forall.
4423 LSS and RSS are filled in this function. */
4424
4425static tree
4426compute_inner_temp_size (gfc_expr *expr1, gfc_expr *expr2,
4427 stmtblock_t * pblock,
4428 gfc_ss **lss, gfc_ss **rss)
4429{
4430 gfc_loopinfo loop;
4431 tree size;
4432 int i;
4433 int save_flag;
4434 tree tmp;
4435
4436 *lss = gfc_walk_expr (expr1);
4437 *rss = NULL__null;
4438
4439 size = gfc_index_one_nodegfc_rank_cst[1];
4440 if (*lss != gfc_ss_terminator)
4441 {
4442 gfc_init_loopinfo (&loop);
4443
4444 /* Walk the RHS of the expression. */
4445 *rss = gfc_walk_expr (expr2);
4446 if (*rss == gfc_ss_terminator)
4447 /* The rhs is scalar. Add a ss for the expression. */
4448 *rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
4449
4450 /* Associate the SS with the loop. */
4451 gfc_add_ss_to_loop (&loop, *lss);
4452 /* We don't actually need to add the rhs at this point, but it might
4453 make guessing the loop bounds a bit easier. */
4454 gfc_add_ss_to_loop (&loop, *rss);
4455
4456 /* We only want the shape of the expression, not rest of the junk
4457 generated by the scalarizer. */
4458 loop.array_parameter = 1;
4459
4460 /* Calculate the bounds of the scalarization. */
4461 save_flag = gfc_option.rtcheck;
4462 gfc_option.rtcheck &= ~GFC_RTCHECK_BOUNDS(1<<0);
4463 gfc_conv_ss_startstride (&loop);
4464 gfc_option.rtcheck = save_flag;
4465 gfc_conv_loop_setup (&loop, &expr2->where);
4466
4467 /* Figure out how many elements we need. */
4468 for (i = 0; i < loop.dimen; i++)
4469 {
4470 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4471 gfc_array_index_type,
4472 gfc_index_one_nodegfc_rank_cst[1], loop.from[i]);
4473 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4474 gfc_array_index_type, tmp, loop.to[i]);
4475 size = fold_build2_loc (input_location, MULT_EXPR,
4476 gfc_array_index_type, size, tmp);
4477 }
4478 gfc_add_block_to_block (pblock, &loop.pre);
4479 size = gfc_evaluate_now (size, pblock);
4480 gfc_add_block_to_block (pblock, &loop.post);
4481
4482 /* TODO: write a function that cleans up a loopinfo without freeing
4483 the SS chains. Currently a NOP. */
4484 }
4485
4486 return size;
4487}
4488
4489
4490/* Calculate the overall iterator number of the nested forall construct.
4491 This routine actually calculates the number of times the body of the
4492 nested forall specified by NESTED_FORALL_INFO is executed and multiplies
4493 that by the expression INNER_SIZE. The BLOCK argument specifies the
4494 block in which to calculate the result, and the optional INNER_SIZE_BODY
4495 argument contains any statements that need to executed (inside the loop)
4496 to initialize or calculate INNER_SIZE. */
4497
4498static tree
4499compute_overall_iter_number (forall_info *nested_forall_info, tree inner_size,
4500 stmtblock_t *inner_size_body, stmtblock_t *block)
4501{
4502 forall_info *forall_tmp = nested_forall_info;
4503 tree tmp, number;
4504 stmtblock_t body;
4505
4506 /* We can eliminate the innermost unconditional loops with constant
4507 array bounds. */
4508 if (INTEGER_CST_P (inner_size)(((enum tree_code) (inner_size)->base.code) == INTEGER_CST
)
)
4509 {
4510 while (forall_tmp
4511 && !forall_tmp->mask
4512 && INTEGER_CST_P (forall_tmp->size)(((enum tree_code) (forall_tmp->size)->base.code) == INTEGER_CST
)
)
4513 {
4514 inner_size = fold_build2_loc (input_location, MULT_EXPR,
4515 gfc_array_index_type,
4516 inner_size, forall_tmp->size);
4517 forall_tmp = forall_tmp->prev_nest;
4518 }
4519
4520 /* If there are no loops left, we have our constant result. */
4521 if (!forall_tmp)
4522 return inner_size;
4523 }
4524
4525 /* Otherwise, create a temporary variable to compute the result. */
4526 number = gfc_create_var (gfc_array_index_type, "num");
4527 gfc_add_modify (block, number, gfc_index_zero_nodegfc_rank_cst[0]);
4528
4529 gfc_start_block (&body);
4530 if (inner_size_body)
4531 gfc_add_block_to_block (&body, inner_size_body);
4532 if (forall_tmp)
4533 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4534 gfc_array_index_type, number, inner_size);
4535 else
4536 tmp = inner_size;
4537 gfc_add_modify (&body, number, tmp);
4538 tmp = gfc_finish_block (&body);
4539
4540 /* Generate loops. */
4541 if (forall_tmp != NULL__null)
4542 tmp = gfc_trans_nested_forall_loop (forall_tmp, tmp, 1);
4543
4544 gfc_add_expr_to_block (block, tmp);
4545
4546 return number;
4547}
4548
4549
4550/* Allocate temporary for forall construct. SIZE is the size of temporary
4551 needed. PTEMP1 is returned for space free. */
4552
4553static tree
4554allocate_temp_for_forall_nest_1 (tree type, tree size, stmtblock_t * block,
4555 tree * ptemp1)
4556{
4557 tree bytesize;
4558 tree unit;
4559 tree tmp;
4560
4561 unit = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (type))fold_convert_loc (((location_t) 0), gfc_array_index_type, ((tree_class_check
((type), (tcc_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 4561, __FUNCTION__))->type_common.size_unit))
;
4562 if (!integer_onep (unit))
4563 bytesize = fold_build2_loc (input_location, MULT_EXPR,
4564 gfc_array_index_type, size, unit);
4565 else
4566 bytesize = size;
4567
4568 *ptemp1 = NULL__null;
4569 tmp = gfc_do_allocate (bytesize, size, ptemp1, block, type);
4570
4571 if (*ptemp1)
4572 tmp = build_fold_indirect_ref_loc (input_location, tmp);
4573 return tmp;
4574}
4575
4576
4577/* Allocate temporary for forall construct according to the information in
4578 nested_forall_info. INNER_SIZE is the size of temporary needed in the
4579 assignment inside forall. PTEMP1 is returned for space free. */
4580
4581static tree
4582allocate_temp_for_forall_nest (forall_info * nested_forall_info, tree type,
4583 tree inner_size, stmtblock_t * inner_size_body,
4584 stmtblock_t * block, tree * ptemp1)
4585{
4586 tree size;
4587
4588 /* Calculate the total size of temporary needed in forall construct. */
4589 size = compute_overall_iter_number (nested_forall_info, inner_size,
4590 inner_size_body, block);
4591
4592 return allocate_temp_for_forall_nest_1 (type, size, block, ptemp1);
4593}
4594
4595
4596/* Handle assignments inside forall which need temporary.
4597
4598 forall (i=start:end:stride; maskexpr)
4599 e<i> = f<i>
4600 end forall
4601 (where e,f<i> are arbitrary expressions possibly involving i
4602 and there is a dependency between e<i> and f<i>)
4603 Translates to:
4604 masktmp(:) = maskexpr(:)
4605
4606 maskindex = 0;
4607 count1 = 0;
4608 num = 0;
4609 for (i = start; i <= end; i += stride)
4610 num += SIZE (f<i>)
4611 count1 = 0;
4612 ALLOCATE (tmp(num))
4613 for (i = start; i <= end; i += stride)
4614 {
4615 if (masktmp[maskindex++])
4616 tmp[count1++] = f<i>
4617 }
4618 maskindex = 0;
4619 count1 = 0;
4620 for (i = start; i <= end; i += stride)
4621 {
4622 if (masktmp[maskindex++])
4623 e<i> = tmp[count1++]
4624 }
4625 DEALLOCATE (tmp)
4626 */
4627static void
4628gfc_trans_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
4629 tree wheremask, bool invert,
4630 forall_info * nested_forall_info,
4631 stmtblock_t * block)
4632{
4633 tree type;
4634 tree inner_size;
4635 gfc_ss *lss, *rss;
4636 tree count, count1;
4637 tree tmp, tmp1;
4638 tree ptemp1;
4639 stmtblock_t inner_size_body;
4640
4641 /* Create vars. count1 is the current iterator number of the nested
4642 forall. */
4643 count1 = gfc_create_var (gfc_array_index_type, "count1");
4644
4645 /* Count is the wheremask index. */
4646 if (wheremask)
4647 {
4648 count = gfc_create_var (gfc_array_index_type, "count");
4649 gfc_add_modify (block, count, gfc_index_zero_nodegfc_rank_cst[0]);
4650 }
4651 else
4652 count = NULL__null;
4653
4654 /* Initialize count1. */
4655 gfc_add_modify (block, count1, gfc_index_zero_nodegfc_rank_cst[0]);
4656
4657 /* Calculate the size of temporary needed in the assignment. Return loop, lss
4658 and rss which are used in function generate_loop_for_rhs_to_temp(). */
4659 /* The type of LHS. Used in function allocate_temp_for_forall_nest */
4660 if (expr1->ts.type == BT_CHARACTER)
4661 {
4662 type = NULL__null;
4663 if (expr1->ref && expr1->ref->type == REF_SUBSTRING)
4664 {
4665 gfc_se ssse;
4666 gfc_init_se (&ssse, NULL__null);
4667 gfc_conv_expr (&ssse, expr1);
4668 type = gfc_get_character_type_len (gfc_default_character_kind,
4669 ssse.string_length);
4670 }
4671 else
4672 {
4673 if (!expr1->ts.u.cl->backend_decl)
4674 {
4675 gfc_se tse;
4676 gcc_assert (expr1->ts.u.cl->length)((void)(!(expr1->ts.u.cl->length) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 4676, __FUNCTION__), 0 : 0))
;
4677 gfc_init_se (&tse, NULL__null);
4678 gfc_conv_expr (&tse, expr1->ts.u.cl->length);
4679 expr1->ts.u.cl->backend_decl = tse.expr;
4680 }
4681 type = gfc_get_character_type_len (gfc_default_character_kind,
4682 expr1->ts.u.cl->backend_decl);
4683 }
4684 }
4685 else
4686 type = gfc_typenode_for_spec (&expr1->ts);
4687
4688 gfc_init_block (&inner_size_body);
4689 inner_size = compute_inner_temp_size (expr1, expr2, &inner_size_body,
4690 &lss, &rss);
4691
4692 /* Allocate temporary for nested forall construct according to the
4693 information in nested_forall_info and inner_size. */
4694 tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type, inner_size,
4695 &inner_size_body, block, &ptemp1);
4696
4697 /* Generate codes to copy rhs to the temporary . */
4698 tmp = generate_loop_for_rhs_to_temp (expr2, tmp1, count, count1, lss, rss,
4699 wheremask, invert);
4700
4701 /* Generate body and loops according to the information in
4702 nested_forall_info. */
4703 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
4704 gfc_add_expr_to_block (block, tmp);
4705
4706 /* Reset count1. */
4707 gfc_add_modify (block, count1, gfc_index_zero_nodegfc_rank_cst[0]);
4708
4709 /* Reset count. */
4710 if (wheremask)
4711 gfc_add_modify (block, count, gfc_index_zero_nodegfc_rank_cst[0]);
4712
4713 /* TODO: Second call to compute_inner_temp_size to initialize lss and
4714 rss; there must be a better way. */
4715 inner_size = compute_inner_temp_size (expr1, expr2, &inner_size_body,
4716 &lss, &rss);
4717
4718 /* Generate codes to copy the temporary to lhs. */
4719 tmp = generate_loop_for_temp_to_lhs (expr1, tmp1, count, count1,
4720 lss, rss,
4721 wheremask, invert);
4722
4723 /* Generate body and loops according to the information in
4724 nested_forall_info. */
4725 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
4726 gfc_add_expr_to_block (block, tmp);
4727
4728 if (ptemp1)
4729 {
4730 /* Free the temporary. */
4731 tmp = gfc_call_free (ptemp1);
4732 gfc_add_expr_to_block (block, tmp);
4733 }
4734}
4735
4736
4737/* Translate pointer assignment inside FORALL which need temporary. */
4738
4739static void
4740gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
4741 forall_info * nested_forall_info,
4742 stmtblock_t * block)
4743{
4744 tree type;
4745 tree inner_size;
4746 gfc_ss *lss, *rss;
4747 gfc_se lse;
4748 gfc_se rse;
4749 gfc_array_info *info;
4750 gfc_loopinfo loop;
4751 tree desc;
4752 tree parm;
4753 tree parmtype;
4754 stmtblock_t body;
4755 tree count;
4756 tree tmp, tmp1, ptemp1;
4757
4758 count = gfc_create_var (gfc_array_index_type, "count");
4759 gfc_add_modify (block, count, gfc_index_zero_nodegfc_rank_cst[0]);
4760
4761 inner_size = gfc_index_one_nodegfc_rank_cst[1];
4762 lss = gfc_walk_expr (expr1);
4763 rss = gfc_walk_expr (expr2);
4764 if (lss == gfc_ss_terminator)
4765 {
4766 type = gfc_typenode_for_spec (&expr1->ts);
4767 type = build_pointer_type (type);
4768
4769 /* Allocate temporary for nested forall construct according to the
4770 information in nested_forall_info and inner_size. */
4771 tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type,
4772 inner_size, NULL__null, block, &ptemp1);
4773 gfc_start_block (&body);
4774 gfc_init_se (&lse, NULL__null);
4775 lse.expr = gfc_build_array_ref (tmp1, count, NULL__null);
4776 gfc_init_se (&rse, NULL__null);
4777 rse.want_pointer = 1;
4778 gfc_conv_expr (&rse, expr2);
4779 gfc_add_block_to_block (&body, &rse.pre);
4780 gfc_add_modify (&body, lse.expr,
4781 fold_convert (TREE_TYPE (lse.expr), rse.expr)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(lse.expr), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 4781, __FUNCTION__))->typed.type), rse.expr)
);
4782 gfc_add_block_to_block (&body, &rse.post);
4783
4784 /* Increment count. */
4785 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4786 count, gfc_index_one_nodegfc_rank_cst[1]);
4787 gfc_add_modify (&body, count, tmp);
4788
4789 tmp = gfc_finish_block (&body);
4790
4791 /* Generate body and loops according to the information in
4792 nested_forall_info. */
4793 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
4794 gfc_add_expr_to_block (block, tmp);
4795
4796 /* Reset count. */
4797 gfc_add_modify (block, count, gfc_index_zero_nodegfc_rank_cst[0]);
4798
4799 gfc_start_block (&body);
4800 gfc_init_se (&lse, NULL__null);
4801 gfc_init_se (&rse, NULL__null);
4802 rse.expr = gfc_build_array_ref (tmp1, count, NULL__null);
4803 lse.want_pointer = 1;
4804 gfc_conv_expr (&lse, expr1);
4805 gfc_add_block_to_block (&body, &lse.pre);
4806 gfc_add_modify (&body, lse.expr, rse.expr);
4807 gfc_add_block_to_block (&body, &lse.post);
4808 /* Increment count. */
4809 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4810 count, gfc_index_one_nodegfc_rank_cst[1]);
4811 gfc_add_modify (&body, count, tmp);
4812 tmp = gfc_finish_block (&body);
4813
4814 /* Generate body and loops according to the information in
4815 nested_forall_info. */
4816 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
4817 gfc_add_expr_to_block (block, tmp);
4818 }
4819 else
4820 {
4821 gfc_init_loopinfo (&loop);
4822
4823 /* Associate the SS with the loop. */
4824 gfc_add_ss_to_loop (&loop, rss);
4825
4826 /* Setup the scalarizing loops and bounds. */
4827 gfc_conv_ss_startstride (&loop);
4828
4829 gfc_conv_loop_setup (&loop, &expr2->where);
4830
4831 info = &rss->info->data.array;
4832 desc = info->descriptor;
4833
4834 /* Make a new descriptor. */
4835 parmtype = gfc_get_element_type (TREE_TYPE (desc)((contains_struct_check ((desc), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 4835, __FUNCTION__))->typed.type)
);
4836 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, 0,
4837 loop.from, loop.to, 1,
4838 GFC_ARRAY_UNKNOWN, true);
4839
4840 /* Allocate temporary for nested forall construct. */
4841 tmp1 = allocate_temp_for_forall_nest (nested_forall_info, parmtype,
4842 inner_size, NULL__null, block, &ptemp1);
4843 gfc_start_block (&body);
4844 gfc_init_se (&lse, NULL__null);
4845 lse.expr = gfc_build_array_ref (tmp1, count, NULL__null);
4846 lse.direct_byref = 1;
4847 gfc_conv_expr_descriptor (&lse, expr2);
4848
4849 gfc_add_block_to_block (&body, &lse.pre);
4850 gfc_add_block_to_block (&body, &lse.post);
4851
4852 /* Increment count. */
4853 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4854 count, gfc_index_one_nodegfc_rank_cst[1]);
4855 gfc_add_modify (&body, count, tmp);
4856
4857 tmp = gfc_finish_block (&body);
4858
4859 /* Generate body and loops according to the information in
4860 nested_forall_info. */
4861 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
4862 gfc_add_expr_to_block (block, tmp);
4863
4864 /* Reset count. */
4865 gfc_add_modify (block, count, gfc_index_zero_nodegfc_rank_cst[0]);
4866
4867 parm = gfc_build_array_ref (tmp1, count, NULL__null);
4868 gfc_init_se (&lse, NULL__null);
4869 gfc_conv_expr_descriptor (&lse, expr1);
4870 gfc_add_modify (&lse.pre, lse.expr, parm);
4871 gfc_start_block (&body);
4872 gfc_add_block_to_block (&body, &lse.pre);
4873 gfc_add_block_to_block (&body, &lse.post);
4874
4875 /* Increment count. */
4876 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4877 count, gfc_index_one_nodegfc_rank_cst[1]);
4878 gfc_add_modify (&body, count, tmp);
4879
4880 tmp = gfc_finish_block (&body);
4881
4882 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
4883 gfc_add_expr_to_block (block, tmp);
4884 }
4885 /* Free the temporary. */
4886 if (ptemp1)
4887 {
4888 tmp = gfc_call_free (ptemp1);
4889 gfc_add_expr_to_block (block, tmp);
4890 }
4891}
4892
4893
4894/* FORALL and WHERE statements are really nasty, especially when you nest
4895 them. All the rhs of a forall assignment must be evaluated before the
4896 actual assignments are performed. Presumably this also applies to all the
4897 assignments in an inner where statement. */
4898
4899/* Generate code for a FORALL statement. Any temporaries are allocated as a
4900 linear array, relying on the fact that we process in the same order in all
4901 loops.
4902
4903 forall (i=start:end:stride; maskexpr)
4904 e<i> = f<i>
4905 g<i> = h<i>
4906 end forall
4907 (where e,f,g,h<i> are arbitrary expressions possibly involving i)
4908 Translates to:
4909 count = ((end + 1 - start) / stride)
4910 masktmp(:) = maskexpr(:)
4911
4912 maskindex = 0;
4913 for (i = start; i <= end; i += stride)
4914 {
4915 if (masktmp[maskindex++])
4916 e<i> = f<i>
4917 }
4918 maskindex = 0;
4919 for (i = start; i <= end; i += stride)
4920 {
4921 if (masktmp[maskindex++])
4922 g<i> = h<i>
4923 }
4924
4925 Note that this code only works when there are no dependencies.
4926 Forall loop with array assignments and data dependencies are a real pain,
4927 because the size of the temporary cannot always be determined before the
4928 loop is executed. This problem is compounded by the presence of nested
4929 FORALL constructs.
4930 */
4931
4932static tree
4933gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
4934{
4935 stmtblock_t pre;
4936 stmtblock_t post;
4937 stmtblock_t block;
4938 stmtblock_t body;
4939 tree *var;
4940 tree *start;
4941 tree *end;
4942 tree *step;
4943 gfc_expr **varexpr;
4944 tree tmp;
4945 tree assign;
4946 tree size;
4947 tree maskindex;
4948 tree mask;
4949 tree pmask;
4950 tree cycle_label = NULL_TREE(tree) __null;
4951 int n;
4952 int nvar;
4953 int need_temp;
4954 gfc_forall_iterator *fa;
4955 gfc_se se;
4956 gfc_code *c;
4957 gfc_saved_var *saved_vars;
4958 iter_info *this_forall;
4959 forall_info *info;
4960 bool need_mask;
4961
4962 /* Do nothing if the mask is false. */
4963 if (code->expr1
4964 && code->expr1->expr_type == EXPR_CONSTANT
4965 && !code->expr1->value.logical)
4966 return build_empty_stmt (input_location);
4967
4968 n = 0;
4969 /* Count the FORALL index number. */
4970 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
4971 n++;
4972 nvar = n;
4973
4974 /* Allocate the space for var, start, end, step, varexpr. */
4975 var = XCNEWVEC (tree, nvar)((tree *) xcalloc ((nvar), sizeof (tree)));
4976 start = XCNEWVEC (tree, nvar)((tree *) xcalloc ((nvar), sizeof (tree)));
4977 end = XCNEWVEC (tree, nvar)((tree *) xcalloc ((nvar), sizeof (tree)));
4978 step = XCNEWVEC (tree, nvar)((tree *) xcalloc ((nvar), sizeof (tree)));
4979 varexpr = XCNEWVEC (gfc_expr *, nvar)((gfc_expr * *) xcalloc ((nvar), sizeof (gfc_expr *)));
4980 saved_vars = XCNEWVEC (gfc_saved_var, nvar)((gfc_saved_var *) xcalloc ((nvar), sizeof (gfc_saved_var)));
4981
4982 /* Allocate the space for info. */
4983 info = XCNEW (forall_info)((forall_info *) xcalloc (1, sizeof (forall_info)));
4984
4985 gfc_start_block (&pre);
4986 gfc_init_block (&post);
4987 gfc_init_block (&block);
4988
4989 n = 0;
4990 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
4991 {
4992 gfc_symbol *sym = fa->var->symtree->n.sym;
4993
4994 /* Allocate space for this_forall. */
4995 this_forall = XCNEW (iter_info)((iter_info *) xcalloc (1, sizeof (iter_info)));
4996
4997 /* Create a temporary variable for the FORALL index. */
4998 tmp = gfc_typenode_for_spec (&sym->ts);
4999 var[n] = gfc_create_var (tmp, sym->name);
5000 gfc_shadow_sym (sym, var[n], &saved_vars[n]);
5001
5002 /* Record it in this_forall. */
5003 this_forall->var = var[n];
5004
5005 /* Replace the index symbol's backend_decl with the temporary decl. */
5006 sym->backend_decl = var[n];
5007
5008 /* Work out the start, end and stride for the loop. */
5009 gfc_init_se (&se, NULL__null);
5010 gfc_conv_expr_val (&se, fa->start);
5011 /* Record it in this_forall. */
5012 this_forall->start = se.expr;
5013 gfc_add_block_to_block (&block, &se.pre);
5014 start[n] = se.expr;
5015
5016 gfc_init_se (&se, NULL__null);
5017 gfc_conv_expr_val (&se, fa->end);
5018 /* Record it in this_forall. */
5019 this_forall->end = se.expr;
5020 gfc_make_safe_expr (&se);
5021 gfc_add_block_to_block (&block, &se.pre);
5022 end[n] = se.expr;
5023
5024 gfc_init_se (&se, NULL__null);
5025 gfc_conv_expr_val (&se, fa->stride);
5026 /* Record it in this_forall. */
5027 this_forall->step = se.expr;
5028 gfc_make_safe_expr (&se);
5029 gfc_add_block_to_block (&block, &se.pre);
5030 step[n] = se.expr;
5031
5032 /* Set the NEXT field of this_forall to NULL. */
5033 this_forall->next = NULL__null;
5034 /* Link this_forall to the info construct. */
5035 if (info->this_loop)
5036 {
5037 iter_info *iter_tmp = info->this_loop;
5038 while (iter_tmp->next != NULL__null)
5039 iter_tmp = iter_tmp->next;
5040 iter_tmp->next = this_forall;
5041 }
5042 else
5043 info->this_loop = this_forall;
5044
5045 n++;
5046 }
5047 nvar = n;
5048
5049 /* Calculate the size needed for the current forall level. */
5050 size = gfc_index_one_nodegfc_rank_cst[1];
5051 for (n = 0; n < nvar; n++)
5052 {
5053 /* size = (end + step - start) / step. */
5054 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (start[n])((contains_struct_check ((start[n]), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 5054, __FUNCTION__))->typed.type)
,
5055 step[n], start[n]);
5056 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (end[n])((contains_struct_check ((end[n]), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 5056, __FUNCTION__))->typed.type)
,
5057 end[n], tmp);
5058 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, TREE_TYPE (tmp)((contains_struct_check ((tmp), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 5058, __FUNCTION__))->typed.type)
,
5059 tmp, step[n]);
5060 tmp = convert (gfc_array_index_type, tmp);
5061
5062 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5063 size, tmp);
5064 }
5065
5066 /* Record the nvar and size of current forall level. */
5067 info->nvar = nvar;
5068 info->size = size;
5069
5070 if (code->expr1)
5071 {
5072 /* If the mask is .true., consider the FORALL unconditional. */
5073 if (code->expr1->expr_type == EXPR_CONSTANT
5074 && code->expr1->value.logical)
5075 need_mask = false;
5076 else
5077 need_mask = true;
5078 }
5079 else
5080 need_mask = false;
5081
5082 /* First we need to allocate the mask. */
5083 if (need_mask)
5084 {
5085 /* As the mask array can be very big, prefer compact boolean types. */
5086 tree mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind);
5087 mask = allocate_temp_for_forall_nest (nested_forall_info, mask_type,
5088 size, NULL__null, &block, &pmask);
5089 maskindex = gfc_create_var_np (gfc_array_index_type, "mi");
5090
5091 /* Record them in the info structure. */
5092 info->maskindex = maskindex;
5093 info->mask = mask;
5094 }
5095 else
5096 {
5097 /* No mask was specified. */
5098 maskindex = NULL_TREE(tree) __null;
5099 mask = pmask = NULL_TREE(tree) __null;
5100 }
5101
5102 /* Link the current forall level to nested_forall_info. */
5103 info->prev_nest = nested_forall_info;
5104 nested_forall_info = info;
5105
5106 /* Copy the mask into a temporary variable if required.
5107 For now we assume a mask temporary is needed. */
5108 if (need_mask)
5109 {
5110 /* As the mask array can be very big, prefer compact boolean types. */
5111 tree mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind);
5112
5113 gfc_add_modify (&block, maskindex, gfc_index_zero_nodegfc_rank_cst[0]);
5114
5115 /* Start of mask assignment loop body. */
5116 gfc_start_block (&body);
5117
5118 /* Evaluate the mask expression. */
5119 gfc_init_se (&se, NULL__null);
5120 gfc_conv_expr_val (&se, code->expr1);
5121 gfc_add_block_to_block (&body, &se.pre);
5122
5123 /* Store the mask. */
5124 se.expr = convert (mask_type, se.expr);
5125
5126 tmp = gfc_build_array_ref (mask, maskindex, NULL__null);
5127 gfc_add_modify (&body, tmp, se.expr);
5128
5129 /* Advance to the next mask element. */
5130 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5131 maskindex, gfc_index_one_nodegfc_rank_cst[1]);
5132 gfc_add_modify (&body, maskindex, tmp);
5133
5134 /* Generate the loops. */
5135 tmp = gfc_finish_block (&body);
5136 tmp = gfc_trans_nested_forall_loop (info, tmp, 0);
5137 gfc_add_expr_to_block (&block, tmp);
5138 }
5139
5140 if (code->op == EXEC_DO_CONCURRENT)
5141 {
5142 gfc_init_block (&body);
5143 cycle_label = gfc_build_label_decl (NULL_TREE(tree) __null);
5144 code->cycle_label = cycle_label;
5145 tmp = gfc_trans_code (code->block->next);
5146 gfc_add_expr_to_block (&body, tmp);
5147
5148 if (TREE_USED (cycle_label)((cycle_label)->base.used_flag))
5149 {
5150 tmp = build1_v (LABEL_EXPR, cycle_label)fold_build1_loc (input_location, LABEL_EXPR, global_trees[TI_VOID_TYPE
], cycle_label)
;
5151 gfc_add_expr_to_block (&body, tmp);
5152 }
5153
5154 tmp = gfc_finish_block (&body);
5155 nested_forall_info->do_concurrent = true;
5156 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
5157 gfc_add_expr_to_block (&block, tmp);
5158 goto done;
5159 }
5160
5161 c = code->block->next;
5162
5163 /* TODO: loop merging in FORALL statements. */
5164 /* Now that we've got a copy of the mask, generate the assignment loops. */
5165 while (c)
5166 {
5167 switch (c->op)
5168 {
5169 case EXEC_ASSIGN:
5170 /* A scalar or array assignment. DO the simple check for
5171 lhs to rhs dependencies. These make a temporary for the
5172 rhs and form a second forall block to copy to variable. */
5173 need_temp = check_forall_dependencies(c, &pre, &post);
5174
5175 /* Temporaries due to array assignment data dependencies introduce
5176 no end of problems. */
5177 if (need_temp || flag_test_forall_tempglobal_options.x_flag_test_forall_temp)
5178 gfc_trans_assign_need_temp (c->expr1, c->expr2, NULL__null, false,
5179 nested_forall_info, &block);
5180 else
5181 {
5182 /* Use the normal assignment copying routines. */
5183 assign = gfc_trans_assignment (c->expr1, c->expr2, false, true);
5184
5185 /* Generate body and loops. */
5186 tmp = gfc_trans_nested_forall_loop (nested_forall_info,
5187 assign, 1);
5188 gfc_add_expr_to_block (&block, tmp);
5189 }
5190
5191 /* Cleanup any temporary symtrees that have been made to deal
5192 with dependencies. */
5193 if (new_symtree)
5194 cleanup_forall_symtrees (c);
5195
5196 break;
5197
5198 case EXEC_WHERE:
5199 /* Translate WHERE or WHERE construct nested in FORALL. */
5200 gfc_trans_where_2 (c, NULL__null, false, nested_forall_info, &block);
5201 break;
5202
5203 /* Pointer assignment inside FORALL. */
5204 case EXEC_POINTER_ASSIGN:
5205 need_temp = gfc_check_dependency (c->expr1, c->expr2, 0);
5206 /* Avoid cases where a temporary would never be needed and where
5207 the temp code is guaranteed to fail. */
5208 if (need_temp
5209 || (flag_test_forall_tempglobal_options.x_flag_test_forall_temp
5210 && c->expr2->expr_type != EXPR_CONSTANT
5211 && c->expr2->expr_type != EXPR_NULL))
5212 gfc_trans_pointer_assign_need_temp (c->expr1, c->expr2,
5213 nested_forall_info, &block);
5214 else
5215 {
5216 /* Use the normal assignment copying routines. */
5217 assign = gfc_trans_pointer_assignment (c->expr1, c->expr2);
5218
5219 /* Generate body and loops. */
5220 tmp = gfc_trans_nested_forall_loop (nested_forall_info,
5221 assign, 1);
5222 gfc_add_expr_to_block (&block, tmp);
5223 }
5224 break;
5225
5226 case EXEC_FORALL:
5227 tmp = gfc_trans_forall_1 (c, nested_forall_info);
5228 gfc_add_expr_to_block (&block, tmp);
5229 break;
5230
5231 /* Explicit subroutine calls are prevented by the frontend but interface
5232 assignments can legitimately produce them. */
5233 case EXEC_ASSIGN_CALL:
5234 assign = gfc_trans_call (c, true, NULL_TREE(tree) __null, NULL_TREE(tree) __null, false);
5235 tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1);
5236 gfc_add_expr_to_block (&block, tmp);
5237 break;
5238
5239 default:
5240 gcc_unreachable ()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 5240, __FUNCTION__))
;
5241 }
5242
5243 c = c->next;
5244 }
5245
5246done:
5247 /* Restore the original index variables. */
5248 for (fa = code->ext.forall_iterator, n = 0; fa; fa = fa->next, n++)
5249 gfc_restore_sym (fa->var->symtree->n.sym, &saved_vars[n]);
5250
5251 /* Free the space for var, start, end, step, varexpr. */
5252 free (var);
5253 free (start);
5254 free (end);
5255 free (step);
5256 free (varexpr);
5257 free (saved_vars);
5258
5259 for (this_forall = info->this_loop; this_forall;)
5260 {
5261 iter_info *next = this_forall->next;
5262 free (this_forall);
5263 this_forall = next;
5264 }
5265
5266 /* Free the space for this forall_info. */
5267 free (info);
5268
5269 if (pmask)
5270 {
5271 /* Free the temporary for the mask. */
5272 tmp = gfc_call_free (pmask);
5273 gfc_add_expr_to_block (&block, tmp);
5274 }
5275 if (maskindex)
5276 pushdecl (maskindex);
5277
5278 gfc_add_block_to_block (&pre, &block);
5279 gfc_add_block_to_block (&pre, &post);
5280
5281 return gfc_finish_block (&pre);
5282}
5283
5284
5285/* Translate the FORALL statement or construct. */
5286
5287tree gfc_trans_forall (gfc_code * code)
5288{
5289 return gfc_trans_forall_1 (code, NULL__null);
5290}
5291
5292
5293/* Translate the DO CONCURRENT construct. */
5294
5295tree gfc_trans_do_concurrent (gfc_code * code)
5296{
5297 return gfc_trans_forall_1 (code, NULL__null);
5298}
5299
5300
5301/* Evaluate the WHERE mask expression, copy its value to a temporary.
5302 If the WHERE construct is nested in FORALL, compute the overall temporary
5303 needed by the WHERE mask expression multiplied by the iterator number of
5304 the nested forall.
5305 ME is the WHERE mask expression.
5306 MASK is the current execution mask upon input, whose sense may or may
5307 not be inverted as specified by the INVERT argument.
5308 CMASK is the updated execution mask on output, or NULL if not required.
5309 PMASK is the pending execution mask on output, or NULL if not required.
5310 BLOCK is the block in which to place the condition evaluation loops. */
5311
5312static void
5313gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info,
5314 tree mask, bool invert, tree cmask, tree pmask,
5315 tree mask_type, stmtblock_t * block)
5316{
5317 tree tmp, tmp1;
5318 gfc_ss *lss, *rss;
5319 gfc_loopinfo loop;
5320 stmtblock_t body, body1;
5321 tree count, cond, mtmp;
5322 gfc_se lse, rse;
5323
5324 gfc_init_loopinfo (&loop);
5325
5326 lss = gfc_walk_expr (me);
5327 rss = gfc_walk_expr (me);
5328
5329 /* Variable to index the temporary. */
5330 count = gfc_create_var (gfc_array_index_type, "count");
5331 /* Initialize count. */
5332 gfc_add_modify (block, count, gfc_index_zero_nodegfc_rank_cst[0]);
5333
5334 gfc_start_block (&body);
5335
5336 gfc_init_se (&rse, NULL__null);
5337 gfc_init_se (&lse, NULL__null);
5338
5339 if (lss == gfc_ss_terminator)
5340 {
5341 gfc_init_block (&body1);
5342 }
5343 else
5344 {
5345 /* Initialize the loop. */
5346 gfc_init_loopinfo (&loop);
5347
5348 /* We may need LSS to determine the shape of the expression. */
5349 gfc_add_ss_to_loop (&loop, lss);
5350 gfc_add_ss_to_loop (&loop, rss);
5351
5352 gfc_conv_ss_startstride (&loop);
5353 gfc_conv_loop_setup (&loop, &me->where);
5354
5355 gfc_mark_ss_chain_used (rss, 1);
5356 /* Start the loop body. */
5357 gfc_start_scalarized_body (&loop, &body1);
5358
5359 /* Translate the expression. */
5360 gfc_copy_loopinfo_to_se (&rse, &loop);
5361 rse.ss = rss;
5362 gfc_conv_expr (&rse, me);
5363 }
5364
5365 /* Variable to evaluate mask condition. */
5366 cond = gfc_create_var (mask_type, "cond");
5367 if (mask && (cmask || pmask))
5368 mtmp = gfc_create_var (mask_type, "mask");
5369 else mtmp = NULL_TREE(tree) __null;
5370
5371 gfc_add_block_to_block (&body1, &lse.pre);
5372 gfc_add_block_to_block (&body1, &rse.pre);
5373
5374 gfc_add_modify (&body1, cond, fold_convert (mask_type, rse.expr)fold_convert_loc (((location_t) 0), mask_type, rse.expr));
5375
5376 if (mask && (cmask || pmask))
5377 {
5378 tmp = gfc_build_array_ref (mask, count, NULL__null);
5379 if (invert)
5380 tmp = fold_build1_loc (input_location, TRUTH_NOT_EXPR, mask_type, tmp);
5381 gfc_add_modify (&body1, mtmp, tmp);
5382 }
5383
5384 if (cmask)
5385 {
5386 tmp1 = gfc_build_array_ref (cmask, count, NULL__null);
5387 tmp = cond;
5388 if (mask)
5389 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, mask_type,
5390 mtmp, tmp);
5391 gfc_add_modify (&body1, tmp1, tmp);
5392 }
5393
5394 if (pmask)
5395 {
5396 tmp1 = gfc_build_array_ref (pmask, count, NULL__null);
5397 tmp = fold_build1_loc (input_location, TRUTH_NOT_EXPR, mask_type, cond);
5398 if (mask)
5399 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, mask_type, mtmp,
5400 tmp);
5401 gfc_add_modify (&body1, tmp1, tmp);
5402 }
5403
5404 gfc_add_block_to_block (&body1, &lse.post);
5405 gfc_add_block_to_block (&body1, &rse.post);
5406
5407 if (lss == gfc_ss_terminator)
5408 {
5409 gfc_add_block_to_block (&body, &body1);
5410 }
5411 else
5412 {
5413 /* Increment count. */
5414 tmp1 = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5415 count, gfc_index_one_nodegfc_rank_cst[1]);
5416 gfc_add_modify (&body1, count, tmp1);
5417
5418 /* Generate the copying loops. */
5419 gfc_trans_scalarizing_loops (&loop, &body1);
5420
5421 gfc_add_block_to_block (&body, &loop.pre);
5422 gfc_add_block_to_block (&body, &loop.post);
5423
5424 gfc_cleanup_loop (&loop);
5425 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
5426 as tree nodes in SS may not be valid in different scope. */
5427 }
5428
5429 tmp1 = gfc_finish_block (&body);
5430 /* If the WHERE construct is inside FORALL, fill the full temporary. */
5431 if (nested_forall_info != NULL__null)
5432 tmp1 = gfc_trans_nested_forall_loop (nested_forall_info, tmp1, 1);
5433
5434 gfc_add_expr_to_block (block, tmp1);
5435}
5436
5437
5438/* Translate an assignment statement in a WHERE statement or construct
5439 statement. The MASK expression is used to control which elements
5440 of EXPR1 shall be assigned. The sense of MASK is specified by
5441 INVERT. */
5442
5443static tree
5444gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2,
5445 tree mask, bool invert,
5446 tree count1, tree count2,
5447 gfc_code *cnext)
5448{
5449 gfc_se lse;
5450 gfc_se rse;
5451 gfc_ss *lss;
5452 gfc_ss *lss_section;
5453 gfc_ss *rss;
5454
5455 gfc_loopinfo loop;
5456 tree tmp;
5457 stmtblock_t block;
5458 stmtblock_t body;
5459 tree index, maskexpr;
5460
5461 /* A defined assignment. */
5462 if (cnext && cnext->resolved_sym)
5463 return gfc_trans_call (cnext, true, mask, count1, invert);
5464
5465#if 0
5466 /* TODO: handle this special case.
5467 Special case a single function returning an array. */
5468 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
5469 {
5470 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
5471 if (tmp)
5472 return tmp;
5473 }
5474#endif
5475
5476 /* Assignment of the form lhs = rhs. */
5477 gfc_start_block (&block);
5478
5479 gfc_init_se (&lse, NULL__null);
5480 gfc_init_se (&rse, NULL__null);
5481
5482 /* Walk the lhs. */
5483 lss = gfc_walk_expr (expr1);
5484 rss = NULL__null;
5485
5486 /* In each where-assign-stmt, the mask-expr and the variable being
5487 defined shall be arrays of the same shape. */
5488 gcc_assert (lss != gfc_ss_terminator)((void)(!(lss != gfc_ss_terminator) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 5488, __FUNCTION__), 0 : 0))
;
5489
5490 /* The assignment needs scalarization. */
5491 lss_section = lss;
5492
5493 /* Find a non-scalar SS from the lhs. */
5494 while (lss_section != gfc_ss_terminator
5495 && lss_section->info->type != GFC_SS_SECTION)
5496 lss_section = lss_section->next;
5497
5498 gcc_assert (lss_section != gfc_ss_terminator)((void)(!(lss_section != gfc_ss_terminator) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 5498, __FUNCTION__), 0 : 0))
;
5499
5500 /* Initialize the scalarizer. */
5501 gfc_init_loopinfo (&loop);
5502
5503 /* Walk the rhs. */
5504 rss = gfc_walk_expr (expr2);
5505 if (rss == gfc_ss_terminator)
5506 {
5507 /* The rhs is scalar. Add a ss for the expression. */
5508 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
5509 rss->info->where = 1;
5510 }
5511
5512 /* Associate the SS with the loop. */
5513 gfc_add_ss_to_loop (&loop, lss);
5514 gfc_add_ss_to_loop (&loop, rss);
5515
5516 /* Calculate the bounds of the scalarization. */
5517 gfc_conv_ss_startstride (&loop);
5518
5519 /* Resolve any data dependencies in the statement. */
5520 gfc_conv_resolve_dependencies (&loop, lss_section, rss);
5521
5522 /* Setup the scalarizing loops. */
5523 gfc_conv_loop_setup (&loop, &expr2->where);
5524
5525 /* Setup the gfc_se structures. */
5526 gfc_copy_loopinfo_to_se (&lse, &loop);
5527 gfc_copy_loopinfo_to_se (&rse, &loop);
5528
5529 rse.ss = rss;
5530 gfc_mark_ss_chain_used (rss, 1);
5531 if (loop.temp_ss == NULL__null)
5532 {
5533 lse.ss = lss;
5534 gfc_mark_ss_chain_used (lss, 1);
5535 }
5536 else
5537 {
5538 lse.ss = loop.temp_ss;
5539 gfc_mark_ss_chain_used (lss, 3);
5540 gfc_mark_ss_chain_used (loop.temp_ss, 3);
5541 }
5542
5543 /* Start the scalarized loop body. */
5544 gfc_start_scalarized_body (&loop, &body);
5545
5546 /* Translate the expression. */
5547 gfc_conv_expr (&rse, expr2);
5548 if (lss != gfc_ss_terminator && loop.temp_ss != NULL__null)
5549 gfc_conv_tmp_array_ref (&lse);
5550 else
5551 gfc_conv_expr (&lse, expr1);
5552
5553 /* Form the mask expression according to the mask. */
5554 index = count1;
5555 maskexpr = gfc_build_array_ref (mask, index, NULL__null);
5556 if (invert)
5557 maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
5558 TREE_TYPE (maskexpr)((contains_struct_check ((maskexpr), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 5558, __FUNCTION__))->typed.type)
, maskexpr);
5559
5560 /* Use the scalar assignment as is. */
5561 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
5562 false, loop.temp_ss == NULL__null);
5563
5564 tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt (input_location))fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], maskexpr, tmp, build_empty_stmt (input_location))
;
5565
5566 gfc_add_expr_to_block (&body, tmp);
5567
5568 if (lss == gfc_ss_terminator)
5569 {
5570 /* Increment count1. */
5571 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5572 count1, gfc_index_one_nodegfc_rank_cst[1]);
5573 gfc_add_modify (&body, count1, tmp);
5574
5575 /* Use the scalar assignment as is. */
5576 gfc_add_block_to_block (&block, &body);
5577 }
5578 else
5579 {
5580 gcc_assert (lse.ss == gfc_ss_terminator((void)(!(lse.ss == gfc_ss_terminator && rse.ss == gfc_ss_terminator
) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 5581, __FUNCTION__), 0 : 0))
5581 && rse.ss == gfc_ss_terminator)((void)(!(lse.ss == gfc_ss_terminator && rse.ss == gfc_ss_terminator
) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 5581, __FUNCTION__), 0 : 0))
;
5582
5583 if (loop.temp_ss != NULL__null)
5584 {
5585 /* Increment count1 before finish the main body of a scalarized
5586 expression. */
5587 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5588 gfc_array_index_type, count1, gfc_index_one_nodegfc_rank_cst[1]);
5589 gfc_add_modify (&body, count1, tmp);
5590 gfc_trans_scalarized_loop_boundary (&loop, &body);
5591
5592 /* We need to copy the temporary to the actual lhs. */
5593 gfc_init_se (&lse, NULL__null);
5594 gfc_init_se (&rse, NULL__null);
5595 gfc_copy_loopinfo_to_se (&lse, &loop);
5596 gfc_copy_loopinfo_to_se (&rse, &loop);
5597
5598 rse.ss = loop.temp_ss;
5599 lse.ss = lss;
5600
5601 gfc_conv_tmp_array_ref (&rse);
5602 gfc_conv_expr (&lse, expr1);
5603
5604 gcc_assert (lse.ss == gfc_ss_terminator((void)(!(lse.ss == gfc_ss_terminator && rse.ss == gfc_ss_terminator
) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 5605, __FUNCTION__), 0 : 0))
5605 && rse.ss == gfc_ss_terminator)((void)(!(lse.ss == gfc_ss_terminator && rse.ss == gfc_ss_terminator
) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 5605, __FUNCTION__), 0 : 0))
;
5606
5607 /* Form the mask expression according to the mask tree list. */
5608 index = count2;
5609 maskexpr = gfc_build_array_ref (mask, index, NULL__null);
5610 if (invert)
5611 maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
5612 TREE_TYPE (maskexpr)((contains_struct_check ((maskexpr), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 5612, __FUNCTION__))->typed.type)
, maskexpr);
5613
5614 /* Use the scalar assignment as is. */
5615 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, true);
5616 tmp = build3_v (COND_EXPR, maskexpr, tmp,fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], maskexpr, tmp, build_empty_stmt (input_location))
5617 build_empty_stmt (input_location))fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], maskexpr, tmp, build_empty_stmt (input_location))
;
5618 gfc_add_expr_to_block (&body, tmp);
5619
5620 /* Increment count2. */
5621 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5622 gfc_array_index_type, count2,
5623 gfc_index_one_nodegfc_rank_cst[1]);
5624 gfc_add_modify (&body, count2, tmp);
5625 }
5626 else
5627 {
5628 /* Increment count1. */
5629 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5630 gfc_array_index_type, count1,
5631 gfc_index_one_nodegfc_rank_cst[1]);
5632 gfc_add_modify (&body, count1, tmp);
5633 }
5634
5635 /* Generate the copying loops. */
5636 gfc_trans_scalarizing_loops (&loop, &body);
5637
5638 /* Wrap the whole thing up. */
5639 gfc_add_block_to_block (&block, &loop.pre);
5640 gfc_add_block_to_block (&block, &loop.post);
5641 gfc_cleanup_loop (&loop);
5642 }
5643
5644 return gfc_finish_block (&block);
5645}
5646
5647
5648/* Translate the WHERE construct or statement.
5649 This function can be called iteratively to translate the nested WHERE
5650 construct or statement.
5651 MASK is the control mask. */
5652
5653static void
5654gfc_trans_where_2 (gfc_code * code, tree mask, bool invert,
5655 forall_info * nested_forall_info, stmtblock_t * block)
5656{
5657 stmtblock_t inner_size_body;
5658 tree inner_size, size;
5659 gfc_ss *lss, *rss;
5660 tree mask_type;
5661 gfc_expr *expr1;
5662 gfc_expr *expr2;
5663 gfc_code *cblock;
5664 gfc_code *cnext;
5665 tree tmp;
5666 tree cond;
5667 tree count1, count2;
5668 bool need_cmask;
5669 bool need_pmask;
5670 int need_temp;
5671 tree pcmask = NULL_TREE(tree) __null;
5672 tree ppmask = NULL_TREE(tree) __null;
5673 tree cmask = NULL_TREE(tree) __null;
5674 tree pmask = NULL_TREE(tree) __null;
5675 gfc_actual_arglist *arg;
5676
5677 /* the WHERE statement or the WHERE construct statement. */
5678 cblock = code->block;
5679
5680 /* As the mask array can be very big, prefer compact boolean types. */
5681 mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind);
5682
5683 /* Determine which temporary masks are needed. */
5684 if (!cblock->block)
5685 {
5686 /* One clause: No ELSEWHEREs. */
5687 need_cmask = (cblock->next != 0);
5688 need_pmask = false;
5689 }
5690 else if (cblock->block->block)
5691 {
5692 /* Three or more clauses: Conditional ELSEWHEREs. */
5693 need_cmask = true;
5694 need_pmask = true;
5695 }
5696 else if (cblock->next)
5697 {
5698 /* Two clauses, the first non-empty. */
5699 need_cmask = true;
5700 need_pmask = (mask != NULL_TREE(tree) __null
5701 && cblock->block->next != 0);
5702 }
5703 else if (!cblock->block->next)
5704 {
5705 /* Two clauses, both empty. */
5706 need_cmask = false;
5707 need_pmask = false;
5708 }
5709 /* Two clauses, the first empty, the second non-empty. */
5710 else if (mask)
5711 {
5712 need_cmask = (cblock->block->expr1 != 0);
5713 need_pmask = true;
5714 }
5715 else
5716 {
5717 need_cmask = true;
5718 need_pmask = false;
5719 }
5720
5721 if (need_cmask || need_pmask)
5722 {
5723 /* Calculate the size of temporary needed by the mask-expr. */
5724 gfc_init_block (&inner_size_body);
5725 inner_size = compute_inner_temp_size (cblock->expr1, cblock->expr1,
5726 &inner_size_body, &lss, &rss);
5727
5728 gfc_free_ss_chain (lss);
5729 gfc_free_ss_chain (rss);
5730
5731 /* Calculate the total size of temporary needed. */
5732 size = compute_overall_iter_number (nested_forall_info, inner_size,
5733 &inner_size_body, block);
5734
5735 /* Check whether the size is negative. */
5736 cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, size,
5737 gfc_index_zero_nodegfc_rank_cst[0]);
5738 size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
5739 cond, gfc_index_zero_nodegfc_rank_cst[0], size);
5740 size = gfc_evaluate_now (size, block);
5741
5742 /* Allocate temporary for WHERE mask if needed. */
5743 if (need_cmask)
5744 cmask = allocate_temp_for_forall_nest_1 (mask_type, size, block,
5745 &pcmask);
5746
5747 /* Allocate temporary for !mask if needed. */
5748 if (need_pmask)
5749 pmask = allocate_temp_for_forall_nest_1 (mask_type, size, block,
5750 &ppmask);
5751 }
5752
5753 while (cblock)
5754 {
5755 /* Each time around this loop, the where clause is conditional
5756 on the value of mask and invert, which are updated at the
5757 bottom of the loop. */
5758
5759 /* Has mask-expr. */
5760 if (cblock->expr1)
5761 {
5762 /* Ensure that the WHERE mask will be evaluated exactly once.
5763 If there are no statements in this WHERE/ELSEWHERE clause,
5764 then we don't need to update the control mask (cmask).
5765 If this is the last clause of the WHERE construct, then
5766 we don't need to update the pending control mask (pmask). */
5767 if (mask)
5768 gfc_evaluate_where_mask (cblock->expr1, nested_forall_info,
5769 mask, invert,
5770 cblock->next ? cmask : NULL_TREE(tree) __null,
5771 cblock->block ? pmask : NULL_TREE(tree) __null,
5772 mask_type, block);
5773 else
5774 gfc_evaluate_where_mask (cblock->expr1, nested_forall_info,
5775 NULL_TREE(tree) __null, false,
5776 (cblock->next || cblock->block)
5777 ? cmask : NULL_TREE(tree) __null,
5778 NULL_TREE(tree) __null, mask_type, block);
5779
5780 invert = false;
5781 }
5782 /* It's a final elsewhere-stmt. No mask-expr is present. */
5783 else
5784 cmask = mask;
5785
5786 /* The body of this where clause are controlled by cmask with
5787 sense specified by invert. */
5788
5789 /* Get the assignment statement of a WHERE statement, or the first
5790 statement in where-body-construct of a WHERE construct. */
5791 cnext = cblock->next;
5792 while (cnext)
5793 {
5794 switch (cnext->op)
5795 {
5796 /* WHERE assignment statement. */
5797 case EXEC_ASSIGN_CALL:
5798
5799 arg = cnext->ext.actual;
5800 expr1 = expr2 = NULL__null;
5801 for (; arg; arg = arg->next)
5802 {
5803 if (!arg->expr)
5804 continue;
5805 if (expr1 == NULL__null)
5806 expr1 = arg->expr;
5807 else
5808 expr2 = arg->expr;
5809 }
5810 goto evaluate;
5811
5812 case EXEC_ASSIGN:
5813 expr1 = cnext->expr1;
5814 expr2 = cnext->expr2;
5815 evaluate:
5816 if (nested_forall_info != NULL__null)
5817 {
5818 need_temp = gfc_check_dependency (expr1, expr2, 0);
5819 if ((need_temp || flag_test_forall_tempglobal_options.x_flag_test_forall_temp)
5820 && cnext->op != EXEC_ASSIGN_CALL)
5821 gfc_trans_assign_need_temp (expr1, expr2,
5822 cmask, invert,
5823 nested_forall_info, block);
5824 else
5825 {
5826 /* Variables to control maskexpr. */
5827 count1 = gfc_create_var (gfc_array_index_type, "count1");
5828 count2 = gfc_create_var (gfc_array_index_type, "count2");
5829 gfc_add_modify (block, count1, gfc_index_zero_nodegfc_rank_cst[0]);
5830 gfc_add_modify (block, count2, gfc_index_zero_nodegfc_rank_cst[0]);
5831
5832 tmp = gfc_trans_where_assign (expr1, expr2,
5833 cmask, invert,
5834 count1, count2,
5835 cnext);
5836
5837 tmp = gfc_trans_nested_forall_loop (nested_forall_info,
5838 tmp, 1);
5839 gfc_add_expr_to_block (block, tmp);
5840 }
5841 }
5842 else
5843 {
5844 /* Variables to control maskexpr. */
5845 count1 = gfc_create_var (gfc_array_index_type, "count1");
5846 count2 = gfc_create_var (gfc_array_index_type, "count2");
5847 gfc_add_modify (block, count1, gfc_index_zero_nodegfc_rank_cst[0]);
5848 gfc_add_modify (block, count2, gfc_index_zero_nodegfc_rank_cst[0]);
5849
5850 tmp = gfc_trans_where_assign (expr1, expr2,
5851 cmask, invert,
5852 count1, count2,
5853 cnext);
5854 gfc_add_expr_to_block (block, tmp);
5855
5856 }
5857 break;
5858
5859 /* WHERE or WHERE construct is part of a where-body-construct. */
5860 case EXEC_WHERE:
5861 gfc_trans_where_2 (cnext, cmask, invert,
5862 nested_forall_info, block);
5863 break;
5864
5865 default:
5866 gcc_unreachable ()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-stmt.c"
, 5866, __FUNCTION__))
;
5867 }
5868
5869 /* The next statement within the same where-body-construct. */
5870 cnext = cnext->next;
5871 }
5872 /* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt. */
5873 cblock = cblock->block;
5874 if (mask == NULL_TREE(tree) __null)
5875 {
5876 /* If we're the initial WHERE, we can simply invert the sense
5877 of the current mask to obtain the "mask" for the remaining
5878 ELSEWHEREs. */
5879 invert = true;
5880 mask = cmask;
5881 }
5882 else
5883 {
5884 /* Otherwise, for nested WHERE's we need to use the pending mask. */
5885 invert = false;
5886 mask = pmask;
5887 }
5888 }
5889
5890 /* If we allocated a pending mask array, deallocate it now. */
5891 if (ppmask)
5892 {
5893 tmp = gfc_call_free (ppmask);
5894 gfc_add_expr_to_block (block, tmp);
5895 }
5896
5897 /* If we allocated a current mask array, deallocate it now. */
5898 if (pcmask)
5899 {
5900 tmp = gfc_call_free (pcmask);
5901 gfc_add_expr_to_block (block, tmp);
5902 }
5903}
5904
5905/* Translate a simple WHERE construct or statement without dependencies.
5906 CBLOCK is the "then" clause of the WHERE statement, where CBLOCK->EXPR
5907 is the mask condition, and EBLOCK if non-NULL is the "else" clause.
5908 Currently both CBLOCK and EBLOCK are restricted to single assignments. */
5909
5910static tree
5911gfc_trans_where_3 (gfc_code * cblock, gfc_code * eblock)
5912{
5913 stmtblock_t block, body;
5914 gfc_expr *cond, *tdst, *tsrc, *edst, *esrc;
5915 tree tmp, cexpr, tstmt, estmt;
5916 gfc_ss *css, *tdss, *tsss;
5917 gfc_se cse, tdse, tsse, edse, esse;
5918 gfc_loopinfo loop;
5919 gfc_ss *edss = 0;
5920 gfc_ss *esss = 0;
5921 bool maybe_workshare = false;
5922
5923 /* Allow the scalarizer to workshare simple where loops. */
5924 if ((ompws_flags & (OMPWS_WORKSHARE_FLAG1 | OMPWS_SCALARIZER_BODY8))
5925 == OMPWS_WORKSHARE_FLAG1)
5926 {
5927 maybe_workshare = true;
5928 ompws_flags |= OMPWS_SCALARIZER_WS4 | OMPWS_SCALARIZER_BODY8;
5929 }
5930
5931 cond = cblock->expr1;
5932 tdst = cblock->next->expr1;
5933 tsrc = cblock->next->expr2;
5934 edst = eblock ? eblock->next->expr1 : NULL__null;
5935 esrc = eblock ? eblock->next->expr2 : NULL__null;
5936
5937 gfc_start_block (&block);
5938 gfc_init_loopinfo (&loop);
5939
5940 /* Handle the condition. */
5941 gfc_init_se (&cse, NULL__null);
5942 css = gfc_walk_expr (cond);
5943 gfc_add_ss_to_loop (&loop, css);
5944
5945 /* Handle the then-clause. */
5946 gfc_init_se (&tdse, NULL__null);
5947 gfc_init_se (&tsse, NULL__null);
5948 tdss = gfc_walk_expr (tdst);
5949 tsss = gfc_walk_expr (tsrc);
5950 if (tsss == gfc_ss_terminator)
5951 {
5952 tsss = gfc_get_scalar_ss (gfc_ss_terminator, tsrc);
5953 tsss->info->where = 1;
5954 }
5955 gfc_add_ss_to_loop (&loop, tdss);
5956 gfc_add_ss_to_loop (&loop, tsss);
5957
5958 if (eblock)
5959 {
5960 /* Handle the else clause. */
5961 gfc_init_se (&edse, NULL__null);
5962 gfc_init_se (&esse, NULL__null);
5963 edss = gfc_walk_expr (edst);
5964 esss = gfc_walk_expr (esrc);
5965 if (esss == gfc_ss_terminator)
5966 {
5967 esss = gfc_get_scalar_ss (gfc_ss_terminator, esrc);
5968 esss->info->where = 1;
5969 }
5970 gfc_add_ss_to_loop (&loop, edss);
5971 gfc_add_ss_to_loop (&loop, esss);
5972 }
5973
5974 gfc_conv_ss_startstride (&loop);
5975 gfc_conv_loop_setup (&loop, &tdst->where);
5976
5977 gfc_mark_ss_chain_used (css, 1);
5978 gfc_mark_ss_chain_used (tdss, 1);
5979 gfc_mark_ss_chain_used (tsss, 1);
5980 if (eblock)
5981 {
5982 gfc_mark_ss_chain_used (edss, 1);
5983 gfc_mark_ss_chain_used (esss, 1);
5984 }
5985
5986 gfc_start_scalarized_body (&loop, &body);
5987
5988 gfc_copy_loopinfo_to_se (&cse, &loop);
5989 gfc_copy_loopinfo_to_se (&tdse, &loop);
5990 gfc_copy_loopinfo_to_se (&tsse, &loop);
5991 cse.ss = css;
5992 tdse.ss = tdss;
5993 tsse.ss = tsss;
5994 if (eblock)
5995 {
5996 gfc_copy_loopinfo_to_se (&edse, &loop);
5997 gfc_copy_loopinfo_to_se (&esse, &loop);
5998 edse.ss = edss;
5999 esse.ss = esss;
6000 }
6001
6002 gfc_conv_expr (&cse, cond);
6003 gfc_add_block_to_block (&body, &cse.pre);
6004 cexpr = cse.expr;
6005
6006 gfc_conv_expr (&tsse, tsrc);
6007 if (tdss != gfc_ss_terminator && loop.temp_ss != NULL__null)
6008 gfc_conv_tmp_array_ref (&tdse);
6009 else
6010 gfc_conv_expr (&tdse, tdst);
6011
6012 if (eblock)
6013 {
6014 gfc_conv_expr (&esse, esrc);
6015 if (edss != gfc_ss_terminator && loop.temp_ss != NULL__null)
6016 gfc_conv_tmp_array_ref (&edse);
6017 else
6018 gfc_conv_expr (&edse, edst);
6019 }
6020
6021 tstmt = gfc_trans_scalar_assign (&tdse, &tsse, tdst->ts, false, true);
6022 estmt = eblock ? gfc_trans_scalar_assign (&edse, &esse, edst->ts,
6023 false, true)
6024 : build_empty_stmt (input_location);
6025 tmp = build3_v (COND_EXPR, cexpr, tstmt, estmt)fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], cexpr, tstmt, estmt)
;
6026 gfc_add_expr_to_block (&body, tmp);
6027 gfc_add_block_to_block (&body, &cse.post);
6028
6029 if (maybe_workshare)
6030 ompws_flags &= ~OMPWS_SCALARIZER_BODY8;
6031 gfc_trans_scalarizing_loops (&loop, &body);
6032 gfc_add_block_to_block (&block, &loop.pre);
6033 gfc_add_block_to_block (&block, &loop.post);
6034 gfc_cleanup_loop (&loop);
6035
6036 return gfc_finish_block (&block);
6037}
6038
6039/* As the WHERE or WHERE construct statement can be nested, we call
6040 gfc_trans_where_2 to do the translation, and pass the initial
6041 NULL values for both the control mask and the pending control mask. */
6042
6043tree
6044gfc_trans_where (gfc_code * code)
6045{
6046 stmtblock_t block;
6047 gfc_code *cblock;
6048 gfc_code *eblock;
6049
6050 cblock = code->block;
6051 if (cblock->next
6052 && cblock->next->op == EXEC_ASSIGN
6053 && !cblock->next->next)
6054 {
6055 eblock = cblock->block;
6056 if (!eblock)
6057 {
6058 /* A simple "WHERE (cond) x = y" statement or block is
6059 dependence free if cond is not dependent upon writing x,
6060 and the source y is unaffected by the destination x. */
6061 if (!gfc_check_dependency (cblock->next->expr1,
6062 cblock->expr1, 0)
6063 && !gfc_check_dependency (cblock->next->expr1,
6064 cblock->next->expr2, 0))
6065 return gfc_trans_where_3 (cblock, NULL__null);
6066 }
6067 else if (!eblock->expr1