File: | build/gcc/fortran/trans-stmt.c |
Warning: | line 5562, column 46 Forming reference to null pointer |
Press '?' to see keyboard shortcuts
Keyboard shortcuts:
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 | ||||
6 | This file is part of GCC. | |||
7 | ||||
8 | GCC is free software; you can redistribute it and/or modify it under | |||
9 | the terms of the GNU General Public License as published by the Free | |||
10 | Software Foundation; either version 3, or (at your option) any later | |||
11 | version. | |||
12 | ||||
13 | GCC is distributed in the hope that it will be useful, but WITHOUT ANY | |||
14 | WARRANTY; without even the implied warranty of MERCHANTABILITY or | |||
15 | FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |||
16 | for more details. | |||
17 | ||||
18 | You should have received a copy of the GNU General Public License | |||
19 | along 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 | ||||
38 | typedef struct iter_info | |||
39 | { | |||
40 | tree var; | |||
41 | tree start; | |||
42 | tree end; | |||
43 | tree step; | |||
44 | struct iter_info *next; | |||
45 | } | |||
46 | iter_info; | |||
47 | ||||
48 | typedef 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 | } | |||
58 | forall_info; | |||
59 | ||||
60 | static 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 | ||||
65 | tree | |||
66 | gfc_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 | ||||
76 | void | |||
77 | gfc_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 | ||||
91 | tree | |||
92 | gfc_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 | ||||
136 | tree | |||
137 | gfc_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. */ | |||
174 | tree | |||
175 | gfc_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 | ||||
185 | static void | |||
186 | replace_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. */ | |||
227 | static void | |||
228 | gfc_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 | ||||
363 | static gfc_symbol * | |||
364 | get_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 | ||||
382 | tree | |||
383 | gfc_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 | ||||
557 | tree | |||
558 | gfc_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 | ||||
606 | tree | |||
607 | gfc_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 | ||||
652 | tree | |||
653 | gfc_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 | ||||
715 | tree | |||
716 | gfc_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 | ||||
732 | tree | |||
733 | gfc_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 | ||||
773 | tree | |||
774 | gfc_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 | ||||
803 | tree | |||
804 | gfc_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 | ||||
823 | tree | |||
824 | gfc_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 | ||||
852 | tree | |||
853 | gfc_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 | ||||
1033 | tree | |||
1034 | gfc_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 | ||||
1203 | tree | |||
1204 | gfc_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 | ||||
1446 | static tree | |||
1447 | gfc_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 | ||||
1495 | tree | |||
1496 | gfc_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 | ||||
1539 | tree | |||
1540 | gfc_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. */ | |||
1597 | tree | |||
1598 | gfc_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 | ||||
1658 | static bool | |||
1659 | class_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 | ||||
1672 | static void | |||
1673 | copy_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 | ||||
1716 | static void | |||
1717 | trans_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 | ||||
2277 | tree | |||
2278 | gfc_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 | ||||
2345 | static tree | |||
2346 | gfc_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; | |||
2506 | cycle_label: | |||
2507 | dovar += step | |||
2508 | countm1t = countm1; | |||
2509 | countm1--; | |||
2510 | if (countm1t == 0) goto exit_label; | |||
2511 | } | |||
2512 | exit_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 | ||||
2517 | tree | |||
2518 | gfc_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; | |||
2801 | cycle_label: | |||
2802 | } | |||
2803 | exit_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 | ||||
2809 | tree | |||
2810 | gfc_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 | ||||
2878 | static tree | |||
2879 | gfc_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 | ||||
2907 | repeat: | |||
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 | ||||
3038 | static tree | |||
3039 | gfc_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 | ||||
3153 | static tree | |||
3154 | gfc_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. */ | |||
3241 | static 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 | ||||
3252 | static tree | |||
3253 | gfc_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 | ||||
3586 | tree | |||
3587 | gfc_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 | ||||
3632 | tree | |||
3633 | gfc_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 | ||||
3662 | static tree | |||
3663 | gfc_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 | ||||
3707 | repeat: | |||
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 | ||||
3768 | tree | |||
3769 | gfc_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 | ||||
3807 | static gfc_symtree *new_symtree; | |||
3808 | static gfc_symtree *old_symtree; | |||
3809 | ||||
3810 | static bool | |||
3811 | forall_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 | ||||
3824 | static void | |||
3825 | forall_replace_symtree (gfc_expr *e, gfc_symbol *sym, int f) | |||
3826 | { | |||
3827 | gfc_traverse_expr (e, sym, forall_replace, f); | |||
3828 | } | |||
3829 | ||||
3830 | static bool | |||
3831 | forall_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 | ||||
3844 | static void | |||
3845 | forall_restore_symtree (gfc_expr *e) | |||
3846 | { | |||
3847 | gfc_traverse_expr (e, NULL__null, forall_restore, 0); | |||
3848 | } | |||
3849 | ||||
3850 | static void | |||
3851 | forall_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. */ | |||
3935 | static int | |||
3936 | check_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 | ||||
3990 | static void | |||
3991 | cleanup_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 | ||||
4019 | static tree | |||
4020 | gfc_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 | ||||
4130 | static tree | |||
4131 | gfc_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 | ||||
4171 | static tree | |||
4172 | gfc_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 | ||||
4206 | static tree | |||
4207 | generate_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 | ||||
4314 | static tree | |||
4315 | generate_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 | ||||
4426 | static tree | |||
4427 | compute_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 | ||||
4499 | static tree | |||
4500 | compute_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 | ||||
4554 | static tree | |||
4555 | allocate_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 | ||||
4582 | static tree | |||
4583 | allocate_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 | */ | |||
4628 | static void | |||
4629 | gfc_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 | ||||
4740 | static void | |||
4741 | gfc_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 | ||||
4933 | static tree | |||
4934 | gfc_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 | ||||
5247 | done: | |||
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 | ||||
5288 | tree 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 | ||||
5296 | tree 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 | ||||
5313 | static void | |||
5314 | gfc_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 | ||||
5444 | static tree | |||
5445 | gfc_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
| |||
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)); | |||
5490 | ||||
5491 | /* The assignment needs scalarization. */ | |||
5492 | lss_section = lss; | |||
5493 | ||||
5494 | /* Find a non-scalar SS from the lhs. */ | |||
5495 | while (lss_section
| |||
5496 | && lss_section->info->type != 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)); | |||
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) | |||
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) | |||
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) | |||
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
| |||
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, | |||
| ||||
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 | ||||
5654 | static void | |||
5655 | gfc_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) | |||
5686 | { | |||
5687 | /* One clause: No ELSEWHEREs. */ | |||
5688 | need_cmask = (cblock->next != 0); | |||
5689 | need_pmask = false; | |||
5690 | } | |||
5691 | else if (cblock->block->block) | |||
5692 | { | |||
5693 | /* Three or more clauses: Conditional ELSEWHEREs. */ | |||
5694 | need_cmask = true; | |||
5695 | need_pmask = true; | |||
5696 | } | |||
5697 | else if (cblock->next
| |||
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) | |||
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
| |||
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
| |||
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
| |||
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
| |||
5750 | pmask = allocate_temp_for_forall_nest_1 (mask_type, size, block, | |||
5751 | &ppmask); | |||
5752 | } | |||
5753 | ||||
5754 | while (cblock) | |||
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) | |||
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) | |||
5794 | { | |||
5795 | switch (cnext->op) | |||
5796 | { | |||
5797 | /* WHERE assignment statement. */ | |||
5798 | case EXEC_ASSIGN_CALL: | |||
5799 | ||||
5800 | arg = cnext->ext.actual; | |||
5801 | expr1 = expr2 = NULL__null; | |||
5802 | for (; arg; arg = arg->next) | |||
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; | |||
5812 | ||||
5813 | case EXEC_ASSIGN: | |||
5814 | expr1 = cnext->expr1; | |||
5815 | expr2 = cnext->expr2; | |||
5816 | evaluate: | |||
5817 | if (nested_forall_info
| |||
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, | |||
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
| |||
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 | ||||
5911 | static tree | |||
5912 | gfc_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 | { | |||