Bug Summary

File:build/gcc/fortran/trans-stmt.c
Warning:line 5562, column 46
Forming reference to null pointer

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