Branch data Line data Source code
1 : : /* Statement translation -- generate GCC trees from gfc_code.
2 : : Copyright (C) 2002-2025 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 : : #define INCLUDE_VECTOR
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 : : gfc_loop_annot annot;
45 : : struct iter_info *next;
46 : : }
47 : : iter_info;
48 : :
49 : : typedef struct forall_info
50 : : {
51 : : iter_info *this_loop;
52 : : tree mask;
53 : : tree maskindex;
54 : : int nvar;
55 : : tree size;
56 : : struct forall_info *prev_nest;
57 : : bool do_concurrent;
58 : : }
59 : : forall_info;
60 : :
61 : : static void gfc_trans_where_2 (gfc_code *, tree, bool,
62 : : forall_info *, stmtblock_t *);
63 : :
64 : : /* Translate a F95 label number to a LABEL_EXPR. */
65 : :
66 : : tree
67 : 3519 : gfc_trans_label_here (gfc_code * code)
68 : : {
69 : 3519 : return build1_v (LABEL_EXPR, gfc_get_label_decl (code->here));
70 : : }
71 : :
72 : :
73 : : /* Given a variable expression which has been ASSIGNed to, find the decl
74 : : containing the auxiliary variables. For variables in common blocks this
75 : : is a field_decl. */
76 : :
77 : : void
78 : 187 : gfc_conv_label_variable (gfc_se * se, gfc_expr * expr)
79 : : {
80 : 187 : gcc_assert (expr->symtree->n.sym->attr.assign == 1);
81 : 187 : gfc_conv_expr (se, expr);
82 : : /* Deals with variable in common block. Get the field declaration. */
83 : 187 : if (TREE_CODE (se->expr) == COMPONENT_REF)
84 : 0 : se->expr = TREE_OPERAND (se->expr, 1);
85 : : /* Deals with dummy argument. Get the parameter declaration. */
86 : 187 : else if (INDIRECT_REF_P (se->expr))
87 : 12 : se->expr = TREE_OPERAND (se->expr, 0);
88 : 187 : }
89 : :
90 : : /* Translate a label assignment statement. */
91 : :
92 : : tree
93 : 116 : gfc_trans_label_assign (gfc_code * code)
94 : : {
95 : 116 : tree label_tree;
96 : 116 : gfc_se se;
97 : 116 : tree len;
98 : 116 : tree addr;
99 : 116 : tree len_tree;
100 : 116 : int label_len;
101 : :
102 : : /* Start a new block. */
103 : 116 : gfc_init_se (&se, NULL);
104 : 116 : gfc_start_block (&se.pre);
105 : 116 : gfc_conv_label_variable (&se, code->expr1);
106 : :
107 : 116 : len = GFC_DECL_STRING_LEN (se.expr);
108 : 116 : addr = GFC_DECL_ASSIGN_ADDR (se.expr);
109 : :
110 : 116 : label_tree = gfc_get_label_decl (code->label1);
111 : :
112 : 116 : if (code->label1->defined == ST_LABEL_TARGET
113 : 116 : || code->label1->defined == ST_LABEL_DO_TARGET)
114 : : {
115 : 115 : label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree);
116 : 115 : len_tree = build_int_cst (gfc_charlen_type_node, -1);
117 : : }
118 : : else
119 : : {
120 : 1 : gfc_expr *format = code->label1->format;
121 : :
122 : 1 : label_len = format->value.character.length;
123 : 1 : len_tree = build_int_cst (gfc_charlen_type_node, label_len);
124 : 2 : label_tree = gfc_build_wide_string_const (format->ts.kind, label_len + 1,
125 : 1 : format->value.character.string);
126 : 1 : label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree);
127 : : }
128 : :
129 : 116 : gfc_add_modify (&se.pre, len, fold_convert (TREE_TYPE (len), len_tree));
130 : 116 : gfc_add_modify (&se.pre, addr, label_tree);
131 : :
132 : 116 : return gfc_finish_block (&se.pre);
133 : : }
134 : :
135 : : /* Translate a GOTO statement. */
136 : :
137 : : tree
138 : 1188 : gfc_trans_goto (gfc_code * code)
139 : : {
140 : 1188 : locus loc = code->loc;
141 : 1188 : tree assigned_goto;
142 : 1188 : tree target;
143 : 1188 : tree tmp;
144 : 1188 : gfc_se se;
145 : :
146 : 1188 : if (code->label1 != NULL)
147 : 1118 : return build1_v (GOTO_EXPR, gfc_get_label_decl (code->label1));
148 : :
149 : : /* ASSIGNED GOTO. */
150 : 70 : gfc_init_se (&se, NULL);
151 : 70 : gfc_start_block (&se.pre);
152 : 70 : gfc_conv_label_variable (&se, code->expr1);
153 : 70 : tmp = GFC_DECL_STRING_LEN (se.expr);
154 : 70 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
155 : 70 : build_int_cst (TREE_TYPE (tmp), -1));
156 : 70 : gfc_trans_runtime_check (true, false, tmp, &se.pre, &loc,
157 : : "Assigned label is not a target label");
158 : :
159 : 70 : assigned_goto = GFC_DECL_ASSIGN_ADDR (se.expr);
160 : :
161 : : /* We're going to ignore a label list. It does not really change the
162 : : statement's semantics (because it is just a further restriction on
163 : : what's legal code); before, we were comparing label addresses here, but
164 : : that's a very fragile business and may break with optimization. So
165 : : just ignore it. */
166 : :
167 : 70 : target = fold_build1_loc (input_location, GOTO_EXPR, void_type_node,
168 : : assigned_goto);
169 : 70 : gfc_add_expr_to_block (&se.pre, target);
170 : 70 : return gfc_finish_block (&se.pre);
171 : : }
172 : :
173 : :
174 : : /* Translate an ENTRY statement. Just adds a label for this entry point. */
175 : : tree
176 : 1341 : gfc_trans_entry (gfc_code * code)
177 : : {
178 : 1341 : return build1_v (LABEL_EXPR, code->ext.entry->label);
179 : : }
180 : :
181 : :
182 : : /* Replace a gfc_ss structure by another both in the gfc_se struct
183 : : and the gfc_loopinfo struct. This is used in gfc_conv_elemental_dependencies
184 : : to replace a variable ss by the corresponding temporary. */
185 : :
186 : : static void
187 : 343 : replace_ss (gfc_se *se, gfc_ss *old_ss, gfc_ss *new_ss)
188 : : {
189 : 343 : gfc_ss **sess, **loopss;
190 : :
191 : : /* The old_ss is a ss for a single variable. */
192 : 343 : gcc_assert (old_ss->info->type == GFC_SS_SECTION);
193 : :
194 : 490 : for (sess = &(se->ss); *sess != gfc_ss_terminator; sess = &((*sess)->next))
195 : 490 : if (*sess == old_ss)
196 : : break;
197 : 343 : gcc_assert (*sess != gfc_ss_terminator);
198 : :
199 : 343 : *sess = new_ss;
200 : 343 : new_ss->next = old_ss->next;
201 : :
202 : : /* Make sure that trailing references are not lost. */
203 : 343 : if (old_ss->info
204 : 343 : && old_ss->info->data.array.ref
205 : 343 : && old_ss->info->data.array.ref->next
206 : 25 : && !(new_ss->info->data.array.ref
207 : 0 : && new_ss->info->data.array.ref->next))
208 : 25 : new_ss->info->data.array.ref = old_ss->info->data.array.ref;
209 : :
210 : 490 : for (loopss = &(se->loop->ss); *loopss != gfc_ss_terminator;
211 : 147 : loopss = &((*loopss)->loop_chain))
212 : 490 : if (*loopss == old_ss)
213 : : break;
214 : 343 : gcc_assert (*loopss != gfc_ss_terminator);
215 : :
216 : 343 : *loopss = new_ss;
217 : 343 : new_ss->loop_chain = old_ss->loop_chain;
218 : 343 : new_ss->loop = old_ss->loop;
219 : :
220 : 343 : gfc_free_ss (old_ss);
221 : 343 : }
222 : :
223 : :
224 : : /* Check for dependencies between INTENT(IN) and INTENT(OUT) arguments of
225 : : elemental subroutines. Make temporaries for output arguments if any such
226 : : dependencies are found. Output arguments are chosen because internal_unpack
227 : : can be used, as is, to copy the result back to the variable. */
228 : : static void
229 : 2216 : gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse,
230 : : gfc_symbol * sym, gfc_actual_arglist * arg,
231 : : gfc_dep_check check_variable)
232 : : {
233 : 2216 : gfc_actual_arglist *arg0;
234 : 2216 : gfc_expr *e;
235 : 2216 : gfc_formal_arglist *formal;
236 : 2216 : gfc_se parmse;
237 : 2216 : gfc_ss *ss;
238 : 2216 : gfc_symbol *fsym;
239 : 2216 : tree data;
240 : 2216 : tree size;
241 : 2216 : tree tmp;
242 : :
243 : 2216 : if (loopse->ss == NULL)
244 : 0 : return;
245 : :
246 : 2216 : ss = loopse->ss;
247 : 2216 : arg0 = arg;
248 : 2216 : formal = gfc_sym_get_dummy_args (sym);
249 : :
250 : : /* Loop over all the arguments testing for dependencies. */
251 : 11390 : for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
252 : : {
253 : 4587 : e = arg->expr;
254 : 4587 : if (e == NULL)
255 : 12 : continue;
256 : :
257 : : /* Obtain the info structure for the current argument. */
258 : 7927 : for (ss = loopse->ss; ss && ss != gfc_ss_terminator; ss = ss->next)
259 : 7661 : if (ss->info->expr == e)
260 : : break;
261 : :
262 : : /* If there is a dependency, create a temporary and use it
263 : : instead of the variable. */
264 : 4575 : fsym = formal ? formal->sym : NULL;
265 : 4575 : if (e->expr_type == EXPR_VARIABLE
266 : 3400 : && e->rank && fsym
267 : 2891 : && fsym->attr.intent != INTENT_IN
268 : 1485 : && !fsym->attr.value
269 : 6000 : && gfc_check_fncall_dependency (e, fsym->attr.intent,
270 : : sym, arg0, check_variable))
271 : : {
272 : 343 : tree initial, temptype;
273 : 343 : stmtblock_t temp_post;
274 : 343 : gfc_ss *tmp_ss;
275 : :
276 : 343 : tmp_ss = gfc_get_array_ss (gfc_ss_terminator, NULL, ss->dimen,
277 : : GFC_SS_SECTION);
278 : 343 : gfc_mark_ss_chain_used (tmp_ss, 1);
279 : 343 : tmp_ss->info->expr = ss->info->expr;
280 : 343 : replace_ss (loopse, ss, tmp_ss);
281 : :
282 : : /* Obtain the argument descriptor for unpacking. */
283 : 343 : gfc_init_se (&parmse, NULL);
284 : 343 : parmse.want_pointer = 1;
285 : 343 : gfc_conv_expr_descriptor (&parmse, e);
286 : 343 : gfc_add_block_to_block (&se->pre, &parmse.pre);
287 : :
288 : : /* If we've got INTENT(INOUT) or a derived type with INTENT(OUT),
289 : : initialize the array temporary with a copy of the values. */
290 : 343 : if (fsym->attr.intent == INTENT_INOUT
291 : 299 : || (fsym->ts.type ==BT_DERIVED
292 : 51 : && fsym->attr.intent == INTENT_OUT))
293 : 95 : initial = parmse.expr;
294 : : /* For class expressions, we always initialize with the copy of
295 : : the values. */
296 : 248 : else if (e->ts.type == BT_CLASS)
297 : 6 : initial = parmse.expr;
298 : : else
299 : : initial = NULL_TREE;
300 : :
301 : 343 : if (e->ts.type != BT_CLASS)
302 : : {
303 : : /* Find the type of the temporary to create; we don't use the type
304 : : of e itself as this breaks for subcomponent-references in e
305 : : (where the type of e is that of the final reference, but
306 : : parmse.expr's type corresponds to the full derived-type). */
307 : : /* TODO: Fix this somehow so we don't need a temporary of the whole
308 : : array but instead only the components referenced. */
309 : 337 : temptype = TREE_TYPE (parmse.expr); /* Pointer to descriptor. */
310 : 337 : gcc_assert (TREE_CODE (temptype) == POINTER_TYPE);
311 : 337 : temptype = TREE_TYPE (temptype);
312 : 337 : temptype = gfc_get_element_type (temptype);
313 : : }
314 : :
315 : : else
316 : : /* For class arrays signal that the size of the dynamic type has to
317 : : be obtained from the vtable, using the 'initial' expression. */
318 : : temptype = NULL_TREE;
319 : :
320 : : /* Generate the temporary. Cleaning up the temporary should be the
321 : : very last thing done, so we add the code to a new block and add it
322 : : to se->post as last instructions. */
323 : 343 : size = gfc_create_var (gfc_array_index_type, NULL);
324 : 343 : data = gfc_create_var (pvoid_type_node, NULL);
325 : 343 : gfc_init_block (&temp_post);
326 : 686 : tmp = gfc_trans_create_temp_array (&se->pre, &temp_post, tmp_ss,
327 : : temptype, initial, false, true,
328 : 343 : false, &arg->expr->where);
329 : 343 : gfc_add_modify (&se->pre, size, tmp);
330 : 343 : tmp = fold_convert (pvoid_type_node, tmp_ss->info->data.array.data);
331 : 343 : gfc_add_modify (&se->pre, data, tmp);
332 : :
333 : : /* Update other ss' delta. */
334 : 343 : gfc_set_delta (loopse->loop);
335 : :
336 : : /* Copy the result back using unpack..... */
337 : 343 : if (e->ts.type != BT_CLASS)
338 : 337 : tmp = build_call_expr_loc (input_location,
339 : : gfor_fndecl_in_unpack, 2, parmse.expr, data);
340 : : else
341 : : {
342 : : /* ... except for class results where the copy is
343 : : unconditional. */
344 : 6 : tmp = build_fold_indirect_ref_loc (input_location, parmse.expr);
345 : 6 : tmp = gfc_conv_descriptor_data_get (tmp);
346 : 6 : tmp = build_call_expr_loc (input_location,
347 : : builtin_decl_explicit (BUILT_IN_MEMCPY),
348 : : 3, tmp, data,
349 : : fold_convert (size_type_node, size));
350 : : }
351 : 343 : gfc_add_expr_to_block (&se->post, tmp);
352 : :
353 : : /* parmse.pre is already added above. */
354 : 343 : gfc_add_block_to_block (&se->post, &parmse.post);
355 : 343 : gfc_add_block_to_block (&se->post, &temp_post);
356 : : }
357 : : }
358 : : }
359 : :
360 : :
361 : : /* Given an executable statement referring to an intrinsic function call,
362 : : returns the intrinsic symbol. */
363 : :
364 : : static gfc_intrinsic_sym *
365 : 6112 : get_intrinsic_for_code (gfc_code *code)
366 : : {
367 : 6112 : if (code->op == EXEC_CALL)
368 : : {
369 : 5769 : gfc_intrinsic_sym * const isym = code->resolved_isym;
370 : 5769 : if (isym)
371 : : return isym;
372 : : else
373 : 5572 : return gfc_get_intrinsic_for_expr (code->expr1);
374 : : }
375 : :
376 : : return NULL;
377 : : }
378 : :
379 : :
380 : : /* Handle the OpenACC routines acc_attach{,_async} and
381 : : acc_detach{,_finalize}{,_async} explicitly. This is required as the
382 : : the corresponding device pointee is attached to the corresponding device
383 : : pointer, but if a temporary array descriptor is created for the call,
384 : : that one is used as pointer instead of the original pointer. */
385 : :
386 : : tree
387 : 55 : gfc_trans_call_acc_attach_detach (gfc_code *code)
388 : : {
389 : 55 : stmtblock_t block;
390 : 55 : gfc_se ptr_addr_se, async_se;
391 : 55 : tree fn;
392 : :
393 : 55 : fn = code->resolved_sym->backend_decl;
394 : 55 : if (fn == NULL)
395 : : {
396 : 18 : fn = gfc_get_symbol_decl (code->resolved_sym);
397 : 18 : code->resolved_sym->backend_decl = fn;
398 : : }
399 : :
400 : 55 : gfc_start_block (&block);
401 : :
402 : 55 : gfc_init_se (&ptr_addr_se, NULL);
403 : 55 : ptr_addr_se.descriptor_only = 1;
404 : 55 : ptr_addr_se.want_pointer = 1;
405 : 55 : gfc_conv_expr (&ptr_addr_se, code->ext.actual->expr);
406 : 55 : gfc_add_block_to_block (&block, &ptr_addr_se.pre);
407 : 55 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (ptr_addr_se.expr)))
408 : 27 : ptr_addr_se.expr = gfc_conv_descriptor_data_get (ptr_addr_se.expr);
409 : 55 : ptr_addr_se.expr = build_fold_addr_expr (ptr_addr_se.expr);
410 : :
411 : 55 : bool async = code->ext.actual->next != NULL;
412 : 55 : if (async)
413 : : {
414 : 3 : gfc_init_se (&async_se, NULL);
415 : 3 : gfc_conv_expr (&async_se, code->ext.actual->next->expr);
416 : 3 : fn = build_call_expr_loc (gfc_get_location (&code->loc), fn, 2,
417 : : ptr_addr_se.expr, async_se.expr);
418 : : }
419 : : else
420 : 52 : fn = build_call_expr_loc (gfc_get_location (&code->loc),
421 : : fn, 1, ptr_addr_se.expr);
422 : 55 : gfc_add_expr_to_block (&block, fn);
423 : 55 : gfc_add_block_to_block (&block, &ptr_addr_se.post);
424 : 55 : if (async)
425 : 3 : gfc_add_block_to_block (&block, &async_se.post);
426 : :
427 : 55 : return gfc_finish_block (&block);
428 : : }
429 : :
430 : :
431 : : /* Translate the CALL statement. Builds a call to an F95 subroutine. */
432 : :
433 : : tree
434 : 77231 : gfc_trans_call (gfc_code * code, bool dependency_check,
435 : : tree mask, tree count1, bool invert)
436 : : {
437 : 77231 : gfc_se se;
438 : 77231 : gfc_ss * ss;
439 : 77231 : int has_alternate_specifier;
440 : 77231 : gfc_dep_check check_variable;
441 : 77231 : tree index = NULL_TREE;
442 : 77231 : tree maskexpr = NULL_TREE;
443 : 77231 : tree tmp;
444 : 77231 : bool is_intrinsic_mvbits;
445 : :
446 : 77231 : gcc_assert (code->resolved_sym);
447 : :
448 : : /* Unfortunately, acc_attach* and acc_detach* need some special treatment for
449 : : attaching the the pointee to a pointer as GCC might introduce a temporary
450 : : array descriptor, whose data component is then used as to be attached to
451 : : pointer. */
452 : 77231 : if (flag_openacc
453 : 2455 : && code->resolved_sym->attr.subroutine
454 : 2449 : && code->resolved_sym->formal
455 : 1290 : && code->resolved_sym->formal->sym->ts.type == BT_ASSUMED
456 : 350 : && code->resolved_sym->formal->sym->attr.dimension
457 : 350 : && code->resolved_sym->formal->sym->as->type == AS_ASSUMED_RANK
458 : 243 : && startswith (code->resolved_sym->name, "acc_")
459 : 77474 : && (!strcmp (code->resolved_sym->name + 4, "attach")
460 : 217 : || !strcmp (code->resolved_sym->name + 4, "attach_async")
461 : 216 : || !strcmp (code->resolved_sym->name + 4, "detach")
462 : 191 : || !strcmp (code->resolved_sym->name + 4, "detach_async")
463 : 190 : || !strcmp (code->resolved_sym->name + 4, "detach_finalize")
464 : 189 : || !strcmp (code->resolved_sym->name + 4, "detach_finalize_async")))
465 : 55 : return gfc_trans_call_acc_attach_detach (code);
466 : :
467 : : /* A CALL starts a new block because the actual arguments may have to
468 : : be evaluated first. */
469 : 77176 : gfc_init_se (&se, NULL);
470 : 77176 : gfc_start_block (&se.pre);
471 : :
472 : 77176 : ss = gfc_ss_terminator;
473 : 77176 : if (code->resolved_sym->attr.elemental)
474 : 6112 : ss = gfc_walk_elemental_function_args (ss, code->ext.actual,
475 : : get_intrinsic_for_code (code),
476 : : GFC_SS_REFERENCE);
477 : :
478 : : /* MVBITS is inlined but needs the dependency checking found here. */
479 : 154352 : is_intrinsic_mvbits = code->resolved_isym
480 : 77176 : && code->resolved_isym->id == GFC_ISYM_MVBITS;
481 : :
482 : : /* Is not an elemental subroutine call with array valued arguments. */
483 : 77176 : if (ss == gfc_ss_terminator)
484 : : {
485 : :
486 : 74960 : if (is_intrinsic_mvbits)
487 : : {
488 : 130 : has_alternate_specifier = 0;
489 : 130 : gfc_conv_intrinsic_mvbits (&se, code->ext.actual, NULL);
490 : : }
491 : : else
492 : : {
493 : : /* Translate the call. */
494 : 74830 : has_alternate_specifier =
495 : 74830 : gfc_conv_procedure_call (&se, code->resolved_sym,
496 : : code->ext.actual, code->expr1, NULL);
497 : :
498 : : /* A subroutine without side-effect, by definition, does nothing! */
499 : 74830 : TREE_SIDE_EFFECTS (se.expr) = 1;
500 : : }
501 : :
502 : : /* Chain the pieces together and return the block. */
503 : 74960 : if (has_alternate_specifier)
504 : : {
505 : 140 : gfc_code *select_code;
506 : 140 : gfc_symbol *sym;
507 : 140 : select_code = code->next;
508 : 140 : gcc_assert(select_code->op == EXEC_SELECT);
509 : 140 : sym = select_code->expr1->symtree->n.sym;
510 : 140 : se.expr = convert (gfc_typenode_for_spec (&sym->ts), se.expr);
511 : 140 : if (sym->backend_decl == NULL)
512 : 1 : sym->backend_decl = gfc_get_symbol_decl (sym);
513 : 140 : gfc_add_modify (&se.pre, sym->backend_decl, se.expr);
514 : : }
515 : : else
516 : 74820 : gfc_add_expr_to_block (&se.pre, se.expr);
517 : :
518 : 74960 : gfc_add_block_to_block (&se.finalblock, &se.post);
519 : 74960 : gfc_add_block_to_block (&se.pre, &se.finalblock);
520 : : }
521 : :
522 : : else
523 : : {
524 : : /* An elemental subroutine call with array valued arguments has
525 : : to be scalarized. */
526 : 2216 : gfc_loopinfo loop;
527 : 2216 : stmtblock_t body;
528 : 2216 : stmtblock_t block;
529 : 2216 : gfc_se loopse;
530 : 2216 : gfc_se depse;
531 : :
532 : : /* gfc_walk_elemental_function_args renders the ss chain in the
533 : : reverse order to the actual argument order. */
534 : 2216 : ss = gfc_reverse_ss (ss);
535 : :
536 : : /* Initialize the loop. */
537 : 2216 : gfc_init_se (&loopse, NULL);
538 : 2216 : gfc_init_loopinfo (&loop);
539 : 2216 : gfc_add_ss_to_loop (&loop, ss);
540 : :
541 : 2216 : gfc_conv_ss_startstride (&loop);
542 : : /* TODO: gfc_conv_loop_setup generates a temporary for vector
543 : : subscripts. This could be prevented in the elemental case
544 : : as temporaries are handled separately
545 : : (below in gfc_conv_elemental_dependencies). */
546 : 2216 : if (code->expr1)
547 : 237 : gfc_conv_loop_setup (&loop, &code->expr1->where);
548 : : else
549 : 1979 : gfc_conv_loop_setup (&loop, &code->loc);
550 : :
551 : 2216 : gfc_mark_ss_chain_used (ss, 1);
552 : :
553 : : /* Convert the arguments, checking for dependencies. */
554 : 2216 : gfc_copy_loopinfo_to_se (&loopse, &loop);
555 : 2216 : loopse.ss = ss;
556 : :
557 : : /* For operator assignment, do dependency checking. */
558 : 2216 : if (dependency_check)
559 : : check_variable = ELEM_CHECK_VARIABLE;
560 : : else
561 : 1892 : check_variable = ELEM_DONT_CHECK_VARIABLE;
562 : :
563 : 2216 : gfc_init_se (&depse, NULL);
564 : 2216 : gfc_conv_elemental_dependencies (&depse, &loopse, code->resolved_sym,
565 : : code->ext.actual, check_variable);
566 : :
567 : 2216 : gfc_add_block_to_block (&loop.pre, &depse.pre);
568 : 2216 : gfc_add_block_to_block (&loop.post, &depse.post);
569 : :
570 : : /* Generate the loop body. */
571 : 2216 : gfc_start_scalarized_body (&loop, &body);
572 : 2216 : gfc_init_block (&block);
573 : :
574 : 2216 : if (mask && count1)
575 : : {
576 : : /* Form the mask expression according to the mask. */
577 : 44 : index = count1;
578 : 44 : maskexpr = gfc_build_array_ref (mask, index, NULL);
579 : 44 : if (invert)
580 : 11 : maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
581 : 11 : TREE_TYPE (maskexpr), maskexpr);
582 : : }
583 : :
584 : 2216 : if (is_intrinsic_mvbits)
585 : : {
586 : 67 : has_alternate_specifier = 0;
587 : 67 : gfc_conv_intrinsic_mvbits (&loopse, code->ext.actual, &loop);
588 : : }
589 : : else
590 : : {
591 : : /* Add the subroutine call to the block. */
592 : 2149 : gfc_conv_procedure_call (&loopse, code->resolved_sym,
593 : : code->ext.actual, code->expr1,
594 : : NULL);
595 : : }
596 : :
597 : 2216 : if (mask && count1)
598 : : {
599 : 44 : tmp = build3_v (COND_EXPR, maskexpr, loopse.expr,
600 : : build_empty_stmt (input_location));
601 : 44 : gfc_add_expr_to_block (&loopse.pre, tmp);
602 : 44 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
603 : : gfc_array_index_type,
604 : : count1, gfc_index_one_node);
605 : 44 : gfc_add_modify (&loopse.pre, count1, tmp);
606 : : }
607 : : else
608 : 2172 : gfc_add_expr_to_block (&loopse.pre, loopse.expr);
609 : :
610 : 2216 : gfc_add_block_to_block (&block, &loopse.pre);
611 : 2216 : gfc_add_block_to_block (&block, &loopse.post);
612 : :
613 : : /* Finish up the loop block and the loop. */
614 : 2216 : gfc_add_expr_to_block (&body, gfc_finish_block (&block));
615 : 2216 : gfc_trans_scalarizing_loops (&loop, &body);
616 : 2216 : gfc_add_block_to_block (&se.pre, &loop.pre);
617 : 2216 : gfc_add_block_to_block (&se.pre, &loop.post);
618 : 2216 : gfc_add_block_to_block (&se.pre, &loopse.finalblock);
619 : 2216 : gfc_add_block_to_block (&se.pre, &se.post);
620 : 2216 : gfc_cleanup_loop (&loop);
621 : : }
622 : :
623 : 77176 : return gfc_finish_block (&se.pre);
624 : : }
625 : :
626 : :
627 : : /* Translate the RETURN statement. */
628 : :
629 : : tree
630 : 3063 : gfc_trans_return (gfc_code * code)
631 : : {
632 : 3063 : if (code->expr1)
633 : : {
634 : 50 : gfc_se se;
635 : 50 : tree tmp;
636 : 50 : tree result;
637 : :
638 : : /* If code->expr is not NULL, this return statement must appear
639 : : in a subroutine and current_fake_result_decl has already
640 : : been generated. */
641 : :
642 : 50 : result = gfc_get_fake_result_decl (NULL, 0);
643 : 50 : if (!result)
644 : : {
645 : 0 : gfc_warning (0,
646 : : "An alternate return at %L without a * dummy argument",
647 : 0 : &code->expr1->where);
648 : 0 : return gfc_generate_return ();
649 : : }
650 : :
651 : : /* Start a new block for this statement. */
652 : 50 : gfc_init_se (&se, NULL);
653 : 50 : gfc_start_block (&se.pre);
654 : :
655 : 50 : gfc_conv_expr (&se, code->expr1);
656 : :
657 : : /* Note that the actually returned expression is a simple value and
658 : : does not depend on any pointers or such; thus we can clean-up with
659 : : se.post before returning. */
660 : 50 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (result),
661 : 50 : result, fold_convert (TREE_TYPE (result),
662 : : se.expr));
663 : 50 : gfc_add_expr_to_block (&se.pre, tmp);
664 : 50 : gfc_add_block_to_block (&se.pre, &se.post);
665 : :
666 : 50 : tmp = gfc_generate_return ();
667 : 50 : gfc_add_expr_to_block (&se.pre, tmp);
668 : 50 : return gfc_finish_block (&se.pre);
669 : : }
670 : :
671 : 3013 : return gfc_generate_return ();
672 : : }
673 : :
674 : :
675 : : /* Translate the PAUSE statement. We have to translate this statement
676 : : to a runtime library call. */
677 : :
678 : : tree
679 : 28 : gfc_trans_pause (gfc_code * code)
680 : : {
681 : 28 : tree gfc_int8_type_node = gfc_get_int_type (8);
682 : 28 : gfc_se se;
683 : 28 : tree tmp;
684 : :
685 : : /* Start a new block for this statement. */
686 : 28 : gfc_init_se (&se, NULL);
687 : 28 : gfc_start_block (&se.pre);
688 : :
689 : :
690 : 28 : if (code->expr1 == NULL)
691 : : {
692 : 10 : tmp = build_int_cst (size_type_node, 0);
693 : 10 : tmp = build_call_expr_loc (input_location,
694 : : gfor_fndecl_pause_string, 2,
695 : : build_int_cst (pchar_type_node, 0), tmp);
696 : : }
697 : 18 : else if (code->expr1->ts.type == BT_INTEGER)
698 : : {
699 : 9 : gfc_conv_expr (&se, code->expr1);
700 : 9 : tmp = build_call_expr_loc (input_location,
701 : : gfor_fndecl_pause_numeric, 1,
702 : : fold_convert (gfc_int8_type_node, se.expr));
703 : : }
704 : : else
705 : : {
706 : 9 : gfc_conv_expr_reference (&se, code->expr1);
707 : 9 : tmp = build_call_expr_loc (input_location,
708 : : gfor_fndecl_pause_string, 2,
709 : : se.expr, fold_convert (size_type_node,
710 : : se.string_length));
711 : : }
712 : :
713 : 28 : gfc_add_expr_to_block (&se.pre, tmp);
714 : :
715 : 28 : gfc_add_block_to_block (&se.pre, &se.post);
716 : :
717 : 28 : return gfc_finish_block (&se.pre);
718 : : }
719 : :
720 : :
721 : : /* Translate the STOP statement. We have to translate this statement
722 : : to a runtime library call. */
723 : :
724 : : tree
725 : 213346 : gfc_trans_stop (gfc_code *code, bool error_stop)
726 : : {
727 : 213346 : gfc_se se;
728 : 213346 : tree tmp;
729 : 213346 : tree quiet;
730 : :
731 : : /* Start a new block for this statement. */
732 : 213346 : gfc_init_se (&se, NULL);
733 : 213346 : gfc_start_block (&se.pre);
734 : :
735 : 213346 : if (code->expr2)
736 : : {
737 : 25 : gfc_conv_expr_val (&se, code->expr2);
738 : 25 : quiet = fold_convert (boolean_type_node, se.expr);
739 : : }
740 : : else
741 : 213321 : quiet = boolean_false_node;
742 : :
743 : 213346 : if (code->expr1 == NULL)
744 : : {
745 : 20413 : tmp = build_int_cst (size_type_node, 0);
746 : 40826 : tmp = build_call_expr_loc (input_location,
747 : : error_stop
748 : 19455 : ? (flag_coarray == GFC_FCOARRAY_LIB
749 : 19455 : ? gfor_fndecl_caf_error_stop_str
750 : : : gfor_fndecl_error_stop_string)
751 : 958 : : (flag_coarray == GFC_FCOARRAY_LIB
752 : 958 : ? gfor_fndecl_caf_stop_str
753 : : : gfor_fndecl_stop_string),
754 : : 3, build_int_cst (pchar_type_node, 0), tmp,
755 : : quiet);
756 : : }
757 : 192933 : else if (code->expr1->ts.type == BT_INTEGER)
758 : : {
759 : 192528 : gfc_conv_expr (&se, code->expr1);
760 : 385056 : tmp = build_call_expr_loc (input_location,
761 : : error_stop
762 : 19278 : ? (flag_coarray == GFC_FCOARRAY_LIB
763 : 19278 : ? gfor_fndecl_caf_error_stop
764 : : : gfor_fndecl_error_stop_numeric)
765 : 173250 : : (flag_coarray == GFC_FCOARRAY_LIB
766 : 173250 : ? gfor_fndecl_caf_stop_numeric
767 : : : gfor_fndecl_stop_numeric), 2,
768 : : fold_convert (integer_type_node, se.expr),
769 : : quiet);
770 : : }
771 : : else
772 : : {
773 : 405 : gfc_conv_expr_reference (&se, code->expr1);
774 : 810 : tmp = build_call_expr_loc (input_location,
775 : : error_stop
776 : 297 : ? (flag_coarray == GFC_FCOARRAY_LIB
777 : 297 : ? gfor_fndecl_caf_error_stop_str
778 : : : gfor_fndecl_error_stop_string)
779 : 108 : : (flag_coarray == GFC_FCOARRAY_LIB
780 : 108 : ? gfor_fndecl_caf_stop_str
781 : : : gfor_fndecl_stop_string),
782 : : 3, se.expr, fold_convert (size_type_node,
783 : : se.string_length),
784 : : quiet);
785 : : }
786 : :
787 : 213346 : gfc_add_expr_to_block (&se.pre, tmp);
788 : :
789 : 213346 : gfc_add_block_to_block (&se.pre, &se.post);
790 : :
791 : 213346 : return gfc_finish_block (&se.pre);
792 : : }
793 : :
794 : : tree
795 : 52 : trans_exit ()
796 : : {
797 : 52 : const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4);
798 : 52 : gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name);
799 : 52 : tree tmp = gfc_get_symbol_decl (exsym);
800 : 52 : return build_call_expr_loc (input_location, tmp, 1, integer_zero_node);
801 : : }
802 : :
803 : : /* Translate the FAIL IMAGE statement. */
804 : :
805 : : tree
806 : 3 : gfc_trans_fail_image (gfc_code *code ATTRIBUTE_UNUSED)
807 : : {
808 : 3 : if (flag_coarray == GFC_FCOARRAY_LIB)
809 : 2 : return build_call_expr_loc (input_location,
810 : 2 : gfor_fndecl_caf_fail_image, 0);
811 : : else
812 : 1 : return trans_exit ();
813 : : }
814 : :
815 : : void
816 : 423 : gfc_trans_sync_stat (struct sync_stat *sync_stat, gfc_se *se, tree *stat,
817 : : tree *errmsg, tree *errmsg_len)
818 : : {
819 : 423 : gfc_se argse;
820 : :
821 : 423 : if (sync_stat->stat)
822 : : {
823 : 72 : gfc_init_se (&argse, NULL);
824 : 72 : gfc_conv_expr (&argse, sync_stat->stat);
825 : 72 : gfc_add_block_to_block (&se->pre, &argse.pre);
826 : :
827 : 72 : if (TREE_TYPE (argse.expr) != integer_type_node)
828 : : {
829 : 6 : tree tstat = gfc_create_var (integer_type_node, "stat");
830 : 6 : TREE_THIS_VOLATILE (tstat) = 1;
831 : 6 : gfc_add_modify (&se->pre, tstat,
832 : : fold_convert (integer_type_node, argse.expr));
833 : 6 : gfc_add_modify (&se->post, argse.expr,
834 : 6 : fold_convert (TREE_TYPE (argse.expr), tstat));
835 : 6 : *stat = build_fold_addr_expr (tstat);
836 : : }
837 : : else
838 : 66 : *stat = build_fold_addr_expr (argse.expr);
839 : : }
840 : : else
841 : 351 : *stat = null_pointer_node;
842 : :
843 : 423 : if (sync_stat->errmsg)
844 : : {
845 : 42 : gfc_init_se (&argse, NULL);
846 : 42 : gfc_conv_expr_reference (&argse, sync_stat->errmsg);
847 : 42 : gfc_add_block_to_block (&se->pre, &argse.pre);
848 : 42 : *errmsg = argse.expr;
849 : 42 : *errmsg_len = fold_convert (size_type_node, argse.string_length);
850 : : }
851 : : else
852 : : {
853 : 381 : *errmsg = null_pointer_node;
854 : 381 : *errmsg_len = build_zero_cst (size_type_node);
855 : : }
856 : 423 : }
857 : :
858 : : /* Translate the FORM TEAM statement. */
859 : :
860 : : tree
861 : 96 : gfc_trans_form_team (gfc_code *code)
862 : : {
863 : 96 : if (flag_coarray == GFC_FCOARRAY_LIB)
864 : : {
865 : 64 : gfc_se se, argse;
866 : 64 : tree team_id, team_type, new_index, stat, errmsg, errmsg_len, tmp;
867 : :
868 : 64 : gfc_init_se (&se, NULL);
869 : 64 : gfc_init_se (&argse, NULL);
870 : :
871 : 64 : gfc_conv_expr_val (&argse, code->expr1);
872 : 64 : team_id = fold_convert (integer_type_node, argse.expr);
873 : 64 : gfc_conv_expr_reference (&argse, code->expr2);
874 : 64 : team_type = argse.expr;
875 : :
876 : : /* NEW_INDEX=. */
877 : 64 : if (code->expr3)
878 : : {
879 : 25 : gfc_conv_expr_reference (&argse, code->expr3);
880 : 25 : new_index = argse.expr;
881 : : }
882 : : else
883 : 39 : new_index = null_pointer_node;
884 : :
885 : 64 : gfc_add_block_to_block (&se.post, &argse.post);
886 : :
887 : 64 : gfc_trans_sync_stat (&code->ext.sync_stat, &se, &stat, &errmsg,
888 : : &errmsg_len);
889 : :
890 : 64 : gfc_add_block_to_block (&se.pre, &argse.pre);
891 : :
892 : 64 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_form_team, 6,
893 : : team_id, team_type, new_index, stat, errmsg,
894 : : errmsg_len);
895 : 64 : gfc_add_expr_to_block (&se.pre, tmp);
896 : 64 : gfc_add_block_to_block (&se.pre, &se.post);
897 : 64 : return gfc_finish_block (&se.pre);
898 : : }
899 : : else
900 : 32 : return trans_exit ();
901 : : }
902 : :
903 : : /* Translate the CHANGE TEAM statement. */
904 : :
905 : : tree
906 : 51 : gfc_trans_change_team (gfc_code *code)
907 : : {
908 : 51 : if (flag_coarray == GFC_FCOARRAY_LIB)
909 : : {
910 : 32 : stmtblock_t block;
911 : 32 : gfc_se se;
912 : 32 : tree team_type, stat, errmsg, errmsg_len, tmp;
913 : :
914 : 32 : gfc_init_se (&se, NULL);
915 : 32 : gfc_start_block (&block);
916 : :
917 : 32 : gfc_conv_expr_val (&se, code->expr1);
918 : 32 : team_type = se.expr;
919 : :
920 : 32 : gfc_trans_sync_stat (&code->ext.block.sync_stat, &se, &stat, &errmsg,
921 : : &errmsg_len);
922 : :
923 : 32 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_change_team, 4,
924 : : team_type, stat, errmsg, errmsg_len);
925 : :
926 : 32 : gfc_add_expr_to_block (&se.pre, tmp);
927 : 32 : gfc_add_block_to_block (&se.pre, &se.post);
928 : 32 : gfc_add_block_to_block (&block, &se.pre);
929 : 32 : gfc_add_expr_to_block (&block, gfc_trans_block_construct (code));
930 : 32 : return gfc_finish_block (&block);
931 : : }
932 : : else
933 : 19 : return trans_exit ();
934 : : }
935 : :
936 : : /* Translate the END TEAM statement. */
937 : :
938 : : tree
939 : 32 : gfc_trans_end_team (gfc_code *code)
940 : : {
941 : 32 : if (flag_coarray == GFC_FCOARRAY_LIB)
942 : : {
943 : 32 : gfc_se se;
944 : 32 : tree stat, errmsg, errmsg_len, tmp;
945 : :
946 : 32 : gfc_init_se (&se, NULL);
947 : 32 : gfc_start_block (&se.pre);
948 : :
949 : 32 : gfc_trans_sync_stat (&code->ext.sync_stat, &se, &stat, &errmsg,
950 : : &errmsg_len);
951 : :
952 : 32 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_end_team, 3,
953 : : stat, errmsg, errmsg_len);
954 : 32 : gfc_add_expr_to_block (&se.pre, tmp);
955 : 32 : gfc_add_block_to_block (&se.pre, &se.post);
956 : 32 : return gfc_finish_block (&se.pre);
957 : : }
958 : : else
959 : 0 : return trans_exit ();
960 : : }
961 : :
962 : : /* Translate the SYNC TEAM statement. */
963 : :
964 : : tree
965 : 18 : gfc_trans_sync_team (gfc_code *code)
966 : : {
967 : 18 : if (flag_coarray == GFC_FCOARRAY_LIB)
968 : : {
969 : 18 : gfc_se se;
970 : 18 : tree team_type, stat, errmsg, errmsg_len, tmp;
971 : :
972 : 18 : gfc_init_se (&se, NULL);
973 : :
974 : 18 : gfc_conv_expr_val (&se, code->expr1);
975 : 18 : team_type = se.expr;
976 : :
977 : 18 : gfc_trans_sync_stat (&code->ext.sync_stat, &se, &stat, &errmsg,
978 : : &errmsg_len);
979 : :
980 : 18 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_team, 4,
981 : : team_type, stat, errmsg, errmsg_len);
982 : 18 : gfc_add_expr_to_block (&se.pre, tmp);
983 : 18 : gfc_add_block_to_block (&se.pre, &se.post);
984 : 18 : return gfc_finish_block (&se.pre);
985 : : }
986 : : else
987 : 0 : return trans_exit ();
988 : : }
989 : :
990 : : tree
991 : 84 : gfc_trans_lock_unlock (gfc_code *code, gfc_exec_op op)
992 : : {
993 : 84 : gfc_se se, argse;
994 : 84 : tree stat = NULL_TREE, stat2 = NULL_TREE;
995 : 84 : tree lock_acquired = NULL_TREE, lock_acquired2 = NULL_TREE;
996 : :
997 : : /* Short cut: For single images without STAT= or LOCK_ACQUIRED
998 : : return early. (ERRMSG= is always untouched for -fcoarray=single.) */
999 : 84 : if (!code->expr2 && !code->expr4 && flag_coarray != GFC_FCOARRAY_LIB)
1000 : : return NULL_TREE;
1001 : :
1002 : 66 : if (code->expr2)
1003 : : {
1004 : 28 : gcc_assert (code->expr2->expr_type == EXPR_VARIABLE);
1005 : 28 : gfc_init_se (&argse, NULL);
1006 : 28 : gfc_conv_expr_val (&argse, code->expr2);
1007 : 28 : stat = argse.expr;
1008 : : }
1009 : 38 : else if (flag_coarray == GFC_FCOARRAY_LIB)
1010 : 32 : stat = null_pointer_node;
1011 : :
1012 : 66 : if (code->expr4)
1013 : : {
1014 : 14 : gcc_assert (code->expr4->expr_type == EXPR_VARIABLE);
1015 : 14 : gfc_init_se (&argse, NULL);
1016 : 14 : gfc_conv_expr_val (&argse, code->expr4);
1017 : 14 : lock_acquired = argse.expr;
1018 : : }
1019 : 52 : else if (flag_coarray == GFC_FCOARRAY_LIB)
1020 : 40 : lock_acquired = null_pointer_node;
1021 : :
1022 : 66 : gfc_start_block (&se.pre);
1023 : 66 : if (flag_coarray == GFC_FCOARRAY_LIB)
1024 : : {
1025 : 48 : tree tmp, token, image_index, errmsg, errmsg_len;
1026 : 48 : tree index = build_zero_cst (gfc_array_index_type);
1027 : 48 : tree caf_decl = gfc_get_tree_for_caf_expr (code->expr1);
1028 : :
1029 : 48 : if (code->expr1->symtree->n.sym->ts.type != BT_DERIVED
1030 : 48 : || code->expr1->symtree->n.sym->ts.u.derived->from_intmod
1031 : : != INTMOD_ISO_FORTRAN_ENV
1032 : 44 : || code->expr1->symtree->n.sym->ts.u.derived->intmod_sym_id
1033 : : != ISOFORTRAN_LOCK_TYPE)
1034 : : {
1035 : 4 : gfc_error ("Sorry, the lock component of derived type at %L is not "
1036 : : "yet supported", &code->expr1->where);
1037 : 4 : return NULL_TREE;
1038 : : }
1039 : :
1040 : 44 : gfc_get_caf_token_offset (&se, &token, NULL, caf_decl, NULL_TREE,
1041 : : code->expr1);
1042 : :
1043 : 44 : if (gfc_is_coindexed (code->expr1))
1044 : 16 : image_index = gfc_caf_get_image_index (&se.pre, code->expr1, caf_decl);
1045 : : else
1046 : 28 : image_index = integer_zero_node;
1047 : :
1048 : : /* For arrays, obtain the array index. */
1049 : 44 : if (gfc_expr_attr (code->expr1).dimension)
1050 : : {
1051 : 28 : tree desc, tmp, extent, lbound, ubound;
1052 : 28 : gfc_array_ref *ar, ar2;
1053 : 28 : int i, rank;
1054 : :
1055 : : /* TODO: Extend this, once DT components are supported. */
1056 : 28 : ar = &code->expr1->ref->u.ar;
1057 : 28 : ar2 = *ar;
1058 : 28 : memset (ar, '\0', sizeof (*ar));
1059 : 28 : ar->as = ar2.as;
1060 : 28 : ar->type = AR_FULL;
1061 : 28 : rank = code->expr1->rank;
1062 : 28 : code->expr1->rank = ar->as->rank;
1063 : :
1064 : 28 : gfc_init_se (&argse, NULL);
1065 : 28 : argse.descriptor_only = 1;
1066 : 28 : gfc_conv_expr_descriptor (&argse, code->expr1);
1067 : 28 : gfc_add_block_to_block (&se.pre, &argse.pre);
1068 : 28 : desc = argse.expr;
1069 : 28 : *ar = ar2;
1070 : 28 : code->expr1->rank = rank;
1071 : :
1072 : 28 : extent = build_one_cst (gfc_array_index_type);
1073 : 98 : for (i = 0; i < ar->dimen; i++)
1074 : : {
1075 : 42 : gfc_init_se (&argse, NULL);
1076 : 42 : gfc_conv_expr_type (&argse, ar->start[i], gfc_array_index_type);
1077 : 42 : gfc_add_block_to_block (&argse.pre, &argse.pre);
1078 : 42 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
1079 : 42 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
1080 : 42 : TREE_TYPE (lbound), argse.expr, lbound);
1081 : 42 : tmp = fold_build2_loc (input_location, MULT_EXPR,
1082 : 42 : TREE_TYPE (tmp), extent, tmp);
1083 : 42 : index = fold_build2_loc (input_location, PLUS_EXPR,
1084 : 42 : TREE_TYPE (tmp), index, tmp);
1085 : 42 : if (i < ar->dimen - 1)
1086 : : {
1087 : 14 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
1088 : 14 : tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
1089 : 14 : extent = fold_build2_loc (input_location, MULT_EXPR,
1090 : 14 : TREE_TYPE (tmp), extent, tmp);
1091 : : }
1092 : : }
1093 : : }
1094 : :
1095 : : /* errmsg. */
1096 : 44 : if (code->expr3)
1097 : : {
1098 : 0 : gfc_init_se (&argse, NULL);
1099 : 0 : argse.want_pointer = 1;
1100 : 0 : gfc_conv_expr (&argse, code->expr3);
1101 : 0 : gfc_add_block_to_block (&se.pre, &argse.pre);
1102 : 0 : errmsg = argse.expr;
1103 : 0 : errmsg_len = fold_convert (size_type_node, argse.string_length);
1104 : : }
1105 : : else
1106 : : {
1107 : 44 : errmsg = null_pointer_node;
1108 : 44 : errmsg_len = build_zero_cst (size_type_node);
1109 : : }
1110 : :
1111 : 44 : if (stat != null_pointer_node && TREE_TYPE (stat) != integer_type_node)
1112 : : {
1113 : 0 : stat2 = stat;
1114 : 0 : stat = gfc_create_var (integer_type_node, "stat");
1115 : : }
1116 : :
1117 : 44 : if (lock_acquired != null_pointer_node
1118 : 44 : && TREE_TYPE (lock_acquired) != integer_type_node)
1119 : : {
1120 : 8 : lock_acquired2 = lock_acquired;
1121 : 8 : lock_acquired = gfc_create_var (integer_type_node, "acquired");
1122 : : }
1123 : :
1124 : 44 : index = fold_convert (size_type_node, index);
1125 : 44 : if (op == EXEC_LOCK)
1126 : 22 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_lock, 7,
1127 : : token, index, image_index,
1128 : 22 : lock_acquired != null_pointer_node
1129 : 8 : ? gfc_build_addr_expr (NULL, lock_acquired)
1130 : : : lock_acquired,
1131 : 22 : stat != null_pointer_node
1132 : 8 : ? gfc_build_addr_expr (NULL, stat) : stat,
1133 : : errmsg, errmsg_len);
1134 : : else
1135 : 22 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_unlock, 6,
1136 : : token, index, image_index,
1137 : 22 : stat != null_pointer_node
1138 : 8 : ? gfc_build_addr_expr (NULL, stat) : stat,
1139 : : errmsg, errmsg_len);
1140 : 44 : gfc_add_expr_to_block (&se.pre, tmp);
1141 : :
1142 : : /* It guarantees memory consistency within the same segment */
1143 : 44 : tmp = gfc_build_string_const (strlen ("memory")+1, "memory"),
1144 : 44 : tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
1145 : : gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
1146 : : tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
1147 : 44 : ASM_VOLATILE_P (tmp) = 1;
1148 : :
1149 : 44 : gfc_add_expr_to_block (&se.pre, tmp);
1150 : :
1151 : 44 : if (stat2 != NULL_TREE)
1152 : 0 : gfc_add_modify (&se.pre, stat2,
1153 : 0 : fold_convert (TREE_TYPE (stat2), stat));
1154 : :
1155 : 44 : if (lock_acquired2 != NULL_TREE)
1156 : 8 : gfc_add_modify (&se.pre, lock_acquired2,
1157 : 8 : fold_convert (TREE_TYPE (lock_acquired2),
1158 : : lock_acquired));
1159 : :
1160 : 44 : return gfc_finish_block (&se.pre);
1161 : : }
1162 : :
1163 : 18 : if (stat != NULL_TREE)
1164 : 12 : gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
1165 : :
1166 : 18 : if (lock_acquired != NULL_TREE)
1167 : 6 : gfc_add_modify (&se.pre, lock_acquired,
1168 : 6 : fold_convert (TREE_TYPE (lock_acquired),
1169 : : boolean_true_node));
1170 : :
1171 : 18 : return gfc_finish_block (&se.pre);
1172 : : }
1173 : :
1174 : : tree
1175 : 39 : gfc_trans_event_post_wait (gfc_code *code, gfc_exec_op op)
1176 : : {
1177 : 39 : gfc_se se, argse;
1178 : 39 : tree stat = NULL_TREE, stat2 = NULL_TREE;
1179 : 39 : tree until_count = NULL_TREE;
1180 : :
1181 : 39 : if (code->expr2)
1182 : : {
1183 : 8 : gcc_assert (code->expr2->expr_type == EXPR_VARIABLE);
1184 : 8 : gfc_init_se (&argse, NULL);
1185 : 8 : gfc_conv_expr_val (&argse, code->expr2);
1186 : 8 : stat = argse.expr;
1187 : : }
1188 : 31 : else if (flag_coarray == GFC_FCOARRAY_LIB)
1189 : 16 : stat = null_pointer_node;
1190 : :
1191 : 39 : if (code->expr4)
1192 : : {
1193 : 12 : gfc_init_se (&argse, NULL);
1194 : 12 : gfc_conv_expr_val (&argse, code->expr4);
1195 : 12 : until_count = fold_convert (integer_type_node, argse.expr);
1196 : : }
1197 : : else
1198 : 27 : until_count = integer_one_node;
1199 : :
1200 : 39 : if (flag_coarray != GFC_FCOARRAY_LIB)
1201 : : {
1202 : 19 : gfc_start_block (&se.pre);
1203 : 19 : gfc_init_se (&argse, NULL);
1204 : 19 : gfc_conv_expr_val (&argse, code->expr1);
1205 : :
1206 : 19 : if (op == EXEC_EVENT_POST)
1207 : 22 : gfc_add_modify (&se.pre, argse.expr,
1208 : : fold_build2_loc (input_location, PLUS_EXPR,
1209 : 11 : TREE_TYPE (argse.expr), argse.expr,
1210 : 11 : build_int_cst (TREE_TYPE (argse.expr), 1)));
1211 : : else
1212 : 16 : gfc_add_modify (&se.pre, argse.expr,
1213 : : fold_build2_loc (input_location, MINUS_EXPR,
1214 : 8 : TREE_TYPE (argse.expr), argse.expr,
1215 : 8 : fold_convert (TREE_TYPE (argse.expr),
1216 : : until_count)));
1217 : 19 : if (stat != NULL_TREE)
1218 : 4 : gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
1219 : :
1220 : 19 : return gfc_finish_block (&se.pre);
1221 : : }
1222 : :
1223 : 20 : gfc_start_block (&se.pre);
1224 : 20 : tree tmp, token, image_index, errmsg, errmsg_len;
1225 : 20 : tree index = build_zero_cst (gfc_array_index_type);
1226 : 20 : tree caf_decl = gfc_get_tree_for_caf_expr (code->expr1);
1227 : :
1228 : 20 : if (code->expr1->symtree->n.sym->ts.type != BT_DERIVED
1229 : 20 : || code->expr1->symtree->n.sym->ts.u.derived->from_intmod
1230 : : != INTMOD_ISO_FORTRAN_ENV
1231 : 20 : || code->expr1->symtree->n.sym->ts.u.derived->intmod_sym_id
1232 : : != ISOFORTRAN_EVENT_TYPE)
1233 : : {
1234 : 0 : gfc_error ("Sorry, the event component of derived type at %L is not "
1235 : : "yet supported", &code->expr1->where);
1236 : 0 : return NULL_TREE;
1237 : : }
1238 : :
1239 : 20 : gfc_init_se (&argse, NULL);
1240 : 20 : gfc_get_caf_token_offset (&argse, &token, NULL, caf_decl, NULL_TREE,
1241 : : code->expr1);
1242 : 20 : gfc_add_block_to_block (&se.pre, &argse.pre);
1243 : :
1244 : 20 : if (gfc_is_coindexed (code->expr1))
1245 : 6 : image_index = gfc_caf_get_image_index (&se.pre, code->expr1, caf_decl);
1246 : : else
1247 : 14 : image_index = integer_zero_node;
1248 : :
1249 : : /* For arrays, obtain the array index. */
1250 : 20 : if (gfc_expr_attr (code->expr1).dimension)
1251 : : {
1252 : 7 : tree desc, tmp, extent, lbound, ubound;
1253 : 7 : gfc_array_ref *ar, ar2;
1254 : 7 : int i;
1255 : :
1256 : : /* TODO: Extend this, once DT components are supported. */
1257 : 7 : ar = &code->expr1->ref->u.ar;
1258 : 7 : ar2 = *ar;
1259 : 7 : memset (ar, '\0', sizeof (*ar));
1260 : 7 : ar->as = ar2.as;
1261 : 7 : ar->type = AR_FULL;
1262 : :
1263 : 7 : gfc_init_se (&argse, NULL);
1264 : 7 : argse.descriptor_only = 1;
1265 : 7 : gfc_conv_expr_descriptor (&argse, code->expr1);
1266 : 7 : gfc_add_block_to_block (&se.pre, &argse.pre);
1267 : 7 : desc = argse.expr;
1268 : 7 : *ar = ar2;
1269 : :
1270 : 7 : extent = build_one_cst (gfc_array_index_type);
1271 : 21 : for (i = 0; i < ar->dimen; i++)
1272 : : {
1273 : 7 : gfc_init_se (&argse, NULL);
1274 : 7 : gfc_conv_expr_type (&argse, ar->start[i], gfc_array_index_type);
1275 : 7 : gfc_add_block_to_block (&argse.pre, &argse.pre);
1276 : 7 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
1277 : 7 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
1278 : 7 : TREE_TYPE (lbound), argse.expr, lbound);
1279 : 7 : tmp = fold_build2_loc (input_location, MULT_EXPR,
1280 : 7 : TREE_TYPE (tmp), extent, tmp);
1281 : 7 : index = fold_build2_loc (input_location, PLUS_EXPR,
1282 : 7 : TREE_TYPE (tmp), index, tmp);
1283 : 7 : if (i < ar->dimen - 1)
1284 : : {
1285 : 0 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
1286 : 0 : tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
1287 : 0 : extent = fold_build2_loc (input_location, MULT_EXPR,
1288 : 0 : TREE_TYPE (tmp), extent, tmp);
1289 : : }
1290 : : }
1291 : : }
1292 : :
1293 : : /* errmsg. */
1294 : 20 : if (code->expr3)
1295 : : {
1296 : 0 : gfc_init_se (&argse, NULL);
1297 : 0 : argse.want_pointer = 1;
1298 : 0 : gfc_conv_expr (&argse, code->expr3);
1299 : 0 : gfc_add_block_to_block (&se.pre, &argse.pre);
1300 : 0 : errmsg = argse.expr;
1301 : 0 : errmsg_len = fold_convert (size_type_node, argse.string_length);
1302 : : }
1303 : : else
1304 : : {
1305 : 20 : errmsg = null_pointer_node;
1306 : 20 : errmsg_len = build_zero_cst (size_type_node);
1307 : : }
1308 : :
1309 : 20 : if (stat != null_pointer_node && TREE_TYPE (stat) != integer_type_node)
1310 : : {
1311 : 0 : stat2 = stat;
1312 : 0 : stat = gfc_create_var (integer_type_node, "stat");
1313 : : }
1314 : :
1315 : 20 : index = fold_convert (size_type_node, index);
1316 : 20 : if (op == EXEC_EVENT_POST)
1317 : 12 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_event_post, 6,
1318 : : token, index, image_index,
1319 : 12 : stat != null_pointer_node
1320 : 2 : ? gfc_build_addr_expr (NULL, stat) : stat,
1321 : : errmsg, errmsg_len);
1322 : : else
1323 : 8 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_event_wait, 6,
1324 : : token, index, until_count,
1325 : 8 : stat != null_pointer_node
1326 : 2 : ? gfc_build_addr_expr (NULL, stat) : stat,
1327 : : errmsg, errmsg_len);
1328 : 20 : gfc_add_expr_to_block (&se.pre, tmp);
1329 : :
1330 : : /* It guarantees memory consistency within the same segment */
1331 : 20 : tmp = gfc_build_string_const (strlen ("memory")+1, "memory"),
1332 : 20 : tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
1333 : : gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
1334 : : tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
1335 : 20 : ASM_VOLATILE_P (tmp) = 1;
1336 : 20 : gfc_add_expr_to_block (&se.pre, tmp);
1337 : :
1338 : 20 : if (stat2 != NULL_TREE)
1339 : 0 : gfc_add_modify (&se.pre, stat2, fold_convert (TREE_TYPE (stat2), stat));
1340 : :
1341 : 20 : return gfc_finish_block (&se.pre);
1342 : : }
1343 : :
1344 : : tree
1345 : 718 : gfc_trans_sync (gfc_code *code, gfc_exec_op type)
1346 : : {
1347 : 718 : gfc_se se, argse;
1348 : 718 : tree tmp;
1349 : 718 : tree images = NULL_TREE, stat = NULL_TREE,
1350 : 718 : errmsg = NULL_TREE, errmsglen = NULL_TREE;
1351 : :
1352 : : /* Short cut: For single images without bound checking or without STAT=,
1353 : : return early. (ERRMSG= is always untouched for -fcoarray=single.) */
1354 : 718 : if (!code->expr2 && !(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1355 : 620 : && flag_coarray != GFC_FCOARRAY_LIB)
1356 : : return NULL_TREE;
1357 : :
1358 : 392 : gfc_init_se (&se, NULL);
1359 : 392 : gfc_start_block (&se.pre);
1360 : :
1361 : 392 : if (code->expr1 && code->expr1->rank == 0)
1362 : : {
1363 : 13 : gfc_init_se (&argse, NULL);
1364 : 13 : gfc_conv_expr_val (&argse, code->expr1);
1365 : 13 : images = argse.expr;
1366 : : }
1367 : :
1368 : 392 : if (code->expr2)
1369 : : {
1370 : 71 : gcc_assert (code->expr2->expr_type == EXPR_VARIABLE
1371 : : || code->expr2->expr_type == EXPR_FUNCTION);
1372 : 71 : gfc_init_se (&argse, NULL);
1373 : 71 : gfc_conv_expr_val (&argse, code->expr2);
1374 : 71 : stat = argse.expr;
1375 : : }
1376 : : else
1377 : 321 : stat = null_pointer_node;
1378 : :
1379 : 392 : if (code->expr3 && flag_coarray == GFC_FCOARRAY_LIB)
1380 : : {
1381 : 14 : gcc_assert (code->expr3->expr_type == EXPR_VARIABLE
1382 : : || code->expr3->expr_type == EXPR_FUNCTION);
1383 : 14 : gfc_init_se (&argse, NULL);
1384 : 14 : argse.want_pointer = 1;
1385 : 14 : gfc_conv_expr (&argse, code->expr3);
1386 : 14 : gfc_conv_string_parameter (&argse);
1387 : 14 : errmsg = gfc_build_addr_expr (NULL, argse.expr);
1388 : 14 : errmsglen = fold_convert (size_type_node, argse.string_length);
1389 : : }
1390 : 378 : else if (flag_coarray == GFC_FCOARRAY_LIB)
1391 : : {
1392 : 318 : errmsg = null_pointer_node;
1393 : 318 : errmsglen = build_int_cst (size_type_node, 0);
1394 : : }
1395 : :
1396 : : /* Check SYNC IMAGES(imageset) for valid image index.
1397 : : FIXME: Add a check for image-set arrays. */
1398 : 392 : if (code->expr1 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1399 : 13 : && code->expr1->rank == 0)
1400 : : {
1401 : 11 : tree images2 = fold_convert (integer_type_node, images);
1402 : 11 : tree cond;
1403 : 11 : if (flag_coarray != GFC_FCOARRAY_LIB)
1404 : 4 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1405 : 4 : images, build_int_cst (TREE_TYPE (images), 1));
1406 : : else
1407 : : {
1408 : 7 : tree cond2;
1409 : 7 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images,
1410 : : 2, null_pointer_node, null_pointer_node);
1411 : 7 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
1412 : : images2, tmp);
1413 : 7 : cond2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
1414 : : images,
1415 : 7 : build_int_cst (TREE_TYPE (images), 1));
1416 : 7 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1417 : : logical_type_node, cond, cond2);
1418 : : }
1419 : 11 : gfc_trans_runtime_check (true, false, cond, &se.pre,
1420 : 11 : &code->expr1->where, "Invalid image number "
1421 : : "%d in SYNC IMAGES", images2);
1422 : : }
1423 : :
1424 : : /* Per F2008, 8.5.1, a SYNC MEMORY is implied by calling the
1425 : : image control statements SYNC IMAGES and SYNC ALL. */
1426 : 392 : if (flag_coarray == GFC_FCOARRAY_LIB)
1427 : : {
1428 : 332 : tmp = gfc_build_string_const (strlen ("memory")+1, "memory"),
1429 : 332 : tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
1430 : : gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
1431 : : tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
1432 : 332 : ASM_VOLATILE_P (tmp) = 1;
1433 : 332 : gfc_add_expr_to_block (&se.pre, tmp);
1434 : : }
1435 : :
1436 : 392 : if (flag_coarray != GFC_FCOARRAY_LIB)
1437 : : {
1438 : : /* Set STAT to zero. */
1439 : 60 : if (code->expr2)
1440 : 48 : gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
1441 : : }
1442 : 332 : else if (type == EXEC_SYNC_ALL || type == EXEC_SYNC_MEMORY)
1443 : : {
1444 : : /* SYNC ALL => stat == null_pointer_node
1445 : : SYNC ALL(stat=s) => stat has an integer type
1446 : :
1447 : : If "stat" has the wrong integer type, use a temp variable of
1448 : : the right type and later cast the result back into "stat". */
1449 : 315 : if (stat == null_pointer_node || TREE_TYPE (stat) == integer_type_node)
1450 : : {
1451 : 315 : if (TREE_TYPE (stat) == integer_type_node)
1452 : 19 : stat = gfc_build_addr_expr (NULL, stat);
1453 : :
1454 : 315 : if(type == EXEC_SYNC_MEMORY)
1455 : 14 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_memory,
1456 : : 3, stat, errmsg, errmsglen);
1457 : : else
1458 : 301 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all,
1459 : : 3, stat, errmsg, errmsglen);
1460 : :
1461 : 315 : gfc_add_expr_to_block (&se.pre, tmp);
1462 : : }
1463 : : else
1464 : : {
1465 : 0 : tree tmp_stat = gfc_create_var (integer_type_node, "stat");
1466 : :
1467 : 0 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all,
1468 : : 3, gfc_build_addr_expr (NULL, tmp_stat),
1469 : : errmsg, errmsglen);
1470 : 0 : gfc_add_expr_to_block (&se.pre, tmp);
1471 : :
1472 : 0 : gfc_add_modify (&se.pre, stat,
1473 : 0 : fold_convert (TREE_TYPE (stat), tmp_stat));
1474 : : }
1475 : : }
1476 : : else
1477 : : {
1478 : 17 : tree len;
1479 : :
1480 : 17 : gcc_assert (type == EXEC_SYNC_IMAGES);
1481 : :
1482 : 17 : if (!code->expr1)
1483 : : {
1484 : 6 : len = build_int_cst (integer_type_node, -1);
1485 : 6 : images = null_pointer_node;
1486 : : }
1487 : 11 : else if (code->expr1->rank == 0)
1488 : : {
1489 : 9 : len = integer_one_node;
1490 : 9 : images = gfc_build_addr_expr (NULL_TREE, images);
1491 : : }
1492 : : else
1493 : : {
1494 : : /* FIXME. */
1495 : 2 : if (code->expr1->ts.kind != gfc_c_int_kind)
1496 : 0 : gfc_fatal_error ("Sorry, only support for integer kind %d "
1497 : : "implemented for image-set at %L",
1498 : : gfc_c_int_kind, &code->expr1->where);
1499 : :
1500 : 2 : gfc_conv_array_parameter (&se, code->expr1, true, NULL, NULL, &len);
1501 : 2 : images = se.expr;
1502 : :
1503 : 2 : tmp = gfc_typenode_for_spec (&code->expr1->ts);
1504 : 2 : if (GFC_ARRAY_TYPE_P (tmp) || GFC_DESCRIPTOR_TYPE_P (tmp))
1505 : 0 : tmp = gfc_get_element_type (tmp);
1506 : :
1507 : 4 : len = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
1508 : 2 : TREE_TYPE (len), len,
1509 : 2 : fold_convert (TREE_TYPE (len),
1510 : : TYPE_SIZE_UNIT (tmp)));
1511 : 2 : len = fold_convert (integer_type_node, len);
1512 : : }
1513 : :
1514 : : /* SYNC IMAGES(imgs) => stat == null_pointer_node
1515 : : SYNC IMAGES(imgs,stat=s) => stat has an integer type
1516 : :
1517 : : If "stat" has the wrong integer type, use a temp variable of
1518 : : the right type and later cast the result back into "stat". */
1519 : 17 : if (stat == null_pointer_node || TREE_TYPE (stat) == integer_type_node)
1520 : : {
1521 : 17 : if (TREE_TYPE (stat) == integer_type_node)
1522 : 4 : stat = gfc_build_addr_expr (NULL, stat);
1523 : :
1524 : 17 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_images,
1525 : : 5, fold_convert (integer_type_node, len),
1526 : : images, stat, errmsg, errmsglen);
1527 : 17 : gfc_add_expr_to_block (&se.pre, tmp);
1528 : : }
1529 : : else
1530 : : {
1531 : 0 : tree tmp_stat = gfc_create_var (integer_type_node, "stat");
1532 : :
1533 : 0 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_images,
1534 : : 5, fold_convert (integer_type_node, len),
1535 : : images, gfc_build_addr_expr (NULL, tmp_stat),
1536 : : errmsg, errmsglen);
1537 : 0 : gfc_add_expr_to_block (&se.pre, tmp);
1538 : :
1539 : 0 : gfc_add_modify (&se.pre, stat,
1540 : 0 : fold_convert (TREE_TYPE (stat), tmp_stat));
1541 : : }
1542 : : }
1543 : :
1544 : 392 : return gfc_finish_block (&se.pre);
1545 : : }
1546 : :
1547 : :
1548 : : /* Generate GENERIC for the IF construct. This function also deals with
1549 : : the simple IF statement, because the front end translates the IF
1550 : : statement into an IF construct.
1551 : :
1552 : : We translate:
1553 : :
1554 : : IF (cond) THEN
1555 : : then_clause
1556 : : ELSEIF (cond2)
1557 : : elseif_clause
1558 : : ELSE
1559 : : else_clause
1560 : : ENDIF
1561 : :
1562 : : into:
1563 : :
1564 : : pre_cond_s;
1565 : : if (cond_s)
1566 : : {
1567 : : then_clause;
1568 : : }
1569 : : else
1570 : : {
1571 : : pre_cond_s
1572 : : if (cond_s)
1573 : : {
1574 : : elseif_clause
1575 : : }
1576 : : else
1577 : : {
1578 : : else_clause;
1579 : : }
1580 : : }
1581 : :
1582 : : where COND_S is the simplified version of the predicate. PRE_COND_S
1583 : : are the pre side-effects produced by the translation of the
1584 : : conditional.
1585 : : We need to build the chain recursively otherwise we run into
1586 : : problems with folding incomplete statements. */
1587 : :
1588 : : static tree
1589 : 240297 : gfc_trans_if_1 (gfc_code * code)
1590 : : {
1591 : 240297 : gfc_se if_se;
1592 : 240297 : tree stmt, elsestmt;
1593 : 240297 : location_t loc, saved_loc = UNKNOWN_LOCATION;
1594 : :
1595 : : /* Check for an unconditional ELSE clause. */
1596 : 240297 : if (!code->expr1)
1597 : 6619 : return gfc_trans_code (code->next);
1598 : :
1599 : : /* Initialize a statement builder for each block. Puts in NULL_TREEs. */
1600 : 233678 : gfc_init_se (&if_se, NULL);
1601 : 233678 : gfc_start_block (&if_se.pre);
1602 : :
1603 : : /* Calculate the IF condition expression. */
1604 : 233678 : if (GFC_LOCUS_IS_SET (code->expr1->where))
1605 : : {
1606 : 233678 : saved_loc = input_location;
1607 : 233678 : input_location = gfc_get_location (&code->expr1->where);
1608 : : }
1609 : :
1610 : 233678 : gfc_conv_expr_val (&if_se, code->expr1);
1611 : :
1612 : 233678 : if (saved_loc != UNKNOWN_LOCATION)
1613 : 233678 : input_location = saved_loc;
1614 : :
1615 : : /* Translate the THEN clause. */
1616 : 233678 : stmt = gfc_trans_code (code->next);
1617 : :
1618 : : /* Translate the ELSE clause. */
1619 : 233678 : if (code->block)
1620 : 6861 : elsestmt = gfc_trans_if_1 (code->block);
1621 : : else
1622 : 226817 : elsestmt = build_empty_stmt (input_location);
1623 : :
1624 : : /* Build the condition expression and add it to the condition block. */
1625 : 466808 : loc = (GFC_LOCUS_IS_SET (code->expr1->where)
1626 : 466808 : ? gfc_get_location (&code->expr1->where) : input_location);
1627 : 233678 : stmt = fold_build3_loc (loc, COND_EXPR, void_type_node, if_se.expr, stmt,
1628 : : elsestmt);
1629 : :
1630 : 233678 : gfc_add_expr_to_block (&if_se.pre, stmt);
1631 : :
1632 : : /* Finish off this statement. */
1633 : 233678 : return gfc_finish_block (&if_se.pre);
1634 : : }
1635 : :
1636 : : tree
1637 : 233436 : gfc_trans_if (gfc_code * code)
1638 : : {
1639 : 233436 : stmtblock_t body;
1640 : 233436 : tree exit_label;
1641 : :
1642 : : /* Create exit label so it is available for trans'ing the body code. */
1643 : 233436 : exit_label = gfc_build_label_decl (NULL_TREE);
1644 : 233436 : code->exit_label = exit_label;
1645 : :
1646 : : /* Translate the actual code in code->block. */
1647 : 233436 : gfc_init_block (&body);
1648 : 233436 : gfc_add_expr_to_block (&body, gfc_trans_if_1 (code->block));
1649 : :
1650 : : /* Add exit label. */
1651 : 233436 : gfc_add_expr_to_block (&body, build1_v (LABEL_EXPR, exit_label));
1652 : :
1653 : 233436 : return gfc_finish_block (&body);
1654 : : }
1655 : :
1656 : :
1657 : : /* Translate an arithmetic IF expression.
1658 : :
1659 : : IF (cond) label1, label2, label3 translates to
1660 : :
1661 : : if (cond <= 0)
1662 : : {
1663 : : if (cond < 0)
1664 : : goto label1;
1665 : : else // cond == 0
1666 : : goto label2;
1667 : : }
1668 : : else // cond > 0
1669 : : goto label3;
1670 : :
1671 : : An optimized version can be generated in case of equal labels.
1672 : : E.g., if label1 is equal to label2, we can translate it to
1673 : :
1674 : : if (cond <= 0)
1675 : : goto label1;
1676 : : else
1677 : : goto label3;
1678 : : */
1679 : :
1680 : : tree
1681 : 64 : gfc_trans_arithmetic_if (gfc_code * code)
1682 : : {
1683 : 64 : gfc_se se;
1684 : 64 : tree tmp;
1685 : 64 : tree branch1;
1686 : 64 : tree branch2;
1687 : 64 : tree zero;
1688 : :
1689 : : /* Start a new block. */
1690 : 64 : gfc_init_se (&se, NULL);
1691 : 64 : gfc_start_block (&se.pre);
1692 : :
1693 : : /* Pre-evaluate COND. */
1694 : 64 : gfc_conv_expr_val (&se, code->expr1);
1695 : 64 : se.expr = gfc_evaluate_now (se.expr, &se.pre);
1696 : :
1697 : : /* Build something to compare with. */
1698 : 64 : zero = gfc_build_const (TREE_TYPE (se.expr), integer_zero_node);
1699 : :
1700 : 64 : if (code->label1->value != code->label2->value)
1701 : : {
1702 : : /* If (cond < 0) take branch1 else take branch2.
1703 : : First build jumps to the COND .LT. 0 and the COND .EQ. 0 cases. */
1704 : 49 : branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label1));
1705 : 49 : branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label2));
1706 : :
1707 : 49 : if (code->label1->value != code->label3->value)
1708 : 36 : tmp = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
1709 : : se.expr, zero);
1710 : : else
1711 : 13 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1712 : : se.expr, zero);
1713 : :
1714 : 49 : branch1 = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1715 : : tmp, branch1, branch2);
1716 : : }
1717 : : else
1718 : 15 : branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label1));
1719 : :
1720 : 64 : if (code->label1->value != code->label3->value
1721 : 45 : && code->label2->value != code->label3->value)
1722 : : {
1723 : : /* if (cond <= 0) take branch1 else take branch2. */
1724 : 37 : branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label3));
1725 : 37 : tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
1726 : : se.expr, zero);
1727 : 37 : branch1 = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1728 : : tmp, branch1, branch2);
1729 : : }
1730 : :
1731 : : /* Append the COND_EXPR to the evaluation of COND, and return. */
1732 : 64 : gfc_add_expr_to_block (&se.pre, branch1);
1733 : 64 : return gfc_finish_block (&se.pre);
1734 : : }
1735 : :
1736 : :
1737 : : /* Translate a CRITICAL block. */
1738 : :
1739 : : tree
1740 : 33 : gfc_trans_critical (gfc_code *code)
1741 : : {
1742 : 33 : stmtblock_t block;
1743 : 33 : tree tmp, token = NULL_TREE;
1744 : 33 : tree stat = NULL_TREE, errmsg, errmsg_len;
1745 : :
1746 : 33 : gfc_start_block (&block);
1747 : :
1748 : 33 : if (flag_coarray == GFC_FCOARRAY_LIB)
1749 : : {
1750 : 17 : gfc_se se;
1751 : :
1752 : 17 : gfc_init_se (&se, NULL);
1753 : 17 : gfc_trans_sync_stat (&code->ext.sync_stat, &se, &stat, &errmsg,
1754 : : &errmsg_len);
1755 : 17 : gfc_add_block_to_block (&block, &se.pre);
1756 : :
1757 : 17 : token = gfc_get_symbol_decl (code->resolved_sym);
1758 : 17 : token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (token));
1759 : 17 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_lock, 7,
1760 : : token, integer_zero_node, integer_one_node,
1761 : : null_pointer_node, stat, errmsg, errmsg_len);
1762 : 17 : gfc_add_expr_to_block (&block, tmp);
1763 : 17 : gfc_add_block_to_block (&block, &se.post);
1764 : :
1765 : : /* It guarantees memory consistency within the same segment. */
1766 : 17 : tmp = gfc_build_string_const (strlen ("memory") + 1, "memory"),
1767 : 17 : tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
1768 : : gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
1769 : : tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
1770 : 17 : ASM_VOLATILE_P (tmp) = 1;
1771 : :
1772 : 17 : gfc_add_expr_to_block (&block, tmp);
1773 : : }
1774 : :
1775 : 33 : tmp = gfc_trans_code (code->block->next);
1776 : 33 : gfc_add_expr_to_block (&block, tmp);
1777 : :
1778 : 33 : if (flag_coarray == GFC_FCOARRAY_LIB)
1779 : : {
1780 : : /* END CRITICAL does not accept STAT or ERRMSG arguments.
1781 : : * If STAT= is specified for CRITICAL, pass a stat argument to
1782 : : * _gfortran_caf_lock_unlock to prevent termination in the event of an
1783 : : * error, but ignore any value assigned to it.
1784 : : */
1785 : 17 : tmp = build_call_expr_loc (
1786 : : input_location, gfor_fndecl_caf_unlock, 6, token, integer_zero_node,
1787 : : integer_one_node,
1788 : 17 : stat != NULL_TREE
1789 : 17 : ? gfc_build_addr_expr (NULL,
1790 : : gfc_create_var (integer_type_node, "stat"))
1791 : : : null_pointer_node,
1792 : : null_pointer_node, integer_zero_node);
1793 : 17 : gfc_add_expr_to_block (&block, tmp);
1794 : :
1795 : : /* It guarantees memory consistency within the same segment */
1796 : 17 : tmp = gfc_build_string_const (strlen ("memory")+1, "memory"),
1797 : 17 : tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
1798 : : gfc_build_string_const (1, ""),
1799 : : NULL_TREE, NULL_TREE,
1800 : : tree_cons (NULL_TREE, tmp, NULL_TREE),
1801 : : NULL_TREE);
1802 : 17 : ASM_VOLATILE_P (tmp) = 1;
1803 : :
1804 : 17 : gfc_add_expr_to_block (&block, tmp);
1805 : : }
1806 : :
1807 : 33 : return gfc_finish_block (&block);
1808 : : }
1809 : :
1810 : :
1811 : : /* Return true, when the class has a _len component. */
1812 : :
1813 : : static bool
1814 : 746 : class_has_len_component (gfc_symbol *sym)
1815 : : {
1816 : 746 : gfc_component *comp = sym->ts.u.derived->components;
1817 : 2168 : while (comp)
1818 : : {
1819 : 1848 : if (strcmp (comp->name, "_len") == 0)
1820 : : return true;
1821 : 1422 : comp = comp->next;
1822 : : }
1823 : : return false;
1824 : : }
1825 : :
1826 : :
1827 : : static void
1828 : 1720 : copy_descriptor (stmtblock_t *block, tree dst, tree src, int rank)
1829 : : {
1830 : 1720 : int n;
1831 : 1720 : tree dim;
1832 : 1720 : tree tmp;
1833 : 1720 : tree tmp2;
1834 : 1720 : tree size;
1835 : 1720 : tree offset;
1836 : :
1837 : 1720 : offset = gfc_index_zero_node;
1838 : :
1839 : : /* Use memcpy to copy the descriptor. The size is the minimum of
1840 : : the sizes of 'src' and 'dst'. This avoids a non-trivial conversion. */
1841 : 1720 : tmp = TYPE_SIZE_UNIT (TREE_TYPE (src));
1842 : 1720 : tmp2 = TYPE_SIZE_UNIT (TREE_TYPE (dst));
1843 : 1720 : size = fold_build2_loc (input_location, MIN_EXPR,
1844 : 1720 : TREE_TYPE (tmp), tmp, tmp2);
1845 : 1720 : tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
1846 : 1720 : tmp = build_call_expr_loc (input_location, tmp, 3,
1847 : : gfc_build_addr_expr (NULL_TREE, dst),
1848 : : gfc_build_addr_expr (NULL_TREE, src),
1849 : : fold_convert (size_type_node, size));
1850 : 1720 : gfc_add_expr_to_block (block, tmp);
1851 : :
1852 : : /* Set the offset correctly. */
1853 : 8592 : for (n = 0; n < rank; n++)
1854 : : {
1855 : 5152 : dim = gfc_rank_cst[n];
1856 : 5152 : tmp = gfc_conv_descriptor_lbound_get (src, dim);
1857 : 5152 : tmp2 = gfc_conv_descriptor_stride_get (src, dim);
1858 : 5152 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
1859 : : tmp, tmp2);
1860 : 5152 : offset = fold_build2_loc (input_location, MINUS_EXPR,
1861 : 5152 : TREE_TYPE (offset), offset, tmp);
1862 : 5152 : offset = gfc_evaluate_now (offset, block);
1863 : : }
1864 : :
1865 : 1720 : gfc_conv_descriptor_offset_set (block, dst, offset);
1866 : 1720 : }
1867 : :
1868 : :
1869 : : /* Do proper initialization for ASSOCIATE names. */
1870 : :
1871 : : static void
1872 : 7042 : trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
1873 : : {
1874 : 7042 : gfc_expr *e;
1875 : 7042 : tree tmp;
1876 : 7042 : bool class_target;
1877 : 7042 : bool unlimited;
1878 : 7042 : tree desc;
1879 : 7042 : tree charlen;
1880 : 7042 : bool need_len_assign;
1881 : 7042 : bool whole_array = true;
1882 : 7042 : bool same_class;
1883 : 7042 : gfc_ref *ref;
1884 : 7042 : gfc_symbol *sym2;
1885 : :
1886 : 7042 : gcc_assert (sym->assoc);
1887 : 7042 : e = sym->assoc->target;
1888 : :
1889 : 16501 : class_target = (e->expr_type == EXPR_VARIABLE)
1890 : 6336 : && e->ts.type == BT_CLASS
1891 : 9539 : && (gfc_is_class_scalar_expr (e)
1892 : 1971 : || gfc_is_class_array_ref (e, NULL));
1893 : 2417 : same_class = class_target && sym->ts.type == BT_CLASS
1894 : 1089 : && strcmp (sym->ts.u.derived->name, e->ts.u.derived->name) == 0;
1895 : :
1896 : 7042 : unlimited = UNLIMITED_POLY (e);
1897 : :
1898 : 15405 : for (ref = e->ref; ref; ref = ref->next)
1899 : 8423 : if (ref->type == REF_ARRAY && ref->u.ar.type == AR_FULL
1900 : 3321 : && ref->u.ar.dimen != 0 && ref->next)
1901 : : {
1902 : : whole_array = false;
1903 : : break;
1904 : : }
1905 : :
1906 : : /* Assignments to the string length need to be generated, when
1907 : : ( sym is a char array or
1908 : : sym has a _len component)
1909 : : and the associated expression is unlimited polymorphic, which is
1910 : : not (yet) correctly in 'unlimited', because for an already associated
1911 : : BT_DERIVED the u-poly flag is not set, i.e.,
1912 : : __tmp_CHARACTER_0_1 => w => arg
1913 : : ^ generated temp ^ from code, the w does not have the u-poly
1914 : : flag set, where UNLIMITED_POLY(e) expects it. */
1915 : 5752 : need_len_assign = ((unlimited || (e->ts.type == BT_DERIVED
1916 : 2318 : && e->ts.u.derived->attr.unlimited_polymorphic))
1917 : 2153 : && (sym->ts.type == BT_CHARACTER
1918 : 1417 : || ((sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED)
1919 : 746 : && class_has_len_component (sym)))
1920 : 8204 : && !sym->attr.select_rank_temporary);
1921 : :
1922 : : /* Do a `pointer assignment' with updated descriptor (or assign descriptor
1923 : : to array temporary) for arrays with either unknown shape or if associating
1924 : : to a variable. Select rank temporaries need somewhat different treatment
1925 : : to other associate names and case temporaries. This because the selector
1926 : : is assumed rank and so the offset in particular has to be changed. Also,
1927 : : the case temporaries carry both allocatable and target attributes if
1928 : : present in the selector. This means that an allocatation or change of
1929 : : association can occur and so has to be dealt with. */
1930 : 7042 : if (sym->attr.select_rank_temporary)
1931 : : {
1932 : 1362 : gfc_se se;
1933 : 1362 : tree class_decl = NULL_TREE;
1934 : 1362 : int rank = 0;
1935 : 1362 : bool class_ptr;
1936 : :
1937 : 1362 : sym2 = e->symtree->n.sym;
1938 : 1362 : gfc_init_se (&se, NULL);
1939 : 1362 : if (e->ts.type == BT_CLASS)
1940 : : {
1941 : : /* Go straight to the class data. */
1942 : 145 : if (sym2->attr.dummy && !sym2->attr.optional)
1943 : : {
1944 : 121 : class_decl = sym2->backend_decl;
1945 : 121 : if (DECL_LANG_SPECIFIC (class_decl)
1946 : 121 : && GFC_DECL_SAVED_DESCRIPTOR (class_decl))
1947 : 0 : class_decl = GFC_DECL_SAVED_DESCRIPTOR (class_decl);
1948 : 121 : if (POINTER_TYPE_P (TREE_TYPE (class_decl)))
1949 : 121 : class_decl = build_fold_indirect_ref_loc (input_location,
1950 : : class_decl);
1951 : 121 : gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (class_decl)));
1952 : 121 : se.expr = gfc_class_data_get (class_decl);
1953 : : }
1954 : : else
1955 : : {
1956 : 24 : class_decl = sym2->backend_decl;
1957 : 24 : gfc_conv_expr_descriptor (&se, e);
1958 : 24 : if (POINTER_TYPE_P (TREE_TYPE (se.expr)))
1959 : 0 : se.expr = build_fold_indirect_ref_loc (input_location,
1960 : : se.expr);
1961 : : }
1962 : :
1963 : 145 : if (CLASS_DATA (sym)->as && CLASS_DATA (sym)->as->rank > 0)
1964 : 145 : rank = CLASS_DATA (sym)->as->rank;
1965 : : }
1966 : : else
1967 : : {
1968 : 1217 : gfc_conv_expr_descriptor (&se, e);
1969 : 1217 : if (sym->as && sym->as->rank > 0)
1970 : 1168 : rank = sym->as->rank;
1971 : : }
1972 : :
1973 : 1362 : desc = sym->backend_decl;
1974 : :
1975 : : /* The SELECT TYPE mechanisms turn class temporaries into pointers, which
1976 : : point to the selector. */
1977 : 1362 : class_ptr = class_decl != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (desc));
1978 : 145 : if (class_ptr)
1979 : : {
1980 : 145 : tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (desc)), "class");
1981 : 145 : tmp = gfc_build_addr_expr (NULL, tmp);
1982 : 145 : gfc_add_modify (&se.pre, desc, tmp);
1983 : :
1984 : 145 : tmp = gfc_class_vptr_get (class_decl);
1985 : 145 : gfc_add_modify (&se.pre, gfc_class_vptr_get (desc), tmp);
1986 : 145 : if (UNLIMITED_POLY (sym))
1987 : 101 : gfc_add_modify (&se.pre, gfc_class_len_get (desc),
1988 : : gfc_class_len_get (class_decl));
1989 : :
1990 : 145 : desc = gfc_class_data_get (desc);
1991 : : }
1992 : :
1993 : : /* SELECT RANK temporaries can carry the allocatable and pointer
1994 : : attributes so the selector descriptor must be copied in and
1995 : : copied out. */
1996 : 1362 : if (rank > 0)
1997 : 1282 : copy_descriptor (&se.pre, desc, se.expr, rank);
1998 : : else
1999 : : {
2000 : 80 : tmp = gfc_conv_descriptor_data_get (se.expr);
2001 : 80 : gfc_add_modify (&se.pre, desc,
2002 : 80 : fold_convert (TREE_TYPE (desc), tmp));
2003 : : }
2004 : :
2005 : : /* Deal with associate_name => selector. Class associate names are
2006 : : treated in the same way as in SELECT TYPE. */
2007 : 1362 : sym2 = sym->assoc->target->symtree->n.sym;
2008 : 1362 : if (sym2->assoc && sym->assoc->target && sym2->ts.type != BT_CLASS)
2009 : : {
2010 : 54 : sym2 = sym2->assoc->target->symtree->n.sym;
2011 : 54 : se.expr = sym2->backend_decl;
2012 : :
2013 : 54 : if (POINTER_TYPE_P (TREE_TYPE (se.expr)))
2014 : 54 : se.expr = build_fold_indirect_ref_loc (input_location,
2015 : : se.expr);
2016 : : }
2017 : :
2018 : : /* There could have been reallocation. Copy descriptor back to the
2019 : : selector and update the offset. */
2020 : 1362 : if (sym->attr.allocatable || sym->attr.pointer
2021 : 996 : || (sym->ts.type == BT_CLASS
2022 : 127 : && (CLASS_DATA (sym)->attr.allocatable
2023 : 79 : || CLASS_DATA (sym)->attr.pointer)))
2024 : : {
2025 : 493 : if (rank > 0)
2026 : 438 : copy_descriptor (&se.post, se.expr, desc, rank);
2027 : : else
2028 : 55 : gfc_conv_descriptor_data_set (&se.post, se.expr, desc);
2029 : :
2030 : : /* The dynamic type could have changed too. */
2031 : 493 : if (sym->ts.type == BT_CLASS)
2032 : : {
2033 : 145 : tmp = sym->backend_decl;
2034 : 145 : if (class_ptr)
2035 : 145 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
2036 : 145 : gfc_add_modify (&se.post, gfc_class_vptr_get (class_decl),
2037 : : gfc_class_vptr_get (tmp));
2038 : 145 : if (UNLIMITED_POLY (sym))
2039 : 101 : gfc_add_modify (&se.post, gfc_class_len_get (class_decl),
2040 : : gfc_class_len_get (tmp));
2041 : : }
2042 : : }
2043 : :
2044 : 1362 : tmp = gfc_finish_block (&se.post);
2045 : :
2046 : 1362 : gfc_add_init_cleanup (block, gfc_finish_block (&se.pre), tmp);
2047 : : }
2048 : :
2049 : : /* Now all the other kinds of associate variable. */
2050 : :
2051 : : /* First we do the F202y ASSOCIATE construct with an assumed rank selector.
2052 : : Since this requires rank remapping, the simplest implementation builds an
2053 : : array reference, using the array ref attached to the association_list,
2054 : : followed by gfc_trans_pointer_assignment. */
2055 : 5680 : else if (e->rank == -1 && sym->assoc->ar)
2056 : : {
2057 : 24 : gfc_array_ref *ar;
2058 : 24 : gfc_expr *expr1 = gfc_lval_expr_from_sym (sym);
2059 : 24 : stmtblock_t init;
2060 : 24 : gfc_init_block (&init);
2061 : :
2062 : : /* Build the array reference and add to expr1. */
2063 : 24 : gfc_free_ref_list (expr1->ref);
2064 : 24 : expr1->ref = gfc_get_ref();
2065 : 24 : expr1->ref->type = REF_ARRAY;
2066 : 24 : ar = gfc_copy_array_ref (sym->assoc->ar);
2067 : 24 : expr1->ref->u.ar = *ar;
2068 : 24 : expr1->ref->u.ar.type = AR_SECTION;
2069 : :
2070 : : /* For class objects, insert the _data component reference. Since the
2071 : : associate-name is a pointer, it needs a target, which is created using
2072 : : its typespec. If unlimited polymorphic, the _len field will be filled
2073 : : by the pointer assignment. */
2074 : 24 : if (expr1->ts.type == BT_CLASS)
2075 : : {
2076 : 12 : need_len_assign = false;
2077 : 12 : gfc_ref *ref;
2078 : 12 : gfc_find_component (expr1->ts.u.derived, "_data", true, true, &ref);
2079 : 12 : ref->next = expr1->ref;
2080 : 12 : expr1->ref = ref;
2081 : 12 : expr1->rank = CLASS_DATA (sym)->as->rank;
2082 : 12 : tmp = gfc_create_var (gfc_typenode_for_spec (&sym->ts), "class");
2083 : 12 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
2084 : 12 : gfc_add_modify (&init, sym->backend_decl, tmp);
2085 : : }
2086 : :
2087 : : /* Do the pointer assignment and clean up. */
2088 : 24 : gfc_expr *expr2 = gfc_copy_expr (e);
2089 : 24 : gfc_add_expr_to_block (&init,
2090 : : gfc_trans_pointer_assignment (expr1, expr2));
2091 : 24 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL);
2092 : 24 : gfc_free_expr (expr1);
2093 : 24 : gfc_free_expr (expr2);
2094 : 24 : }
2095 : : /* PDT array and string components are separately allocated for each element
2096 : : of a PDT array. Therefore, there is no choice but to copy in and copy out
2097 : : the target expression. */
2098 : 5656 : else if (e && is_subref_array (e)
2099 : 446 : && (gfc_expr_attr (e).pdt_array || gfc_expr_attr (e).pdt_string))
2100 : : {
2101 : 18 : gfc_se init;
2102 : 18 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym->backend_decl)));
2103 : 18 : gfc_init_se (&init, NULL);
2104 : 18 : gfc_conv_subref_array_arg (&init, e, false, INTENT_INOUT,
2105 : 18 : sym && sym->attr.pointer);
2106 : 18 : init.expr = build_fold_indirect_ref_loc (input_location, init.expr);
2107 : 18 : gfc_add_modify (&init.pre, sym->backend_decl, init.expr);
2108 : 18 : gfc_add_init_cleanup (block, gfc_finish_block (&init.pre),
2109 : : gfc_finish_block (&init.post));
2110 : : }
2111 : 5638 : else if ((sym->attr.dimension || sym->attr.codimension) && !class_target
2112 : 617 : && (sym->as->type == AS_DEFERRED || sym->assoc->variable))
2113 : : {
2114 : 617 : gfc_se se;
2115 : 617 : tree desc;
2116 : 617 : bool cst_array_ctor;
2117 : 617 : stmtblock_t init;
2118 : 617 : gfc_init_block (&init);
2119 : :
2120 : 617 : desc = sym->backend_decl;
2121 : 1234 : cst_array_ctor = e->expr_type == EXPR_ARRAY
2122 : 97 : && gfc_constant_array_constructor_p (e->value.constructor)
2123 : 635 : && e->ts.type != BT_CHARACTER;
2124 : :
2125 : : /* If association is to an expression, evaluate it and create temporary.
2126 : : Otherwise, get descriptor of target for pointer assignment. */
2127 : 617 : gfc_init_se (&se, NULL);
2128 : :
2129 : 617 : if (sym->assoc->variable || cst_array_ctor)
2130 : : {
2131 : 388 : se.direct_byref = 1;
2132 : 388 : se.expr = desc;
2133 : 388 : GFC_DECL_PTR_ARRAY_P (sym->backend_decl) = 1;
2134 : : }
2135 : :
2136 : 617 : if (sym->attr.codimension)
2137 : 11 : se.want_coarray = 1;
2138 : :
2139 : 617 : gfc_conv_expr_descriptor (&se, e);
2140 : :
2141 : 617 : if (flag_coarray == GFC_FCOARRAY_LIB && sym->attr.codimension)
2142 : : {
2143 : 3 : tree token = gfc_conv_descriptor_token (se.expr),
2144 : : size
2145 : 3 : = sym->attr.dimension
2146 : 3 : ? fold_build2 (MULT_EXPR, gfc_array_index_type,
2147 : : gfc_conv_descriptor_size (se.expr, e->rank),
2148 : : gfc_conv_descriptor_span_get (se.expr))
2149 : 2 : : gfc_conv_descriptor_span_get (se.expr);
2150 : : /* Create a new token, because in the token the modified descriptor
2151 : : is stored. The modified descriptor is needed for accesses on the
2152 : : remote image. In the scalar case, the base address needs to be
2153 : : associated correctly, which also needs a new token.
2154 : : The token is freed automatically be the end team statement. */
2155 : 3 : gfc_add_expr_to_block (
2156 : : &se.pre,
2157 : : build_call_expr_loc (
2158 : : input_location, gfor_fndecl_caf_register, 7, size,
2159 : : build_int_cst (integer_type_node, GFC_CAF_COARRAY_MAP_EXISTING),
2160 : : gfc_build_addr_expr (pvoid_type_node, token),
2161 : : gfc_build_addr_expr (NULL_TREE, se.expr), null_pointer_node,
2162 : : null_pointer_node, integer_zero_node));
2163 : : }
2164 : :
2165 : 617 : if (sym->ts.type == BT_CHARACTER
2166 : 266 : && !sym->attr.select_type_temporary
2167 : 266 : && sym->ts.u.cl->backend_decl
2168 : 266 : && VAR_P (sym->ts.u.cl->backend_decl)
2169 : 222 : && se.string_length
2170 : 222 : && se.string_length != sym->ts.u.cl->backend_decl)
2171 : : {
2172 : : /* When the target is a variable, its length is already known. */
2173 : 222 : tree len = fold_convert (TREE_TYPE (sym->ts.u.cl->backend_decl),
2174 : : se.string_length);
2175 : 222 : if (e->expr_type == EXPR_VARIABLE)
2176 : 130 : gfc_add_modify (&init, sym->ts.u.cl->backend_decl, len);
2177 : : else
2178 : 92 : gfc_add_modify (&se.pre, sym->ts.u.cl->backend_decl, len);
2179 : : }
2180 : :
2181 : : /* If we didn't already do the pointer assignment, set associate-name
2182 : : descriptor to the one generated for the temporary. */
2183 : 617 : if ((!sym->assoc->variable && !cst_array_ctor)
2184 : 388 : || !whole_array)
2185 : : {
2186 : 229 : int dim;
2187 : :
2188 : 229 : if (whole_array)
2189 : 229 : gfc_add_modify (&se.pre, desc, se.expr);
2190 : :
2191 : : /* The generated descriptor has lower bound zero (as array
2192 : : temporary), shift bounds so we get lower bounds of 1. */
2193 : 577 : for (dim = 0; dim < e->rank; ++dim)
2194 : 300 : gfc_conv_shift_descriptor_lbound (&se.pre, desc,
2195 : : dim, gfc_index_one_node);
2196 : : }
2197 : :
2198 : 617 : if (e->expr_type == EXPR_FUNCTION
2199 : 93 : && sym->ts.type == BT_DERIVED
2200 : 43 : && sym->ts.u.derived
2201 : 43 : && sym->ts.u.derived->attr.pdt_type)
2202 : : {
2203 : 0 : tmp = gfc_deallocate_pdt_comp (sym->ts.u.derived, se.expr,
2204 : 0 : sym->as->rank);
2205 : 0 : gfc_add_expr_to_block (&se.post, tmp);
2206 : : }
2207 : :
2208 : : /* Done, register stuff as init / cleanup code. */
2209 : 617 : gfc_add_block_to_block (&init, &se.pre);
2210 : 617 : gfc_add_init_cleanup (block, gfc_finish_block (&init),
2211 : : gfc_finish_block (&se.post));
2212 : 617 : }
2213 : :
2214 : : /* Temporaries, arising from TYPE IS, just need the descriptor of class
2215 : : arrays to be assigned directly. */
2216 : 5021 : else if (class_target && (sym->attr.dimension || sym->attr.codimension)
2217 : 1328 : && (sym->ts.type == BT_DERIVED || unlimited))
2218 : : {
2219 : 1328 : gfc_se se;
2220 : :
2221 : 1328 : gfc_init_se (&se, NULL);
2222 : 1328 : se.descriptor_only = 1;
2223 : : /* In a select type the (temporary) associate variable shall point to
2224 : : a standard fortran array (lower bound == 1), but conv_expr ()
2225 : : just maps to the input array in the class object, whose lbound may
2226 : : be arbitrary. conv_expr_descriptor solves this by inserting a
2227 : : temporary array descriptor. */
2228 : 1328 : gfc_conv_expr_descriptor (&se, e);
2229 : :
2230 : 1328 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))
2231 : : || GFC_ARRAY_TYPE_P (TREE_TYPE (se.expr)));
2232 : 1328 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym->backend_decl)));
2233 : :
2234 : 1328 : if (sym->ts.type == BT_CHARACTER)
2235 : : {
2236 : : /* Emit a DECL_EXPR for the variable sized array type in so the
2237 : : gimplification of its type sizes works correctly. */
2238 : 302 : tree arraytype;
2239 : 302 : tmp = TREE_TYPE (sym->backend_decl);
2240 : 302 : arraytype = TREE_TYPE (GFC_TYPE_ARRAY_DATAPTR_TYPE (tmp));
2241 : 302 : if (! TYPE_NAME (arraytype))
2242 : 51 : TYPE_NAME (arraytype) = build_decl (UNKNOWN_LOCATION, TYPE_DECL,
2243 : : NULL_TREE, arraytype);
2244 : 302 : gfc_add_expr_to_block (&se.pre, build1 (DECL_EXPR,
2245 : 302 : arraytype, TYPE_NAME (arraytype)));
2246 : : }
2247 : :
2248 : 1328 : if (GFC_ARRAY_TYPE_P (TREE_TYPE (se.expr)))
2249 : : {
2250 : 0 : if (INDIRECT_REF_P (se.expr))
2251 : 0 : tmp = TREE_OPERAND (se.expr, 0);
2252 : : else
2253 : : tmp = se.expr;
2254 : :
2255 : 0 : gfc_add_modify (&se.pre, sym->backend_decl,
2256 : 0 : gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (tmp)));
2257 : : }
2258 : : else
2259 : 1328 : gfc_add_modify (&se.pre, sym->backend_decl, se.expr);
2260 : :
2261 : 1328 : if (unlimited)
2262 : : {
2263 : : /* Recover the dtype, which has been overwritten by the
2264 : : assignment from an unlimited polymorphic object. */
2265 : 803 : tmp = gfc_conv_descriptor_dtype (sym->backend_decl);
2266 : 803 : gfc_add_modify (&se.pre, tmp,
2267 : 803 : gfc_get_dtype (TREE_TYPE (sym->backend_decl)));
2268 : : }
2269 : :
2270 : 1328 : gfc_add_init_cleanup (block, gfc_finish_block (&se.pre),
2271 : : gfc_finish_block (&se.post));
2272 : 1328 : }
2273 : :
2274 : : /* Do a scalar pointer assignment; this is for scalar variable targets. */
2275 : 3693 : else if (gfc_is_associate_pointer (sym))
2276 : : {
2277 : 3303 : gfc_se se;
2278 : :
2279 : 3303 : gcc_assert (!sym->attr.dimension && !sym->attr.codimension);
2280 : :
2281 : 3303 : gfc_init_se (&se, NULL);
2282 : :
2283 : : /* Class associate-names come this way because they are
2284 : : unconditionally associate pointers and the symbol is scalar. */
2285 : 3303 : if (sym->ts.type == BT_CLASS && e->expr_type == EXPR_FUNCTION)
2286 : : {
2287 : 99 : gfc_conv_expr (&se, e);
2288 : 99 : se.expr = gfc_evaluate_now (se.expr, &se.pre);
2289 : : /* Finalize the expression and free if it is allocatable. */
2290 : 99 : gfc_finalize_tree_expr (&se, NULL, gfc_expr_attr (e), e->rank);
2291 : 99 : gfc_add_block_to_block (&se.post, &se.finalblock);
2292 : 99 : need_len_assign = false;
2293 : : }
2294 : 3204 : else if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.dimension)
2295 : : {
2296 : 432 : tree target_expr;
2297 : : /* For a class array we need a descriptor for the selector. */
2298 : 432 : gfc_conv_expr_descriptor (&se, e);
2299 : : /* Needed to get/set the _len component below. */
2300 : 432 : target_expr = se.expr;
2301 : :
2302 : : /* Obtain a temporary class container for the result. */
2303 : 432 : gfc_conv_class_to_class (&se, e, sym->ts, false, true, false, false);
2304 : 432 : se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
2305 : :
2306 : 432 : desc = gfc_class_data_get (se.expr);
2307 : :
2308 : 432 : if (need_len_assign)
2309 : : {
2310 : 175 : if (e->symtree
2311 : 175 : && DECL_LANG_SPECIFIC (e->symtree->n.sym->backend_decl)
2312 : 84 : && GFC_DECL_SAVED_DESCRIPTOR (e->symtree->n.sym->backend_decl)
2313 : 205 : && TREE_CODE (target_expr) != COMPONENT_REF)
2314 : : /* Use the original class descriptor stored in the saved
2315 : : descriptor to get the target_expr. */
2316 : 36 : target_expr =
2317 : 18 : GFC_DECL_SAVED_DESCRIPTOR (e->symtree->n.sym->backend_decl);
2318 : : else
2319 : : /* Strip the _data component from the target_expr. */
2320 : 157 : target_expr = TREE_OPERAND (target_expr, 0);
2321 : : /* Add a reference to the _len comp to the target expr. */
2322 : 175 : tmp = gfc_class_len_get (target_expr);
2323 : : /* Get the component-ref for the temp structure's _len comp. */
2324 : 175 : charlen = gfc_class_len_get (se.expr);
2325 : : /* Add the assign to the beginning of the block... */
2326 : 175 : gfc_add_modify (&se.pre, charlen,
2327 : 175 : fold_convert (TREE_TYPE (charlen), tmp));
2328 : : /* and the oposite way at the end of the block, to hand changes
2329 : : on the string length back. */
2330 : 175 : gfc_add_modify (&se.post, tmp,
2331 : 175 : fold_convert (TREE_TYPE (tmp), charlen));
2332 : : /* Length assignment done, prevent adding it again below. */
2333 : 175 : need_len_assign = false;
2334 : : }
2335 : : }
2336 : 2772 : else if (sym->ts.type == BT_CLASS && e->ts.type == BT_CLASS
2337 : 592 : && CLASS_DATA (e)->attr.dimension)
2338 : : {
2339 : : /* This is bound to be a class array element. */
2340 : 80 : gfc_conv_expr_reference (&se, e);
2341 : : /* Obtain a temporary class container for the result. */
2342 : 80 : gfc_conv_derived_to_class (&se, e, sym, se.expr, false, false,
2343 : 80 : e->symtree->name);
2344 : 80 : need_len_assign = false;
2345 : : }
2346 : 2692 : else if (whole_array && (same_class || unlimited)
2347 : 271 : && e->ts.type == BT_CLASS && CLASS_DATA (e)->attr.codimension)
2348 : : {
2349 : 9 : gfc_expr *class_e = gfc_find_and_cut_at_last_class_ref (e);
2350 : 9 : gfc_conv_expr (&se, class_e);
2351 : 9 : gfc_free_expr (class_e);
2352 : 9 : need_len_assign = false;
2353 : 9 : }
2354 : : else
2355 : : {
2356 : : /* For BT_CLASS and BT_DERIVED, this boils down to a pointer assign,
2357 : : which has the string length included. For CHARACTERS it is still
2358 : : needed and will be done at the end of this routine. */
2359 : 2683 : gfc_conv_expr (&se, e);
2360 : 2683 : need_len_assign = need_len_assign && sym->ts.type == BT_CHARACTER;
2361 : : }
2362 : :
2363 : 3303 : if (sym->ts.type == BT_CHARACTER
2364 : 525 : && !sym->attr.select_type_temporary
2365 : 91 : && VAR_P (sym->ts.u.cl->backend_decl)
2366 : 55 : && se.string_length != sym->ts.u.cl->backend_decl)
2367 : : {
2368 : 55 : gfc_add_modify (&se.pre, sym->ts.u.cl->backend_decl,
2369 : 55 : fold_convert (TREE_TYPE (sym->ts.u.cl->backend_decl),
2370 : : se.string_length));
2371 : 55 : if (e->expr_type == EXPR_FUNCTION)
2372 : : {
2373 : 6 : tmp = gfc_call_free (sym->backend_decl);
2374 : 6 : gfc_add_expr_to_block (&se.post, tmp);
2375 : : }
2376 : : }
2377 : :
2378 : 525 : if (sym->ts.type == BT_CHARACTER && e->ts.type == BT_CHARACTER
2379 : 3394 : && POINTER_TYPE_P (TREE_TYPE (se.expr)))
2380 : : {
2381 : : /* These are pointer types already. */
2382 : 73 : tmp = fold_convert (TREE_TYPE (sym->backend_decl), se.expr);
2383 : : }
2384 : : else
2385 : : {
2386 : 3230 : tree ctree = gfc_get_class_from_expr (se.expr);
2387 : 3230 : tmp = TREE_TYPE (sym->backend_decl);
2388 : :
2389 : 3230 : if (sym->ts.type == BT_CLASS && e->ts.type == BT_CLASS)
2390 : : {
2391 : : /* F2018:19.5.1.6 "If a selector has the POINTER attribute,
2392 : : it shall be associated; the associate name is associated
2393 : : with the target of the pointer and does not have the
2394 : : POINTER attribute." */
2395 : 637 : if (e->rank == 0 && ctree
2396 : 1748 : && (!GFC_CLASS_TYPE_P (TREE_TYPE (se.expr))
2397 : 555 : || CLASS_DATA (e)->attr.class_pointer))
2398 : : {
2399 : 285 : tree stmp;
2400 : 285 : tree dtmp;
2401 : 285 : tree ctmp;
2402 : :
2403 : 285 : ctmp = ctree;
2404 : 285 : dtmp = TREE_TYPE (TREE_TYPE (sym->backend_decl));
2405 : 285 : ctree = gfc_create_var (dtmp, "class");
2406 : :
2407 : 285 : if (IS_INFERRED_TYPE (e)
2408 : 6 : && !GFC_CLASS_TYPE_P (TREE_TYPE (se.expr)))
2409 : : stmp = se.expr;
2410 : : else
2411 : 285 : stmp = gfc_class_data_get (ctmp);
2412 : :
2413 : 285 : if (!CLASS_DATA (sym)->attr.codimension
2414 : 285 : && !POINTER_TYPE_P (TREE_TYPE (stmp)))
2415 : 0 : stmp = gfc_build_addr_expr (NULL, stmp);
2416 : :
2417 : 285 : dtmp = gfc_class_data_get (ctree);
2418 : 285 : stmp = build1 (VIEW_CONVERT_EXPR, TREE_TYPE (dtmp), stmp);
2419 : 285 : gfc_add_modify (&se.pre, dtmp, stmp);
2420 : 285 : stmp = gfc_class_vptr_get (ctmp);
2421 : 285 : dtmp = gfc_class_vptr_get (ctree);
2422 : 285 : stmp = fold_convert (TREE_TYPE (dtmp), stmp);
2423 : 285 : gfc_add_modify (&se.pre, dtmp, stmp);
2424 : 285 : if (UNLIMITED_POLY (sym))
2425 : : {
2426 : 66 : stmp = gfc_class_len_get (ctmp);
2427 : 66 : dtmp = gfc_class_len_get (ctree);
2428 : 66 : stmp = fold_convert (TREE_TYPE (dtmp), stmp);
2429 : 66 : gfc_add_modify (&se.pre, dtmp, stmp);
2430 : 66 : need_len_assign = false;
2431 : : }
2432 : 285 : se.expr = ctree;
2433 : : }
2434 : 826 : else if (CLASS_DATA (sym)->attr.codimension)
2435 : : {
2436 : 27 : gfc_conv_class_to_class (&se, e, sym->ts, false, false, false,
2437 : : false);
2438 : 27 : tmp = se.expr;
2439 : : }
2440 : : }
2441 : : /* For non-pointer types in se.expr, the first condition holds.
2442 : : For pointer or reference types in se.expr, a double TREE_TYPE ()
2443 : : is possible and an associate variable always is a pointer. */
2444 : 6432 : if (!POINTER_TYPE_P (TREE_TYPE (se.expr))
2445 : 3230 : || TREE_TYPE (TREE_TYPE (se.expr))
2446 : 28 : != TREE_TYPE (TREE_TYPE (sym->backend_decl)))
2447 : 3203 : tmp = gfc_build_addr_expr (tmp, se.expr);
2448 : : }
2449 : :
2450 : 3303 : gfc_add_modify (&se.pre, sym->backend_decl, tmp);
2451 : :
2452 : 3303 : gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
2453 : : gfc_finish_block (&se.post));
2454 : : }
2455 : :
2456 : : /* Do a simple assignment. This is for scalar expressions, where we
2457 : : can simply use expression assignment. */
2458 : : else
2459 : : {
2460 : 390 : gfc_expr *lhs;
2461 : 390 : tree res;
2462 : 390 : gfc_se se;
2463 : 390 : stmtblock_t final_block;
2464 : :
2465 : 390 : gfc_init_se (&se, NULL);
2466 : :
2467 : : /* resolve.cc converts some associate names to allocatable so that
2468 : : allocation can take place automatically in gfc_trans_assignment.
2469 : : The frontend prevents them from being either allocated,
2470 : : deallocated or reallocated. */
2471 : 390 : if (sym->ts.type == BT_DERIVED
2472 : 79 : && sym->ts.u.derived->attr.alloc_comp)
2473 : : {
2474 : 12 : tmp = sym->backend_decl;
2475 : 12 : tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, tmp,
2476 : 12 : sym->attr.dimension ? sym->as->rank : 0);
2477 : 12 : gfc_add_expr_to_block (&se.pre, tmp);
2478 : : }
2479 : :
2480 : 390 : if (sym->attr.allocatable)
2481 : : {
2482 : 12 : tmp = sym->backend_decl;
2483 : 12 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
2484 : 0 : gfc_conv_descriptor_data_set (&se.pre, tmp, null_pointer_node);
2485 : : else
2486 : 12 : gfc_add_modify (&se.pre, tmp,
2487 : 12 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
2488 : : }
2489 : :
2490 : 390 : lhs = gfc_lval_expr_from_sym (sym);
2491 : 390 : lhs->must_finalize = 0;
2492 : 390 : res = gfc_trans_assignment (lhs, e, false, true);
2493 : 390 : gfc_add_expr_to_block (&se.pre, res);
2494 : :
2495 : 390 : gfc_init_block (&final_block);
2496 : :
2497 : 390 : if (sym->attr.associate_var
2498 : 390 : && sym->ts.type == BT_DERIVED
2499 : 79 : && sym->ts.u.derived->attr.defined_assign_comp
2500 : 0 : && gfc_may_be_finalized (sym->ts)
2501 : 390 : && e->expr_type == EXPR_FUNCTION)
2502 : : {
2503 : 0 : gfc_expr *ef;
2504 : 0 : ef = gfc_lval_expr_from_sym (sym);
2505 : 0 : gfc_add_finalizer_call (&final_block, ef);
2506 : 0 : gfc_free_expr (ef);
2507 : : }
2508 : :
2509 : 390 : if (sym->ts.type == BT_DERIVED
2510 : 79 : && sym->ts.u.derived->attr.alloc_comp)
2511 : : {
2512 : 12 : tmp = sym->backend_decl;
2513 : 12 : tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived,
2514 : : tmp, 0);
2515 : 12 : gfc_add_expr_to_block (&final_block, tmp);
2516 : : }
2517 : :
2518 : 390 : tmp = sym->backend_decl;
2519 : 390 : if (e->expr_type == EXPR_FUNCTION
2520 : 82 : && sym->ts.type == BT_DERIVED
2521 : 45 : && sym->ts.u.derived
2522 : 45 : && sym->ts.u.derived->attr.pdt_type)
2523 : : {
2524 : 6 : tmp = gfc_deallocate_pdt_comp (sym->ts.u.derived, tmp,
2525 : : 0);
2526 : : }
2527 : 384 : else if (e->expr_type == EXPR_FUNCTION
2528 : 76 : && sym->ts.type == BT_CLASS
2529 : 0 : && CLASS_DATA (sym)->ts.u.derived
2530 : 0 : && CLASS_DATA (sym)->ts.u.derived->attr.pdt_type)
2531 : : {
2532 : 0 : tmp = gfc_class_data_get (tmp);
2533 : 0 : tmp = gfc_deallocate_pdt_comp (CLASS_DATA (sym)->ts.u.derived,
2534 : : tmp, 0);
2535 : : }
2536 : 384 : else if (sym->attr.allocatable)
2537 : : {
2538 : 12 : tmp = sym->backend_decl;
2539 : :
2540 : 12 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
2541 : 0 : tmp = gfc_conv_descriptor_data_get (tmp);
2542 : :
2543 : : /* A simple call to free suffices here. */
2544 : 12 : tmp = gfc_call_free (tmp);
2545 : :
2546 : : /* Make sure that reallocation on assignment cannot occur. */
2547 : 12 : sym->attr.allocatable = 0;
2548 : : }
2549 : : else
2550 : : tmp = NULL_TREE;
2551 : :
2552 : 390 : gfc_add_expr_to_block (&final_block, tmp);
2553 : 390 : tmp = gfc_finish_block (&final_block);
2554 : 390 : res = gfc_finish_block (&se.pre);
2555 : 390 : gfc_add_init_cleanup (block, res, tmp);
2556 : 390 : gfc_free_expr (lhs);
2557 : : }
2558 : :
2559 : : /* Set the stringlength, when needed. */
2560 : 7042 : if (need_len_assign)
2561 : : {
2562 : 736 : gfc_se se;
2563 : 736 : gfc_init_se (&se, NULL);
2564 : 736 : if (e->symtree->n.sym->ts.type == BT_CHARACTER)
2565 : : {
2566 : : /* Deferred strings are dealt with in the preceding. */
2567 : 0 : gcc_assert (!e->symtree->n.sym->ts.deferred);
2568 : 0 : tmp = e->symtree->n.sym->ts.u.cl->backend_decl;
2569 : : }
2570 : 736 : else if (e->symtree->n.sym->attr.function
2571 : 12 : && e->symtree->n.sym == e->symtree->n.sym->result)
2572 : : {
2573 : 12 : tmp = gfc_get_fake_result_decl (e->symtree->n.sym, 0);
2574 : 12 : tmp = gfc_class_len_get (tmp);
2575 : : }
2576 : : else
2577 : 724 : tmp = gfc_class_len_get (gfc_get_symbol_decl (e->symtree->n.sym));
2578 : 736 : gfc_get_symbol_decl (sym);
2579 : 736 : charlen = sym->ts.type == BT_CHARACTER ? sym->ts.u.cl->backend_decl
2580 : 0 : : gfc_class_len_get (sym->backend_decl);
2581 : : /* Prevent adding a noop len= len. */
2582 : 736 : if (tmp != charlen)
2583 : : {
2584 : 736 : gfc_add_modify (&se.pre, charlen,
2585 : 736 : fold_convert (TREE_TYPE (charlen), tmp));
2586 : 736 : gfc_add_init_cleanup (block, gfc_finish_block (&se.pre),
2587 : : gfc_finish_block (&se.post));
2588 : : }
2589 : : }
2590 : 7042 : }
2591 : :
2592 : :
2593 : : /* Translate a BLOCK construct. This is basically what we would do for a
2594 : : procedure body. */
2595 : :
2596 : : tree
2597 : 13607 : gfc_trans_block_construct (gfc_code* code)
2598 : : {
2599 : 13607 : gfc_namespace* ns;
2600 : 13607 : gfc_symbol* sym;
2601 : 13607 : gfc_wrapped_block block;
2602 : 13607 : tree exit_label;
2603 : 13607 : stmtblock_t body;
2604 : 13607 : gfc_association_list *ass;
2605 : 13607 : tree translated_body;
2606 : :
2607 : 13607 : ns = code->ext.block.ns;
2608 : 13607 : gcc_assert (ns);
2609 : 13607 : sym = ns->proc_name;
2610 : 13607 : gcc_assert (sym);
2611 : :
2612 : : /* Process local variables. */
2613 : 13607 : gcc_assert (!sym->tlink);
2614 : 13607 : sym->tlink = sym;
2615 : 13607 : gfc_process_block_locals (ns);
2616 : :
2617 : : /* Generate code including exit-label. */
2618 : 13607 : gfc_init_block (&body);
2619 : 13607 : exit_label = gfc_build_label_decl (NULL_TREE);
2620 : 13607 : code->exit_label = exit_label;
2621 : :
2622 : 13607 : finish_oacc_declare (ns, sym, true);
2623 : :
2624 : 13607 : translated_body = gfc_trans_code (ns->code);
2625 : 13607 : if (ns->omp_structured_block)
2626 : 457 : translated_body = build1 (OMP_STRUCTURED_BLOCK, void_type_node,
2627 : : translated_body);
2628 : 13607 : gfc_add_expr_to_block (&body, translated_body);
2629 : 13607 : gfc_add_expr_to_block (&body, build1_v (LABEL_EXPR, exit_label));
2630 : :
2631 : : /* Finish everything. */
2632 : 13607 : gfc_start_wrapped_block (&block, gfc_finish_block (&body));
2633 : 13607 : gfc_trans_deferred_vars (sym, &block);
2634 : 20649 : for (ass = code->ext.block.assoc; ass; ass = ass->next)
2635 : 7042 : trans_associate_var (ass->st->n.sym, &block);
2636 : :
2637 : 13607 : return gfc_finish_wrapped_block (&block);
2638 : : }
2639 : :
2640 : : /* Translate the simple DO construct in a C-style manner.
2641 : : This is where the loop variable has integer type and step +-1.
2642 : : Following code will generate infinite loop in case where TO is INT_MAX
2643 : : (for +1 step) or INT_MIN (for -1 step)
2644 : :
2645 : : We translate a do loop from:
2646 : :
2647 : : DO dovar = from, to, step
2648 : : body
2649 : : END DO
2650 : :
2651 : : to:
2652 : :
2653 : : [Evaluate loop bounds and step]
2654 : : dovar = from;
2655 : : for (;;)
2656 : : {
2657 : : if (dovar > to)
2658 : : goto end_label;
2659 : : body;
2660 : : cycle_label:
2661 : : dovar += step;
2662 : : }
2663 : : end_label:
2664 : :
2665 : : This helps the optimizers by avoiding the extra pre-header condition and
2666 : : we save a register as we just compare the updated IV (not a value in
2667 : : previous step). */
2668 : :
2669 : : static tree
2670 : 25326 : gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar,
2671 : : tree from, tree to, tree step, tree exit_cond)
2672 : : {
2673 : 25326 : stmtblock_t body;
2674 : 25326 : tree type;
2675 : 25326 : tree cond;
2676 : 25326 : tree tmp;
2677 : 25326 : tree saved_dovar = NULL;
2678 : 25326 : tree cycle_label;
2679 : 25326 : tree exit_label;
2680 : 25326 : location_t loc;
2681 : 25326 : type = TREE_TYPE (dovar);
2682 : 25326 : bool is_step_positive = tree_int_cst_sgn (step) > 0;
2683 : :
2684 : 25326 : loc = gfc_get_location (&code->ext.iterator->start->where);
2685 : :
2686 : : /* Initialize the DO variable: dovar = from. */
2687 : 25326 : gfc_add_modify_loc (loc, pblock, dovar,
2688 : 25326 : fold_convert (TREE_TYPE (dovar), from));
2689 : :
2690 : : /* Save value for do-tinkering checking. */
2691 : 25326 : if (gfc_option.rtcheck & GFC_RTCHECK_DO)
2692 : : {
2693 : 191 : saved_dovar = gfc_create_var (type, ".saved_dovar");
2694 : 191 : gfc_add_modify_loc (loc, pblock, saved_dovar, dovar);
2695 : : }
2696 : :
2697 : : /* Cycle and exit statements are implemented with gotos. */
2698 : 25326 : cycle_label = gfc_build_label_decl (NULL_TREE);
2699 : 25326 : exit_label = gfc_build_label_decl (NULL_TREE);
2700 : :
2701 : : /* Put the labels where they can be found later. See gfc_trans_do(). */
2702 : 25326 : code->cycle_label = cycle_label;
2703 : 25326 : code->exit_label = exit_label;
2704 : :
2705 : : /* Loop body. */
2706 : 25326 : gfc_start_block (&body);
2707 : :
2708 : : /* Exit the loop if there is an I/O result condition or error. */
2709 : 25326 : if (exit_cond)
2710 : : {
2711 : 322 : tmp = build1_v (GOTO_EXPR, exit_label);
2712 : 322 : tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
2713 : : exit_cond, tmp,
2714 : : build_empty_stmt (loc));
2715 : 322 : gfc_add_expr_to_block (&body, tmp);
2716 : : }
2717 : :
2718 : : /* Evaluate the loop condition. */
2719 : 25326 : if (is_step_positive)
2720 : 25211 : cond = fold_build2_loc (loc, GT_EXPR, logical_type_node, dovar,
2721 : : fold_convert (type, to));
2722 : : else
2723 : 115 : cond = fold_build2_loc (loc, LT_EXPR, logical_type_node, dovar,
2724 : : fold_convert (type, to));
2725 : :
2726 : 25326 : cond = gfc_evaluate_now_loc (loc, cond, &body);
2727 : 25326 : if (code->ext.iterator->annot.unroll && cond != error_mark_node)
2728 : 12 : cond
2729 : 12 : = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond,
2730 : : build_int_cst (integer_type_node, annot_expr_unroll_kind),
2731 : : build_int_cst (integer_type_node,
2732 : 12 : code->ext.iterator->annot.unroll));
2733 : :
2734 : 25326 : if (code->ext.iterator->annot.ivdep && cond != error_mark_node)
2735 : 2 : cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond,
2736 : : build_int_cst (integer_type_node, annot_expr_ivdep_kind),
2737 : : integer_zero_node);
2738 : 25326 : if (code->ext.iterator->annot.vector && cond != error_mark_node)
2739 : 2 : cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond,
2740 : : build_int_cst (integer_type_node, annot_expr_vector_kind),
2741 : : integer_zero_node);
2742 : 25326 : if (code->ext.iterator->annot.novector && cond != error_mark_node)
2743 : 2 : cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond,
2744 : : build_int_cst (integer_type_node, annot_expr_no_vector_kind),
2745 : : integer_zero_node);
2746 : :
2747 : : /* The loop exit. */
2748 : 25326 : tmp = fold_build1_loc (loc, GOTO_EXPR, void_type_node, exit_label);
2749 : 25326 : TREE_USED (exit_label) = 1;
2750 : 25326 : tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
2751 : : cond, tmp, build_empty_stmt (loc));
2752 : 25326 : gfc_add_expr_to_block (&body, tmp);
2753 : :
2754 : : /* Check whether the induction variable is equal to INT_MAX
2755 : : (respectively to INT_MIN). */
2756 : 25326 : if (gfc_option.rtcheck & GFC_RTCHECK_DO)
2757 : : {
2758 : 191 : tree boundary = is_step_positive ? TYPE_MAX_VALUE (type)
2759 : 191 : : TYPE_MIN_VALUE (type);
2760 : :
2761 : 191 : tmp = fold_build2_loc (loc, EQ_EXPR, logical_type_node,
2762 : : dovar, boundary);
2763 : 191 : gfc_trans_runtime_check (true, false, tmp, &body, &code->loc,
2764 : : "Loop iterates infinitely");
2765 : : }
2766 : :
2767 : : /* Main loop body. */
2768 : 25326 : tmp = gfc_trans_code_cond (code->block->next, exit_cond);
2769 : 25326 : gfc_add_expr_to_block (&body, tmp);
2770 : :
2771 : : /* Label for cycle statements (if needed). */
2772 : 25326 : if (TREE_USED (cycle_label))
2773 : : {
2774 : 25326 : tmp = build1_v (LABEL_EXPR, cycle_label);
2775 : 25326 : gfc_add_expr_to_block (&body, tmp);
2776 : : }
2777 : :
2778 : : /* Check whether someone has modified the loop variable. */
2779 : 25326 : if (gfc_option.rtcheck & GFC_RTCHECK_DO)
2780 : : {
2781 : 191 : tmp = fold_build2_loc (loc, NE_EXPR, logical_type_node,
2782 : : dovar, saved_dovar);
2783 : 191 : gfc_trans_runtime_check (true, false, tmp, &body, &code->loc,
2784 : : "Loop variable has been modified");
2785 : : }
2786 : :
2787 : : /* Increment the loop variable. */
2788 : 25326 : tmp = fold_build2_loc (loc, PLUS_EXPR, type, dovar, step);
2789 : 25326 : gfc_add_modify_loc (loc, &body, dovar, tmp);
2790 : :
2791 : 25326 : if (gfc_option.rtcheck & GFC_RTCHECK_DO)
2792 : 191 : gfc_add_modify_loc (loc, &body, saved_dovar, dovar);
2793 : :
2794 : : /* Finish the loop body. */
2795 : 25326 : tmp = gfc_finish_block (&body);
2796 : 25326 : tmp = fold_build1_loc (loc, LOOP_EXPR, void_type_node, tmp);
2797 : :
2798 : 25326 : gfc_add_expr_to_block (pblock, tmp);
2799 : :
2800 : : /* Add the exit label. */
2801 : 25326 : tmp = build1_v (LABEL_EXPR, exit_label);
2802 : 25326 : gfc_add_expr_to_block (pblock, tmp);
2803 : :
2804 : 25326 : return gfc_finish_block (pblock);
2805 : : }
2806 : :
2807 : : /* Translate the DO construct. This obviously is one of the most
2808 : : important ones to get right with any compiler, but especially
2809 : : so for Fortran.
2810 : :
2811 : : We special case some loop forms as described in gfc_trans_simple_do.
2812 : : For other cases we implement them with a separate loop count,
2813 : : as described in the standard.
2814 : :
2815 : : We translate a do loop from:
2816 : :
2817 : : DO dovar = from, to, step
2818 : : body
2819 : : END DO
2820 : :
2821 : : to:
2822 : :
2823 : : [evaluate loop bounds and step]
2824 : : empty = (step > 0 ? to < from : to > from);
2825 : : countm1 = (to - from) / step;
2826 : : dovar = from;
2827 : : if (empty) goto exit_label;
2828 : : for (;;)
2829 : : {
2830 : : body;
2831 : : cycle_label:
2832 : : dovar += step
2833 : : countm1t = countm1;
2834 : : countm1--;
2835 : : if (countm1t == 0) goto exit_label;
2836 : : }
2837 : : exit_label:
2838 : :
2839 : : countm1 is an unsigned integer. It is equal to the loop count minus one,
2840 : : because the loop count itself can overflow. */
2841 : :
2842 : : tree
2843 : 26361 : gfc_trans_do (gfc_code * code, tree exit_cond)
2844 : : {
2845 : 26361 : gfc_se se;
2846 : 26361 : tree dovar;
2847 : 26361 : tree saved_dovar = NULL;
2848 : 26361 : tree from;
2849 : 26361 : tree to;
2850 : 26361 : tree step;
2851 : 26361 : tree countm1;
2852 : 26361 : tree type;
2853 : 26361 : tree utype;
2854 : 26361 : tree cond;
2855 : 26361 : tree cycle_label;
2856 : 26361 : tree exit_label;
2857 : 26361 : tree tmp;
2858 : 26361 : stmtblock_t block;
2859 : 26361 : stmtblock_t body;
2860 : 26361 : location_t loc;
2861 : :
2862 : 26361 : gfc_start_block (&block);
2863 : :
2864 : 26361 : loc = gfc_get_location (&code->ext.iterator->start->where);
2865 : :
2866 : : /* Evaluate all the expressions in the iterator. */
2867 : 26361 : gfc_init_se (&se, NULL);
2868 : 26361 : gfc_conv_expr_lhs (&se, code->ext.iterator->var);
2869 : 26361 : gfc_add_block_to_block (&block, &se.pre);
2870 : 26361 : dovar = se.expr;
2871 : 26361 : type = TREE_TYPE (dovar);
2872 : :
2873 : 26361 : gfc_init_se (&se, NULL);
2874 : 26361 : gfc_conv_expr_val (&se, code->ext.iterator->start);
2875 : 26361 : gfc_add_block_to_block (&block, &se.pre);
2876 : 26361 : from = gfc_evaluate_now (se.expr, &block);
2877 : :
2878 : 26361 : gfc_init_se (&se, NULL);
2879 : 26361 : gfc_conv_expr_val (&se, code->ext.iterator->end);
2880 : 26361 : gfc_add_block_to_block (&block, &se.pre);
2881 : 26361 : to = gfc_evaluate_now (se.expr, &block);
2882 : :
2883 : 26361 : gfc_init_se (&se, NULL);
2884 : 26361 : gfc_conv_expr_val (&se, code->ext.iterator->step);
2885 : 26361 : gfc_add_block_to_block (&block, &se.pre);
2886 : 26361 : step = gfc_evaluate_now (se.expr, &block);
2887 : :
2888 : 26361 : if (gfc_option.rtcheck & GFC_RTCHECK_DO)
2889 : : {
2890 : 203 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, step,
2891 : : build_zero_cst (type));
2892 : 203 : gfc_trans_runtime_check (true, false, tmp, &block, &code->loc,
2893 : : "DO step value is zero");
2894 : : }
2895 : :
2896 : : /* Special case simple loops. */
2897 : 26361 : if (TREE_CODE (type) == INTEGER_TYPE
2898 : 26361 : && (integer_onep (step)
2899 : 1068 : || tree_int_cst_equal (step, integer_minus_one_node)))
2900 : 25326 : return gfc_trans_simple_do (code, &block, dovar, from, to, step,
2901 : 25326 : exit_cond);
2902 : :
2903 : 1035 : if (TREE_CODE (type) == INTEGER_TYPE)
2904 : 953 : utype = unsigned_type_for (type);
2905 : : else
2906 : 82 : utype = unsigned_type_for (gfc_array_index_type);
2907 : 1035 : countm1 = gfc_create_var (utype, "countm1");
2908 : :
2909 : : /* Cycle and exit statements are implemented with gotos. */
2910 : 1035 : cycle_label = gfc_build_label_decl (NULL_TREE);
2911 : 1035 : exit_label = gfc_build_label_decl (NULL_TREE);
2912 : 1035 : TREE_USED (exit_label) = 1;
2913 : :
2914 : : /* Put these labels where they can be found later. */
2915 : 1035 : code->cycle_label = cycle_label;
2916 : 1035 : code->exit_label = exit_label;
2917 : :
2918 : : /* Initialize the DO variable: dovar = from. */
2919 : 1035 : gfc_add_modify (&block, dovar, from);
2920 : :
2921 : : /* Save value for do-tinkering checking. */
2922 : 1035 : if (gfc_option.rtcheck & GFC_RTCHECK_DO)
2923 : : {
2924 : 12 : saved_dovar = gfc_create_var (type, ".saved_dovar");
2925 : 12 : gfc_add_modify_loc (loc, &block, saved_dovar, dovar);
2926 : : }
2927 : :
2928 : : /* Initialize loop count and jump to exit label if the loop is empty.
2929 : : This code is executed before we enter the loop body. We generate:
2930 : : if (step > 0)
2931 : : {
2932 : : countm1 = (to - from) / step;
2933 : : if (to < from)
2934 : : goto exit_label;
2935 : : }
2936 : : else
2937 : : {
2938 : : countm1 = (from - to) / -step;
2939 : : if (to > from)
2940 : : goto exit_label;
2941 : : }
2942 : : */
2943 : :
2944 : 1035 : if (TREE_CODE (type) == INTEGER_TYPE)
2945 : : {
2946 : 953 : tree pos, neg, tou, fromu, stepu, tmp2;
2947 : :
2948 : : /* The distance from FROM to TO cannot always be represented in a signed
2949 : : type, thus use unsigned arithmetic, also to avoid any undefined
2950 : : overflow issues. */
2951 : 953 : tou = fold_convert (utype, to);
2952 : 953 : fromu = fold_convert (utype, from);
2953 : 953 : stepu = fold_convert (utype, step);
2954 : :
2955 : : /* For a positive step, when to < from, exit, otherwise compute
2956 : : countm1 = ((unsigned)to - (unsigned)from) / (unsigned)step */
2957 : 953 : tmp = fold_build2_loc (loc, LT_EXPR, logical_type_node, to, from);
2958 : 953 : tmp2 = fold_build2_loc (loc, TRUNC_DIV_EXPR, utype,
2959 : : fold_build2_loc (loc, MINUS_EXPR, utype,
2960 : : tou, fromu),
2961 : : stepu);
2962 : 953 : pos = build2 (COMPOUND_EXPR, void_type_node,
2963 : : fold_build2 (MODIFY_EXPR, void_type_node,
2964 : : countm1, tmp2),
2965 : : build3_loc (loc, COND_EXPR, void_type_node,
2966 : : gfc_unlikely (tmp, PRED_FORTRAN_LOOP_PREHEADER),
2967 : : build1_loc (loc, GOTO_EXPR, void_type_node,
2968 : : exit_label), NULL_TREE));
2969 : :
2970 : : /* For a negative step, when to > from, exit, otherwise compute
2971 : : countm1 = ((unsigned)from - (unsigned)to) / -(unsigned)step */
2972 : 953 : tmp = fold_build2_loc (loc, GT_EXPR, logical_type_node, to, from);
2973 : 953 : tmp2 = fold_build2_loc (loc, TRUNC_DIV_EXPR, utype,
2974 : : fold_build2_loc (loc, MINUS_EXPR, utype,
2975 : : fromu, tou),
2976 : : fold_build1_loc (loc, NEGATE_EXPR, utype, stepu));
2977 : 953 : neg = build2 (COMPOUND_EXPR, void_type_node,
2978 : : fold_build2 (MODIFY_EXPR, void_type_node,
2979 : : countm1, tmp2),
2980 : : build3_loc (loc, COND_EXPR, void_type_node,
2981 : : gfc_unlikely (tmp, PRED_FORTRAN_LOOP_PREHEADER),
2982 : : build1_loc (loc, GOTO_EXPR, void_type_node,
2983 : : exit_label), NULL_TREE));
2984 : :
2985 : 953 : tmp = fold_build2_loc (loc, LT_EXPR, logical_type_node, step,
2986 : 953 : build_int_cst (TREE_TYPE (step), 0));
2987 : 953 : tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp, neg, pos);
2988 : :
2989 : 953 : gfc_add_expr_to_block (&block, tmp);
2990 : : }
2991 : : else
2992 : : {
2993 : 82 : tree pos_step;
2994 : :
2995 : : /* TODO: We could use the same width as the real type.
2996 : : This would probably cause more problems that it solves
2997 : : when we implement "long double" types. */
2998 : :
2999 : 82 : tmp = fold_build2_loc (loc, MINUS_EXPR, type, to, from);
3000 : 82 : tmp = fold_build2_loc (loc, RDIV_EXPR, type, tmp, step);
3001 : 82 : tmp = fold_build1_loc (loc, FIX_TRUNC_EXPR, utype, tmp);
3002 : 82 : gfc_add_modify (&block, countm1, tmp);
3003 : :
3004 : : /* We need a special check for empty loops:
3005 : : empty = (step > 0 ? to < from : to > from); */
3006 : 82 : pos_step = fold_build2_loc (loc, GT_EXPR, logical_type_node, step,
3007 : : build_zero_cst (type));
3008 : 82 : tmp = fold_build3_loc (loc, COND_EXPR, logical_type_node, pos_step,
3009 : : fold_build2_loc (loc, LT_EXPR,
3010 : : logical_type_node, to, from),
3011 : : fold_build2_loc (loc, GT_EXPR,
3012 : : logical_type_node, to, from));
3013 : : /* If the loop is empty, go directly to the exit label. */
3014 : 82 : tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp,
3015 : : build1_v (GOTO_EXPR, exit_label),
3016 : : build_empty_stmt (input_location));
3017 : 82 : gfc_add_expr_to_block (&block, tmp);
3018 : : }
3019 : :
3020 : : /* Loop body. */
3021 : 1035 : gfc_start_block (&body);
3022 : :
3023 : : /* Main loop body. */
3024 : 1035 : tmp = gfc_trans_code_cond (code->block->next, exit_cond);
3025 : 1035 : gfc_add_expr_to_block (&body, tmp);
3026 : :
3027 : : /* Label for cycle statements (if needed). */
3028 : 1035 : if (TREE_USED (cycle_label))
3029 : : {
3030 : 1035 : tmp = build1_v (LABEL_EXPR, cycle_label);
3031 : 1035 : gfc_add_expr_to_block (&body, tmp);
3032 : : }
3033 : :
3034 : : /* Check whether someone has modified the loop variable. */
3035 : 1035 : if (gfc_option.rtcheck & GFC_RTCHECK_DO)
3036 : : {
3037 : 12 : tmp = fold_build2_loc (loc, NE_EXPR, logical_type_node, dovar,
3038 : : saved_dovar);
3039 : 12 : gfc_trans_runtime_check (true, false, tmp, &body, &code->loc,
3040 : : "Loop variable has been modified");
3041 : : }
3042 : :
3043 : : /* Exit the loop if there is an I/O result condition or error. */
3044 : 1035 : if (exit_cond)
3045 : : {
3046 : 1 : tmp = build1_v (GOTO_EXPR, exit_label);
3047 : 1 : tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
3048 : : exit_cond, tmp,
3049 : : build_empty_stmt (input_location));
3050 : 1 : gfc_add_expr_to_block (&body, tmp);
3051 : : }
3052 : :
3053 : : /* Increment the loop variable. */
3054 : 1035 : tmp = fold_build2_loc (loc, PLUS_EXPR, type, dovar, step);
3055 : 1035 : gfc_add_modify_loc (loc, &body, dovar, tmp);
3056 : :
3057 : 1035 : if (gfc_option.rtcheck & GFC_RTCHECK_DO)
3058 : 12 : gfc_add_modify_loc (loc, &body, saved_dovar, dovar);
3059 : :
3060 : : /* Initialize countm1t. */
3061 : 1035 : tree countm1t = gfc_create_var (utype, "countm1t");
3062 : 1035 : gfc_add_modify_loc (loc, &body, countm1t, countm1);
3063 : :
3064 : : /* Decrement the loop count. */
3065 : 1035 : tmp = fold_build2_loc (loc, MINUS_EXPR, utype, countm1,
3066 : : build_int_cst (utype, 1));
3067 : 1035 : gfc_add_modify_loc (loc, &body, countm1, tmp);
3068 : :
3069 : : /* End with the loop condition. Loop until countm1t == 0. */
3070 : 1035 : cond = fold_build2_loc (loc, EQ_EXPR, logical_type_node, countm1t,
3071 : : build_int_cst (utype, 0));
3072 : 1035 : if (code->ext.iterator->annot.unroll && cond != error_mark_node)
3073 : 3 : cond
3074 : 3 : = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond,
3075 : : build_int_cst (integer_type_node, annot_expr_unroll_kind),
3076 : : build_int_cst (integer_type_node,
3077 : 3 : code->ext.iterator->annot.unroll));
3078 : :
3079 : 1035 : if (code->ext.iterator->annot.ivdep && cond != error_mark_node)
3080 : 0 : cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond,
3081 : : build_int_cst (integer_type_node, annot_expr_ivdep_kind),
3082 : : integer_zero_node);
3083 : 1035 : if (code->ext.iterator->annot.vector && cond != error_mark_node)
3084 : 0 : cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond,
3085 : : build_int_cst (integer_type_node, annot_expr_vector_kind),
3086 : : integer_zero_node);
3087 : 1035 : if (code->ext.iterator->annot.novector && cond != error_mark_node)
3088 : 0 : cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond,
3089 : : build_int_cst (integer_type_node, annot_expr_no_vector_kind),
3090 : : integer_zero_node);
3091 : :
3092 : 1035 : tmp = fold_build1_loc (loc, GOTO_EXPR, void_type_node, exit_label);
3093 : 1035 : tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
3094 : : cond, tmp, build_empty_stmt (loc));
3095 : 1035 : gfc_add_expr_to_block (&body, tmp);
3096 : :
3097 : : /* End of loop body. */
3098 : 1035 : tmp = gfc_finish_block (&body);
3099 : :
3100 : : /* The for loop itself. */
3101 : 1035 : tmp = fold_build1_loc (loc, LOOP_EXPR, void_type_node, tmp);
3102 : 1035 : gfc_add_expr_to_block (&block, tmp);
3103 : :
3104 : : /* Add the exit label. */
3105 : 1035 : tmp = build1_v (LABEL_EXPR, exit_label);
3106 : 1035 : gfc_add_expr_to_block (&block, tmp);
3107 : :
3108 : 1035 : return gfc_finish_block (&block);
3109 : : }
3110 : :
3111 : :
3112 : : /* Translate the DO WHILE construct.
3113 : :
3114 : : We translate
3115 : :
3116 : : DO WHILE (cond)
3117 : : body
3118 : : END DO
3119 : :
3120 : : to:
3121 : :
3122 : : for ( ; ; )
3123 : : {
3124 : : pre_cond;
3125 : : if (! cond) goto exit_label;
3126 : : body;
3127 : : cycle_label:
3128 : : }
3129 : : exit_label:
3130 : :
3131 : : Because the evaluation of the exit condition `cond' may have side
3132 : : effects, we can't do much for empty loop bodies. The backend optimizers
3133 : : should be smart enough to eliminate any dead loops. */
3134 : :
3135 : : tree
3136 : 498 : gfc_trans_do_while (gfc_code * code)
3137 : : {
3138 : 498 : gfc_se cond;
3139 : 498 : tree tmp;
3140 : 498 : tree cycle_label;
3141 : 498 : tree exit_label;
3142 : 498 : stmtblock_t block;
3143 : :
3144 : : /* Everything we build here is part of the loop body. */
3145 : 498 : gfc_start_block (&block);
3146 : :
3147 : : /* Cycle and exit statements are implemented with gotos. */
3148 : 498 : cycle_label = gfc_build_label_decl (NULL_TREE);
3149 : 498 : exit_label = gfc_build_label_decl (NULL_TREE);
3150 : :
3151 : : /* Put the labels where they can be found later. See gfc_trans_do(). */
3152 : 498 : code->cycle_label = cycle_label;
3153 : 498 : code->exit_label = exit_label;
3154 : :
3155 : : /* Create a GIMPLE version of the exit condition. */
3156 : 498 : gfc_init_se (&cond, NULL);
3157 : 498 : gfc_conv_expr_val (&cond, code->expr1);
3158 : 498 : gfc_add_block_to_block (&block, &cond.pre);
3159 : 498 : cond.expr = fold_build1_loc (gfc_get_location (&code->expr1->where),
3160 : 498 : TRUTH_NOT_EXPR, TREE_TYPE (cond.expr),
3161 : : cond.expr);
3162 : :
3163 : : /* Build "IF (! cond) GOTO exit_label". */
3164 : 498 : tmp = build1_v (GOTO_EXPR, exit_label);
3165 : 498 : TREE_USED (exit_label) = 1;
3166 : 498 : tmp = fold_build3_loc (gfc_get_location (&code->expr1->where), COND_EXPR,
3167 : : void_type_node, cond.expr, tmp,
3168 : : build_empty_stmt (gfc_get_location (
3169 : 498 : &code->expr1->where)));
3170 : 498 : gfc_add_expr_to_block (&block, tmp);
3171 : :
3172 : : /* The main body of the loop. */
3173 : 498 : tmp = gfc_trans_code (code->block->next);
3174 : 498 : gfc_add_expr_to_block (&block, tmp);
3175 : :
3176 : : /* Label for cycle statements (if needed). */
3177 : 498 : if (TREE_USED (cycle_label))
3178 : : {
3179 : 498 : tmp = build1_v (LABEL_EXPR, cycle_label);
3180 : 498 : gfc_add_expr_to_block (&block, tmp);
3181 : : }
3182 : :
3183 : : /* End of loop body. */
3184 : 498 : tmp = gfc_finish_block (&block);
3185 : :
3186 : 498 : gfc_init_block (&block);
3187 : : /* Build the loop. */
3188 : 498 : tmp = fold_build1_loc (gfc_get_location (&code->expr1->where), LOOP_EXPR,
3189 : : void_type_node, tmp);
3190 : 498 : gfc_add_expr_to_block (&block, tmp);
3191 : :
3192 : : /* Add the exit label. */
3193 : 498 : tmp = build1_v (LABEL_EXPR, exit_label);
3194 : 498 : gfc_add_expr_to_block (&block, tmp);
3195 : :
3196 : 498 : return gfc_finish_block (&block);
3197 : : }
3198 : :
3199 : :
3200 : : /* Deal with the particular case of SELECT_TYPE, where the vtable
3201 : : addresses are used for the selection. Since these are not sorted,
3202 : : the selection has to be made by a series of if statements. */
3203 : :
3204 : : static tree
3205 : 2858 : gfc_trans_select_type_cases (gfc_code * code)
3206 : : {
3207 : 2858 : gfc_code *c;
3208 : 2858 : gfc_case *cp;
3209 : 2858 : tree tmp;
3210 : 2858 : tree cond;
3211 : 2858 : tree low;
3212 : 2858 : tree high;
3213 : 2858 : gfc_se se;
3214 : 2858 : gfc_se cse;
3215 : 2858 : stmtblock_t block;
3216 : 2858 : stmtblock_t body;
3217 : 2858 : bool def = false;
3218 : 2858 : gfc_expr *e;
3219 : 2858 : gfc_start_block (&block);
3220 : :
3221 : : /* Calculate the switch expression. */
3222 : 2858 : gfc_init_se (&se, NULL);
3223 : 2858 : gfc_conv_expr_val (&se, code->expr1);
3224 : 2858 : gfc_add_block_to_block (&block, &se.pre);
3225 : :
3226 : : /* Generate an expression for the selector hash value, for
3227 : : use to resolve character cases. */
3228 : 2858 : e = gfc_copy_expr (code->expr1->value.function.actual->expr);
3229 : 2858 : gfc_add_hash_component (e);
3230 : :
3231 : 2858 : TREE_USED (code->exit_label) = 0;
3232 : :
3233 : 5716 : repeat:
3234 : 15812 : for (c = code->block; c; c = c->block)
3235 : : {
3236 : 10096 : cp = c->ext.block.case_list;
3237 : :
3238 : : /* Assume it's the default case. */
3239 : 10096 : low = NULL_TREE;
3240 : 10096 : high = NULL_TREE;
3241 : 10096 : tmp = NULL_TREE;
3242 : :
3243 : : /* Put the default case at the end. */
3244 : 10096 : if ((!def && !cp->low) || (def && cp->low))
3245 : 5048 : continue;
3246 : :
3247 : 5048 : if (cp->low && (cp->ts.type == BT_CLASS
3248 : 3292 : || cp->ts.type == BT_DERIVED))
3249 : : {
3250 : 1885 : gfc_init_se (&cse, NULL);
3251 : 1885 : gfc_conv_expr_val (&cse, cp->low);
3252 : 1885 : gfc_add_block_to_block (&block, &cse.pre);
3253 : 1885 : low = cse.expr;
3254 : : }
3255 : 3163 : else if (cp->ts.type != BT_UNKNOWN)
3256 : : {
3257 : 1407 : gcc_assert (cp->high);
3258 : 1407 : gfc_init_se (&cse, NULL);
3259 : 1407 : gfc_conv_expr_val (&cse, cp->high);
3260 : 1407 : gfc_add_block_to_block (&block, &cse.pre);
3261 : 1407 : high = cse.expr;
3262 : : }
3263 : :
3264 : 5048 : gfc_init_block (&body);
3265 : :
3266 : : /* Add the statements for this case. */
3267 : 5048 : tmp = gfc_trans_code (c->next);
3268 : 5048 : gfc_add_expr_to_block (&body, tmp);
3269 : :
3270 : : /* Break to the end of the SELECT TYPE construct. The default
3271 : : case just falls through. */
3272 : 5048 : if (!def)
3273 : : {
3274 : 3292 : TREE_USED (code->exit_label) = 1;
3275 : 3292 : tmp = build1_v (GOTO_EXPR, code->exit_label);
3276 : 3292 : gfc_add_expr_to_block (&body, tmp);
3277 : : }
3278 : :
3279 : 5048 : tmp = gfc_finish_block (&body);
3280 : :
3281 : 5048 : if (low != NULL_TREE)
3282 : : {
3283 : : /* Compare vtable pointers. */
3284 : 1885 : cond = fold_build2_loc (input_location, EQ_EXPR,
3285 : 1885 : TREE_TYPE (se.expr), se.expr, low);
3286 : 1885 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
3287 : : cond, tmp,
3288 : : build_empty_stmt (input_location));
3289 : : }
3290 : 3163 : else if (high != NULL_TREE)
3291 : : {
3292 : : /* Compare hash values for character cases. */
3293 : 1407 : gfc_init_se (&cse, NULL);
3294 : 1407 : gfc_conv_expr_val (&cse, e);
3295 : 1407 : gfc_add_block_to_block (&block, &cse.pre);
3296 : :
3297 : 1407 : cond = fold_build2_loc (input_location, EQ_EXPR,
3298 : 1407 : TREE_TYPE (se.expr), high, cse.expr);
3299 : 1407 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
3300 : : cond, tmp,
3301 : : build_empty_stmt (input_location));
3302 : : }
3303 : :
3304 : 5048 : gfc_add_expr_to_block (&block, tmp);
3305 : : }
3306 : :
3307 : 5716 : if (!def)
3308 : : {
3309 : 2858 : def = true;
3310 : 2858 : goto repeat;
3311 : : }
3312 : :
3313 : 2858 : gfc_free_expr (e);
3314 : :
3315 : 2858 : return gfc_finish_block (&block);
3316 : : }
3317 : :
3318 : :
3319 : : /* Translate the SELECT CASE construct for INTEGER case expressions,
3320 : : without killing all potential optimizations. The problem is that
3321 : : Fortran allows unbounded cases, but the back-end does not, so we
3322 : : need to intercept those before we enter the equivalent SWITCH_EXPR
3323 : : we can build.
3324 : :
3325 : : For example, we translate this,
3326 : :
3327 : : SELECT CASE (expr)
3328 : : CASE (:100,101,105:115)
3329 : : block_1
3330 : : CASE (190:199,200:)
3331 : : block_2
3332 : : CASE (300)
3333 : : block_3
3334 : : CASE DEFAULT
3335 : : block_4
3336 : : END SELECT
3337 : :
3338 : : to the GENERIC equivalent,
3339 : :
3340 : : switch (expr)
3341 : : {
3342 : : case (minimum value for typeof(expr) ... 100:
3343 : : case 101:
3344 : : case 105 ... 114:
3345 : : block1:
3346 : : goto end_label;
3347 : :
3348 : : case 200 ... (maximum value for typeof(expr):
3349 : : case 190 ... 199:
3350 : : block2;
3351 : : goto end_label;
3352 : :
3353 : : case 300:
3354 : : block_3;
3355 : : goto end_label;
3356 : :
3357 : : default:
3358 : : block_4;
3359 : : goto end_label;
3360 : : }
3361 : :
3362 : : end_label: */
3363 : :
3364 : : static tree
3365 : 891 : gfc_trans_integer_select (gfc_code * code)
3366 : : {
3367 : 891 : gfc_code *c;
3368 : 891 : gfc_case *cp;
3369 : 891 : tree end_label;
3370 : 891 : tree tmp;
3371 : 891 : gfc_se se;
3372 : 891 : stmtblock_t block;
3373 : 891 : stmtblock_t body;
3374 : :
3375 : 891 : gfc_start_block (&block);
3376 : :
3377 : : /* Calculate the switch expression. */
3378 : 891 : gfc_init_se (&se, NULL);
3379 : 891 : gfc_conv_expr_val (&se, code->expr1);
3380 : 891 : gfc_add_block_to_block (&block, &se.pre);
3381 : :
3382 : 891 : end_label = gfc_build_label_decl (NULL_TREE);
3383 : :
3384 : 891 : gfc_init_block (&body);
3385 : :
3386 : 2704 : for (c = code->block; c; c = c->block)
3387 : : {
3388 : 3698 : for (cp = c->ext.block.case_list; cp; cp = cp->next)
3389 : : {
3390 : 1885 : tree low, high;
3391 : 1885 : tree label;
3392 : :
3393 : : /* Assume it's the default case. */
3394 : 1885 : low = high = NULL_TREE;
3395 : :
3396 : 1885 : if (cp->low)
3397 : : {
3398 : 1497 : if (cp->low->ts.type == BT_INTEGER)
3399 : 1455 : low = gfc_conv_mpz_to_tree (cp->low->value.integer,
3400 : : cp->low->ts.kind);
3401 : : else
3402 : 42 : low = gfc_conv_mpz_unsigned_to_tree (cp->low->value.integer,
3403 : : cp->low->ts.kind);
3404 : :
3405 : : /* If there's only a lower bound, set the high bound to the
3406 : : maximum value of the case expression. */
3407 : 1497 : if (!cp->high)
3408 : 45 : high = TYPE_MAX_VALUE (TREE_TYPE (se.expr));
3409 : : }
3410 : :
3411 : 1885 : if (cp->high)
3412 : : {
3413 : : /* Three cases are possible here:
3414 : :
3415 : : 1) There is no lower bound, e.g. CASE (:N).
3416 : : 2) There is a lower bound .NE. high bound, that is
3417 : : a case range, e.g. CASE (N:M) where M>N (we make
3418 : : sure that M>N during type resolution).
3419 : : 3) There is a lower bound, and it has the same value
3420 : : as the high bound, e.g. CASE (N:N). This is our
3421 : : internal representation of CASE(N).
3422 : :
3423 : : In the first and second case, we need to set a value for
3424 : : high. In the third case, we don't because the GCC middle
3425 : : end represents a single case value by just letting high be
3426 : : a NULL_TREE. We can't do that because we need to be able
3427 : : to represent unbounded cases. */
3428 : :
3429 : 1496 : if (!cp->low
3430 : 1452 : || (mpz_cmp (cp->low->value.integer,
3431 : 1452 : cp->high->value.integer) != 0))
3432 : : {
3433 : 73 : if (cp->high->ts.type == BT_INTEGER)
3434 : 73 : high = gfc_conv_mpz_to_tree (cp->high->value.integer,
3435 : : cp->high->ts.kind);
3436 : : else
3437 : 0 : high
3438 : 0 : = gfc_conv_mpz_unsigned_to_tree (cp->high->value.integer,
3439 : : cp->high->ts.kind);
3440 : : }
3441 : :
3442 : : /* Unbounded case. */
3443 : 1496 : if (!cp->low)
3444 : 44 : low = TYPE_MIN_VALUE (TREE_TYPE (se.expr));
3445 : : }
3446 : :
3447 : : /* Build a label. */
3448 : 1885 : label = gfc_build_label_decl (NULL_TREE);
3449 : :
3450 : : /* Add this case label.
3451 : : Add parameter 'label', make it match GCC backend. */
3452 : 1885 : tmp = build_case_label (low, high, label);
3453 : 1885 : gfc_add_expr_to_block (&body, tmp);
3454 : : }
3455 : :
3456 : : /* Add the statements for this case. */
3457 : 1813 : tmp = gfc_trans_code (c->next);
3458 : 1813 : gfc_add_expr_to_block (&body, tmp);
3459 : :
3460 : : /* Break to the end of the construct. */
3461 : 1813 : tmp = build1_v (GOTO_EXPR, end_label);
3462 : 1813 : gfc_add_expr_to_block (&body, tmp);
3463 : : }
3464 : :
3465 : 891 : tmp = gfc_finish_block (&body);
3466 : 891 : tmp = fold_build2_loc (input_location, SWITCH_EXPR, NULL_TREE, se.expr, tmp);
3467 : 891 : gfc_add_expr_to_block (&block, tmp);
3468 : :
3469 : 891 : tmp = build1_v (LABEL_EXPR, end_label);
3470 : 891 : gfc_add_expr_to_block (&block, tmp);
3471 : :
3472 : 891 : return gfc_finish_block (&block);
3473 : : }
3474 : :
3475 : :
3476 : : /* Translate the SELECT CASE construct for LOGICAL case expressions.
3477 : :
3478 : : There are only two cases possible here, even though the standard
3479 : : does allow three cases in a LOGICAL SELECT CASE construct: .TRUE.,
3480 : : .FALSE., and DEFAULT.
3481 : :
3482 : : We never generate more than two blocks here. Instead, we always
3483 : : try to eliminate the DEFAULT case. This way, we can translate this
3484 : : kind of SELECT construct to a simple
3485 : :
3486 : : if {} else {};
3487 : :
3488 : : expression in GENERIC. */
3489 : :
3490 : : static tree
3491 : 54 : gfc_trans_logical_select (gfc_code * code)
3492 : : {
3493 : 54 : gfc_code *c;
3494 : 54 : gfc_code *t, *f, *d;
3495 : 54 : gfc_case *cp;
3496 : 54 : gfc_se se;
3497 : 54 : stmtblock_t block;
3498 : :
3499 : : /* Assume we don't have any cases at all. */
3500 : 54 : t = f = d = NULL;
3501 : :
3502 : : /* Now see which ones we actually do have. We can have at most two
3503 : : cases in a single case list: one for .TRUE. and one for .FALSE.
3504 : : The default case is always separate. If the cases for .TRUE. and
3505 : : .FALSE. are in the same case list, the block for that case list
3506 : : always executed, and we don't generate code a COND_EXPR. */
3507 : 171 : for (c = code->block; c; c = c->block)
3508 : : {
3509 : 243 : for (cp = c->ext.block.case_list; cp; cp = cp->next)
3510 : : {
3511 : 126 : if (cp->low)
3512 : : {
3513 : 72 : if (cp->low->value.logical == 0) /* .FALSE. */
3514 : : f = c;
3515 : : else /* if (cp->value.logical != 0), thus .TRUE. */
3516 : 36 : t = c;
3517 : : }
3518 : : else
3519 : : d = c;
3520 : : }
3521 : : }
3522 : :
3523 : : /* Start a new block. */
3524 : 54 : gfc_start_block (&block);
3525 : :
3526 : : /* Calculate the switch expression. We always need to do this
3527 : : because it may have side effects. */
3528 : 54 : gfc_init_se (&se, NULL);
3529 : 54 : gfc_conv_expr_val (&se, code->expr1);
3530 : 54 : gfc_add_block_to_block (&block, &se.pre);
3531 : :
3532 : 54 : if (t == f && t != NULL)
3533 : : {
3534 : : /* Cases for .TRUE. and .FALSE. are in the same block. Just
3535 : : translate the code for these cases, append it to the current
3536 : : block. */
3537 : 9 : gfc_add_expr_to_block (&block, gfc_trans_code (t->next));
3538 : : }
3539 : : else
3540 : : {
3541 : 45 : tree true_tree, false_tree, stmt;
3542 : :
3543 : 45 : true_tree = build_empty_stmt (input_location);
3544 : 45 : false_tree = build_empty_stmt (input_location);
3545 : :
3546 : : /* If we have a case for .TRUE. and for .FALSE., discard the default case.
3547 : : Otherwise, if .TRUE. or .FALSE. is missing and there is a default case,
3548 : : make the missing case the default case. */
3549 : 45 : if (t != NULL && f != NULL)
3550 : 63 : d = NULL;
3551 : 36 : else if (d != NULL)
3552 : : {
3553 : 36 : if (t == NULL)
3554 : : t = d;
3555 : : else
3556 : : f = d;
3557 : : }
3558 : :
3559 : : /* Translate the code for each of these blocks, and append it to
3560 : : the current block. */
3561 : 18 : if (t != NULL)
3562 : 45 : true_tree = gfc_trans_code (t->next);
3563 : :
3564 : 45 : if (f != NULL)
3565 : 45 : false_tree = gfc_trans_code (f->next);
3566 : :
3567 : 45 : stmt = fold_build3_loc (input_location, COND_EXPR, void_type_node,
3568 : : se.expr, true_tree, false_tree);
3569 : 45 : gfc_add_expr_to_block (&block, stmt);
3570 : : }
3571 : :
3572 : 54 : return gfc_finish_block (&block);
3573 : : }
3574 : :
3575 : :
3576 : : /* The jump table types are stored in static variables to avoid
3577 : : constructing them from scratch every single time. */
3578 : : static GTY(()) tree select_struct[2];
3579 : :
3580 : : /* Translate the SELECT CASE construct for CHARACTER case expressions.
3581 : : Instead of generating compares and jumps, it is far simpler to
3582 : : generate a data structure describing the cases in order and call a
3583 : : library subroutine that locates the right case.
3584 : : This is particularly true because this is the only case where we
3585 : : might have to dispose of a temporary.
3586 : : The library subroutine returns a pointer to jump to or NULL if no
3587 : : branches are to be taken. */
3588 : :
3589 : : static tree
3590 : 75 : gfc_trans_character_select (gfc_code *code)
3591 : : {
3592 : 75 : tree init, end_label, tmp, type, case_num, label, fndecl;
3593 : 75 : stmtblock_t block, body;
3594 : 75 : gfc_case *cp, *d;
3595 : 75 : gfc_code *c;
3596 : 75 : gfc_se se, expr1se;
3597 : 75 : int n, k;
3598 : 75 : vec<constructor_elt, va_gc> *inits = NULL;
3599 : :
3600 : 75 : tree pchartype = gfc_get_pchar_type (code->expr1->ts.kind);
3601 : :
3602 : : /* The jump table types are stored in static variables to avoid
3603 : : constructing them from scratch every single time. */
3604 : 75 : static tree ss_string1[2], ss_string1_len[2];
3605 : 75 : static tree ss_string2[2], ss_string2_len[2];
3606 : 75 : static tree ss_target[2];
3607 : :
3608 : 75 : cp = code->block->ext.block.case_list;
3609 : 241 : while (cp->left != NULL)
3610 : : cp = cp->left;
3611 : :
3612 : : /* Generate the body */
3613 : 75 : gfc_start_block (&block);
3614 : 75 : gfc_init_se (&expr1se, NULL);
3615 : 75 : gfc_conv_expr_reference (&expr1se, code->expr1);
3616 : :
3617 : 75 : gfc_add_block_to_block (&block, &expr1se.pre);
3618 : :
3619 : 75 : end_label = gfc_build_label_decl (NULL_TREE);
3620 : :
3621 : 75 : gfc_init_block (&body);
3622 : :
3623 : : /* Attempt to optimize length 1 selects. */
3624 : 75 : if (integer_onep (expr1se.string_length))
3625 : : {
3626 : 126 : for (d = cp; d; d = d->right)
3627 : : {
3628 : 110 : gfc_charlen_t i;
3629 : 110 : if (d->low)
3630 : : {
3631 : 100 : gcc_assert (d->low->expr_type == EXPR_CONSTANT
3632 : : && d->low->ts.type == BT_CHARACTER);
3633 : 100 : if (d->low->value.character.length > 1)
3634 : : {
3635 : 2 : for (i = 1; i < d->low->value.character.length; i++)
3636 : 2 : if (d->low->value.character.string[i] != ' ')
3637 : : break;
3638 : 2 : if (i != d->low->value.character.length)
3639 : : {
3640 : 2 : if (optimize && d->high && i == 1)
3641 : : {
3642 : 2 : gcc_assert (d->high->expr_type == EXPR_CONSTANT
3643 : : && d->high->ts.type == BT_CHARACTER);
3644 : 2 : if (d->high->value.character.length > 1
3645 : 2 : && (d->low->value.character.string[0]
3646 : 2 : == d->high->value.character.string[0])
3647 : 2 : && d->high->value.character.string[1] != ' '
3648 : 4 : && ((d->low->value.character.string[1] < ' ')
3649 : : == (d->high->value.character.string[1]
3650 : 2 : < ' ')))
3651 : 2 : continue;
3652 : : }
3653 : : break;
3654 : : }
3655 : : }
3656 : : }
3657 : 108 : if (d->high)
3658 : : {
3659 : 98 : gcc_assert (d->high->expr_type == EXPR_CONSTANT
3660 : : && d->high->ts.type == BT_CHARACTER);
3661 : 98 : if (d->high->value.character.length > 1)
3662 : : {
3663 : 3 : for (i = 1; i < d->high->value.character.length; i++)
3664 : 2 : if (d->high->value.character.string[i] != ' ')
3665 : : break;
3666 : 1 : if (i != d->high->value.character.length)
3667 : : break;
3668 : : }
3669 : : }
3670 : : }
3671 : 16 : if (d == NULL)
3672 : : {
3673 : 16 : tree ctype = gfc_get_char_type (code->expr1->ts.kind);
3674 : :
3675 : 58 : for (c = code->block; c; c = c->block)
3676 : : {
3677 : 152 : for (cp = c->ext.block.case_list; cp; cp = cp->next)
3678 : : {
3679 : 110 : tree low, high;
3680 : 110 : tree label;
3681 : 110 : gfc_char_t r;
3682 : :
3683 : : /* Assume it's the default case. */
3684 : 110 : low = high = NULL_TREE;
3685 : :
3686 : 110 : if (cp->low)
3687 : : {
3688 : : /* CASE ('ab') or CASE ('ab':'az') will never match
3689 : : any length 1 character. */
3690 : 100 : if (cp->low->value.character.length > 1
3691 : 2 : && cp->low->value.character.string[1] != ' ')
3692 : 2 : continue;
3693 : :
3694 : 98 : if (cp->low->value.character.length > 0)
3695 : 97 : r = cp->low->value.character.string[0];
3696 : : else
3697 : : r = ' ';
3698 : 98 : low = build_int_cst (ctype, r);
3699 : :
3700 : : /* If there's only a lower bound, set the high bound
3701 : : to the maximum value of the case expression. */
3702 : 98 : if (!cp->high)
3703 : 0 : high = TYPE_MAX_VALUE (ctype);
3704 : : }
3705 : :
3706 : 108 : if (cp->high)
3707 : : {
3708 : 98 : if (!cp->low
3709 : 98 : || (cp->low->value.character.string[0]
3710 : 98 : != cp->high->value.character.string[0]))
3711 : : {
3712 : 2 : if (cp->high->value.character.length > 0)
3713 : 2 : r = cp->high->value.character.string[0];
3714 : : else
3715 : : r = ' ';
3716 : 2 : high = build_int_cst (ctype, r);
3717 : : }
3718 : :
3719 : : /* Unbounded case. */
3720 : 98 : if (!cp->low)
3721 : 0 : low = TYPE_MIN_VALUE (ctype);
3722 : : }
3723 : :
3724 : : /* Build a label. */
3725 : 108 : label = gfc_build_label_decl (NULL_TREE);
3726 : :
3727 : : /* Add this case label.
3728 : : Add parameter 'label', make it match GCC backend. */
3729 : 108 : tmp = build_case_label (low, high, label);
3730 : 108 : gfc_add_expr_to_block (&body, tmp);
3731 : : }
3732 : :
3733 : : /* Add the statements for this case. */
3734 : 42 : tmp = gfc_trans_code (c->next);
3735 : 42 : gfc_add_expr_to_block (&body, tmp);
3736 : :
3737 : : /* Break to the end of the construct. */
3738 : 42 : tmp = build1_v (GOTO_EXPR, end_label);
3739 : 42 : gfc_add_expr_to_block (&body, tmp);
3740 : : }
3741 : :
3742 : 32 : tmp = gfc_string_to_single_character (expr1se.string_length,
3743 : : expr1se.expr,
3744 : 16 : code->expr1->ts.kind);
3745 : 16 : case_num = gfc_create_var (ctype, "case_num");
3746 : 16 : gfc_add_modify (&block, case_num, tmp);
3747 : :
3748 : 16 : gfc_add_block_to_block (&block, &expr1se.post);
3749 : :
3750 : 16 : tmp = gfc_finish_block (&body);
3751 : 16 : tmp = fold_build2_loc (input_location, SWITCH_EXPR, NULL_TREE,
3752 : : case_num, tmp);
3753 : 16 : gfc_add_expr_to_block (&block, tmp);
3754 : :
3755 : 16 : tmp = build1_v (LABEL_EXPR, end_label);
3756 : 16 : gfc_add_expr_to_block (&block, tmp);
3757 : :
3758 : 16 : return gfc_finish_block (&block);
3759 : : }
3760 : : }
3761 : :
3762 : 59 : if (code->expr1->ts.kind == 1)
3763 : : k = 0;
3764 : 6 : else if (code->expr1->ts.kind == 4)
3765 : : k = 1;
3766 : : else
3767 : 0 : gcc_unreachable ();
3768 : :
3769 : 59 : if (select_struct[k] == NULL)
3770 : : {
3771 : 53 : tree *chain = NULL;
3772 : 53 : select_struct[k] = make_node (RECORD_TYPE);
3773 : :
3774 : 53 : if (code->expr1->ts.kind == 1)
3775 : 47 : TYPE_NAME (select_struct[k]) = get_identifier ("_jump_struct_char1");
3776 : 6 : else if (code->expr1->ts.kind == 4)
3777 : 6 : TYPE_NAME (select_struct[k]) = get_identifier ("_jump_struct_char4");
3778 : : else
3779 : 0 : gcc_unreachable ();
3780 : :
3781 : : #undef ADD_FIELD
3782 : : #define ADD_FIELD(NAME, TYPE) \
3783 : : ss_##NAME[k] = gfc_add_field_to_struct (select_struct[k], \
3784 : : get_identifier (stringize(NAME)), \
3785 : : TYPE, \
3786 : : &chain)
3787 : :
3788 : 53 : ADD_FIELD (string1, pchartype);
3789 : 53 : ADD_FIELD (string1_len, gfc_charlen_type_node);
3790 : :
3791 : 53 : ADD_FIELD (string2, pchartype);
3792 : 53 : ADD_FIELD (string2_len, gfc_charlen_type_node);
3793 : :
3794 : 53 : ADD_FIELD (target, integer_type_node);
3795 : : #undef ADD_FIELD
3796 : :
3797 : 53 : gfc_finish_type (select_struct[k]);
3798 : : }
3799 : :
3800 : : n = 0;
3801 : 311 : for (d = cp; d; d = d->right)
3802 : 252 : d->n = n++;
3803 : :
3804 : 263 : for (c = code->block; c; c = c->block)
3805 : : {
3806 : 456 : for (d = c->ext.block.case_list; d; d = d->next)
3807 : : {
3808 : 252 : label = gfc_build_label_decl (NULL_TREE);
3809 : 452 : tmp = build_case_label ((d->low == NULL && d->high == NULL)
3810 : : ? NULL
3811 : 200 : : build_int_cst (integer_type_node, d->n),
3812 : : NULL, label);
3813 : 252 : gfc_add_expr_to_block (&body, tmp);
3814 : : }
3815 : :
3816 : 204 : tmp = gfc_trans_code (c->next);
3817 : 204 : gfc_add_expr_to_block (&body, tmp);
3818 : :
3819 : 204 : tmp = build1_v (GOTO_EXPR, end_label);
3820 : 204 : gfc_add_expr_to_block (&body, tmp);
3821 : : }
3822 : :
3823 : : /* Generate the structure describing the branches */
3824 : 311 : for (d = cp; d; d = d->right)
3825 : : {
3826 : 252 : vec<constructor_elt, va_gc> *node = NULL;
3827 : :
3828 : 252 : gfc_init_se (&se, NULL);
3829 : :
3830 : 252 : if (d->low == NULL)
3831 : : {
3832 : 52 : CONSTRUCTOR_APPEND_ELT (node, ss_string1[k], null_pointer_node);
3833 : 52 : CONSTRUCTOR_APPEND_ELT (node, ss_string1_len[k], build_zero_cst (gfc_charlen_type_node));
3834 : : }
3835 : : else
3836 : : {
3837 : 200 : gfc_conv_expr_reference (&se, d->low);
3838 : :
3839 : 200 : CONSTRUCTOR_APPEND_ELT (node, ss_string1[k], se.expr);
3840 : 200 : CONSTRUCTOR_APPEND_ELT (node, ss_string1_len[k], se.string_length);
3841 : : }
3842 : :
3843 : 252 : if (d->high == NULL)
3844 : : {
3845 : 52 : CONSTRUCTOR_APPEND_ELT (node, ss_string2[k], null_pointer_node);
3846 : 52 : CONSTRUCTOR_APPEND_ELT (node, ss_string2_len[k], build_zero_cst (gfc_charlen_type_node));
3847 : : }
3848 : : else
3849 : : {
3850 : 200 : gfc_init_se (&se, NULL);
3851 : 200 : gfc_conv_expr_reference (&se, d->high);
3852 : :
3853 : 200 : CONSTRUCTOR_APPEND_ELT (node, ss_string2[k], se.expr);
3854 : 200 : CONSTRUCTOR_APPEND_ELT (node, ss_string2_len[k], se.string_length);
3855 : : }
3856 : :
3857 : 252 : CONSTRUCTOR_APPEND_ELT (node, ss_target[k],
3858 : : build_int_cst (integer_type_node, d->n));
3859 : :
3860 : 252 : tmp = build_constructor (select_struct[k], node);
3861 : 252 : CONSTRUCTOR_APPEND_ELT (inits, NULL_TREE, tmp);
3862 : : }
3863 : :
3864 : 59 : type = build_array_type (select_struct[k],
3865 : 59 : build_index_type (size_int (n-1)));
3866 : :
3867 : 59 : init = build_constructor (type, inits);
3868 : 59 : TREE_CONSTANT (init) = 1;
3869 : 59 : TREE_STATIC (init) = 1;
3870 : : /* Create a static variable to hold the jump table. */
3871 : 59 : tmp = gfc_create_var (type, "jumptable");
3872 : 59 : TREE_CONSTANT (tmp) = 1;
3873 : 59 : TREE_STATIC (tmp) = 1;
3874 : 59 : TREE_READONLY (tmp) = 1;
3875 : 59 : DECL_INITIAL (tmp) = init;
3876 : 59 : init = tmp;
3877 : :
3878 : : /* Build the library call */
3879 : 59 : init = gfc_build_addr_expr (pvoid_type_node, init);
3880 : :
3881 : 59 : if (code->expr1->ts.kind == 1)
3882 : 53 : fndecl = gfor_fndecl_select_string;
3883 : 6 : else if (code->expr1->ts.kind == 4)
3884 : 6 : fndecl = gfor_fndecl_select_string_char4;
3885 : : else
3886 : 0 : gcc_unreachable ();
3887 : :
3888 : 59 : tmp = build_call_expr_loc (input_location,
3889 : : fndecl, 4, init,
3890 : 59 : build_int_cst (gfc_charlen_type_node, n),
3891 : : expr1se.expr, expr1se.string_length);
3892 : 59 : case_num = gfc_create_var (integer_type_node, "case_num");
3893 : 59 : gfc_add_modify (&block, case_num, tmp);
3894 : :
3895 : 59 : gfc_add_block_to_block (&block, &expr1se.post);
3896 : :
3897 : 59 : tmp = gfc_finish_block (&body);
3898 : 59 : tmp = fold_build2_loc (input_location, SWITCH_EXPR, NULL_TREE,
3899 : : case_num, tmp);
3900 : 59 : gfc_add_expr_to_block (&block, tmp);
3901 : :
3902 : 59 : tmp = build1_v (LABEL_EXPR, end_label);
3903 : 59 : gfc_add_expr_to_block (&block, tmp);
3904 : :
3905 : 59 : return gfc_finish_block (&block);
3906 : : }
3907 : :
3908 : :
3909 : : /* Translate the three variants of the SELECT CASE construct.
3910 : :
3911 : : SELECT CASEs with INTEGER case expressions can be translated to an
3912 : : equivalent GENERIC switch statement, and for LOGICAL case
3913 : : expressions we build one or two if-else compares.
3914 : :
3915 : : SELECT CASEs with CHARACTER case expressions are a whole different
3916 : : story, because they don't exist in GENERIC. So we sort them and
3917 : : do a binary search at runtime.
3918 : :
3919 : : Fortran has no BREAK statement, and it does not allow jumps from
3920 : : one case block to another. That makes things a lot easier for
3921 : : the optimizers. */
3922 : :
3923 : : tree
3924 : 1022 : gfc_trans_select (gfc_code * code)
3925 : : {
3926 : 1022 : stmtblock_t block;
3927 : 1022 : tree body;
3928 : 1022 : tree exit_label;
3929 : :
3930 : 1022 : gcc_assert (code && code->expr1);
3931 : 1022 : gfc_init_block (&block);
3932 : :
3933 : : /* Build the exit label and hang it in. */
3934 : 1022 : exit_label = gfc_build_label_decl (NULL_TREE);
3935 : 1022 : code->exit_label = exit_label;
3936 : :
3937 : : /* Empty SELECT constructs are legal. */
3938 : 1022 : if (code->block == NULL)
3939 : 2 : body = build_empty_stmt (input_location);
3940 : :
3941 : : /* Select the correct translation function. */
3942 : : else
3943 : 1020 : switch (code->expr1->ts.type)
3944 : : {
3945 : 54 : case BT_LOGICAL:
3946 : 54 : body = gfc_trans_logical_select (code);
3947 : 54 : break;
3948 : :
3949 : 891 : case BT_INTEGER:
3950 : 891 : case BT_UNSIGNED:
3951 : 891 : body = gfc_trans_integer_select (code);
3952 : 891 : break;
3953 : :
3954 : 75 : case BT_CHARACTER:
3955 : 75 : body = gfc_trans_character_select (code);
3956 : 75 : break;
3957 : :
3958 : 0 : default:
3959 : 0 : gfc_internal_error ("gfc_trans_select(): Bad type for case expr.");
3960 : : /* Not reached */
3961 : : }
3962 : :
3963 : : /* Build everything together. */
3964 : 1022 : gfc_add_expr_to_block (&block, body);
3965 : 1022 : gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, exit_label));
3966 : :
3967 : 1022 : return gfc_finish_block (&block);
3968 : : }
3969 : :
3970 : : tree
3971 : 2858 : gfc_trans_select_type (gfc_code * code)
3972 : : {
3973 : 2858 : stmtblock_t block;
3974 : 2858 : tree body;
3975 : 2858 : tree exit_label;
3976 : :
3977 : 2858 : gcc_assert (code && code->expr1);
3978 : 2858 : gfc_init_block (&block);
3979 : :
3980 : : /* Build the exit label and hang it in. */
3981 : 2858 : exit_label = gfc_build_label_decl (NULL_TREE);
3982 : 2858 : code->exit_label = exit_label;
3983 : :
3984 : : /* Empty SELECT constructs are legal. */
3985 : 2858 : if (code->block == NULL)
3986 : 0 : body = build_empty_stmt (input_location);
3987 : : else
3988 : 2858 : body = gfc_trans_select_type_cases (code);
3989 : :
3990 : : /* Build everything together. */
3991 : 2858 : gfc_add_expr_to_block (&block, body);
3992 : :
3993 : 2858 : if (TREE_USED (exit_label))
3994 : 2657 : gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, exit_label));
3995 : :
3996 : 2858 : return gfc_finish_block (&block);
3997 : : }
3998 : :
3999 : :
4000 : : static tree
4001 : 1000 : gfc_trans_select_rank_cases (gfc_code * code)
4002 : : {
4003 : 1000 : gfc_code *c;
4004 : 1000 : gfc_case *cp;
4005 : 1000 : tree tmp;
4006 : 1000 : tree cond;
4007 : 1000 : tree low;
4008 : 1000 : tree rank;
4009 : 1000 : gfc_se se;
4010 : 1000 : gfc_se cse;
4011 : 1000 : stmtblock_t block;
4012 : 1000 : stmtblock_t body;
4013 : 1000 : bool def = false;
4014 : :
4015 : 1000 : gfc_start_block (&block);
4016 : :
4017 : : /* Calculate the switch expression. */
4018 : 1000 : gfc_init_se (&se, NULL);
4019 : 1000 : gfc_conv_expr_descriptor (&se, code->expr1);
4020 : 1000 : rank = gfc_conv_descriptor_rank (se.expr);
4021 : 1000 : rank = gfc_evaluate_now (rank, &block);
4022 : 1000 : symbol_attribute attr = gfc_expr_attr (code->expr1);
4023 : 1000 : if (!attr.pointer && !attr.allocatable)
4024 : : {
4025 : : /* Special case for assumed-rank ('rank(*)', internally -1):
4026 : : rank = (rank == 0 || ubound[rank-1] != -1) ? rank : -1. */
4027 : 766 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
4028 : 766 : rank, build_int_cst (TREE_TYPE (rank), 0));
4029 : 766 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4030 : : fold_convert (gfc_array_index_type, rank),
4031 : : gfc_index_one_node);
4032 : 766 : tmp = gfc_conv_descriptor_ubound_get (se.expr, tmp);
4033 : 766 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
4034 : 766 : tmp, build_int_cst (TREE_TYPE (tmp), -1));
4035 : 766 : cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
4036 : : logical_type_node, cond, tmp);
4037 : 766 : tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (rank),
4038 : 766 : cond, rank, build_int_cst (TREE_TYPE (rank), -1));
4039 : 766 : rank = gfc_evaluate_now (tmp, &block);
4040 : : }
4041 : 1000 : TREE_USED (code->exit_label) = 0;
4042 : :
4043 : 2000 : repeat:
4044 : 6554 : for (c = code->block; c; c = c->block)
4045 : : {
4046 : 4554 : cp = c->ext.block.case_list;
4047 : :
4048 : : /* Assume it's the default case. */
4049 : 4554 : low = NULL_TREE;
4050 : 4554 : tmp = NULL_TREE;
4051 : :
4052 : : /* Put the default case at the end. */
4053 : 4554 : if ((!def && !cp->low) || (def && cp->low))
4054 : 2277 : continue;
4055 : :
4056 : 2277 : if (cp->low)
4057 : : {
4058 : 1362 : gfc_init_se (&cse, NULL);
4059 : 1362 : gfc_conv_expr_val (&cse, cp->low);
4060 : 1362 : gfc_add_block_to_block (&block, &cse.pre);
4061 : 1362 : low = cse.expr;
4062 : : }
4063 : :
4064 : 2277 : gfc_init_block (&body);
4065 : :
4066 : : /* Add the statements for this case. */
4067 : 2277 : tmp = gfc_trans_code (c->next);
4068 : 2277 : gfc_add_expr_to_block (&body, tmp);
4069 : :
4070 : : /* Break to the end of the SELECT RANK construct. The default
4071 : : case just falls through. */
4072 : 2277 : if (!def)
4073 : : {
4074 : 1362 : TREE_USED (code->exit_label) = 1;
4075 : 1362 : tmp = build1_v (GOTO_EXPR, code->exit_label);
4076 : 1362 : gfc_add_expr_to_block (&body, tmp);
4077 : : }
4078 : :
4079 : 2277 : tmp = gfc_finish_block (&body);
4080 : :
4081 : 2277 : if (low != NULL_TREE)
4082 : : {
4083 : 2724 : cond = fold_build2_loc (input_location, EQ_EXPR,
4084 : 1362 : TREE_TYPE (rank), rank,
4085 : 1362 : fold_convert (TREE_TYPE (rank), low));
4086 : 1362 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
4087 : : cond, tmp,
4088 : : build_empty_stmt (input_location));
4089 : : }
4090 : :
4091 : 2277 : gfc_add_expr_to_block (&block, tmp);
4092 : : }
4093 : :
4094 : 2000 : if (!def)
4095 : : {
4096 : 1000 : def = true;
4097 : 1000 : goto repeat;
4098 : : }
4099 : :
4100 : 1000 : return gfc_finish_block (&block);
4101 : : }
4102 : :
4103 : :
4104 : : tree
4105 : 1001 : gfc_trans_select_rank (gfc_code * code)
4106 : : {
4107 : 1001 : stmtblock_t block;
4108 : 1001 : tree body;
4109 : 1001 : tree exit_label;
4110 : :
4111 : 1001 : gcc_assert (code && code->expr1);
4112 : 1001 : gfc_init_block (&block);
4113 : :
4114 : : /* Build the exit label and hang it in. */
4115 : 1001 : exit_label = gfc_build_label_decl (NULL_TREE);
4116 : 1001 : code->exit_label = exit_label;
4117 : :
4118 : : /* Empty SELECT constructs are legal. */
4119 : 1001 : if (code->block == NULL)
4120 : 1 : body = build_empty_stmt (input_location);
4121 : : else
4122 : 1000 : body = gfc_trans_select_rank_cases (code);
4123 : :
4124 : : /* Build everything together. */
4125 : 1001 : gfc_add_expr_to_block (&block, body);
4126 : :
4127 : 1001 : if (TREE_USED (exit_label))
4128 : 1001 : gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, exit_label));
4129 : :
4130 : 1001 : return gfc_finish_block (&block);
4131 : : }
4132 : :
4133 : :
4134 : : /* Traversal function to substitute a replacement symtree if the symbol
4135 : : in the expression is the same as that passed. f == 2 signals that
4136 : : that variable itself is not to be checked - only the references.
4137 : : This group of functions is used when the variable expression in a
4138 : : FORALL assignment has internal references. For example:
4139 : : FORALL (i = 1:4) p(p(i)) = i
4140 : : The only recourse here is to store a copy of 'p' for the index
4141 : : expression. */
4142 : :
4143 : : static gfc_symtree *new_symtree;
4144 : : static gfc_symtree *old_symtree;
4145 : :
4146 : : static bool
4147 : 710 : forall_replace (gfc_expr *expr, gfc_symbol *sym, int *f)
4148 : : {
4149 : 710 : if (expr->expr_type != EXPR_VARIABLE)
4150 : : return false;
4151 : :
4152 : 406 : if (*f == 2)
4153 : 62 : *f = 1;
4154 : 344 : else if (expr->symtree->n.sym == sym)
4155 : 72 : expr->symtree = new_symtree;
4156 : :
4157 : : return false;
4158 : : }
4159 : :
4160 : : static void
4161 : 124 : forall_replace_symtree (gfc_expr *e, gfc_symbol *sym, int f)
4162 : : {
4163 : 0 : gfc_traverse_expr (e, sym, forall_replace, f);
4164 : 0 : }
4165 : :
4166 : : static bool
4167 : 710 : forall_restore (gfc_expr *expr,
4168 : : gfc_symbol *sym ATTRIBUTE_UNUSED,
4169 : : int *f ATTRIBUTE_UNUSED)
4170 : : {
4171 : 710 : if (expr->expr_type != EXPR_VARIABLE)
4172 : : return false;
4173 : :
4174 : 406 : if (expr->symtree == new_symtree)
4175 : 72 : expr->symtree = old_symtree;
4176 : :
4177 : : return false;
4178 : : }
4179 : :
4180 : : static void
4181 : 124 : forall_restore_symtree (gfc_expr *e)
4182 : : {
4183 : 0 : gfc_traverse_expr (e, NULL, forall_restore, 0);
4184 : 0 : }
4185 : :
4186 : : static void
4187 : 62 : forall_make_variable_temp (gfc_code *c, stmtblock_t *pre, stmtblock_t *post)
4188 : : {
4189 : 62 : gfc_se tse;
4190 : 62 : gfc_se rse;
4191 : 62 : gfc_expr *e;
4192 : 62 : gfc_symbol *new_sym;
4193 : 62 : gfc_symbol *old_sym;
4194 : 62 : gfc_symtree *root;
4195 : 62 : tree tmp;
4196 : :
4197 : : /* Build a copy of the lvalue. */
4198 : 62 : old_symtree = c->expr1->symtree;
4199 : 62 : old_sym = old_symtree->n.sym;
4200 : 62 : e = gfc_lval_expr_from_sym (old_sym);
4201 : 62 : if (old_sym->attr.dimension)
4202 : : {
4203 : 30 : gfc_init_se (&tse, NULL);
4204 : 30 : gfc_conv_subref_array_arg (&tse, e, 0, INTENT_IN, false);
4205 : 30 : gfc_add_block_to_block (pre, &tse.pre);
4206 : 30 : gfc_add_block_to_block (post, &tse.post);
4207 : 30 : tse.expr = build_fold_indirect_ref_loc (input_location, tse.expr);
4208 : :
4209 : 30 : if (c->expr1->ref->u.ar.type != AR_SECTION)
4210 : : {
4211 : : /* Use the variable offset for the temporary. */
4212 : 24 : tmp = gfc_conv_array_offset (old_sym->backend_decl);
4213 : 24 : gfc_conv_descriptor_offset_set (pre, tse.expr, tmp);
4214 : : }
4215 : : }
4216 : : else
4217 : : {
4218 : 32 : gfc_init_se (&tse, NULL);
4219 : 32 : gfc_init_se (&rse, NULL);
4220 : 32 : gfc_conv_expr (&rse, e);
4221 : 32 : if (e->ts.type == BT_CHARACTER)
4222 : : {
4223 : 32 : tse.string_length = rse.string_length;
4224 : 32 : tmp = gfc_get_character_type_len (gfc_default_character_kind,
4225 : : tse.string_length);
4226 : 32 : tse.expr = gfc_conv_string_tmp (&tse, build_pointer_type (tmp),
4227 : : rse.string_length);
4228 : 32 : gfc_add_block_to_block (pre, &tse.pre);
4229 : 32 : gfc_add_block_to_block (post, &tse.post);
4230 : : }
4231 : : else
4232 : : {
4233 : 0 : tmp = gfc_typenode_for_spec (&e->ts);
4234 : 0 : tse.expr = gfc_create_var (tmp, "temp");
4235 : : }
4236 : :
4237 : 64 : tmp = gfc_trans_scalar_assign (&tse, &rse, e->ts,
4238 : 32 : e->expr_type == EXPR_VARIABLE, false);
4239 : 32 : gfc_add_expr_to_block (pre, tmp);
4240 : : }
4241 : 62 : gfc_free_expr (e);
4242 : :
4243 : : /* Create a new symbol to represent the lvalue. */
4244 : 62 : new_sym = gfc_new_symbol (old_sym->name, NULL);
4245 : 62 : new_sym->ts = old_sym->ts;
4246 : 62 : new_sym->attr.referenced = 1;
4247 : 62 : new_sym->attr.temporary = 1;
4248 : 62 : new_sym->attr.dimension = old_sym->attr.dimension;
4249 : 62 : new_sym->attr.flavor = old_sym->attr.flavor;
4250 : :
4251 : : /* Use the temporary as the backend_decl. */
4252 : 62 : new_sym->backend_decl = tse.expr;
4253 : :
4254 : : /* Create a fake symtree for it. */
4255 : 62 : root = NULL;
4256 : 62 : new_symtree = gfc_new_symtree (&root, old_sym->name);
4257 : 62 : new_symtree->n.sym = new_sym;
4258 : 62 : gcc_assert (new_symtree == root);
4259 : :
4260 : : /* Go through the expression reference replacing the old_symtree
4261 : : with the new. */
4262 : 62 : forall_replace_symtree (c->expr1, old_sym, 2);
4263 : :
4264 : : /* Now we have made this temporary, we might as well use it for
4265 : : the right hand side. */
4266 : 62 : forall_replace_symtree (c->expr2, old_sym, 1);
4267 : 62 : }
4268 : :
4269 : :
4270 : : /* Handles dependencies in forall assignments. */
4271 : : static int
4272 : 1825 : check_forall_dependencies (gfc_code *c, stmtblock_t *pre, stmtblock_t *post)
4273 : : {
4274 : 1825 : gfc_ref *lref;
4275 : 1825 : gfc_ref *rref;
4276 : 1825 : int need_temp;
4277 : 1825 : gfc_symbol *lsym;
4278 : :
4279 : 1825 : lsym = c->expr1->symtree->n.sym;
4280 : 1825 : need_temp = gfc_check_dependency (c->expr1, c->expr2, 0);
4281 : :
4282 : : /* Now check for dependencies within the 'variable'
4283 : : expression itself. These are treated by making a complete
4284 : : copy of variable and changing all the references to it
4285 : : point to the copy instead. Note that the shallow copy of
4286 : : the variable will not suffice for derived types with
4287 : : pointer components. We therefore leave these to their
4288 : : own devices. Likewise for allocatable components. */
4289 : 1825 : if (lsym->ts.type == BT_DERIVED
4290 : 149 : && (lsym->ts.u.derived->attr.pointer_comp
4291 : 139 : || lsym->ts.u.derived->attr.alloc_comp))
4292 : : return need_temp;
4293 : :
4294 : 1730 : new_symtree = NULL;
4295 : 1730 : if (find_forall_index (c->expr1, lsym, 2))
4296 : : {
4297 : 12 : forall_make_variable_temp (c, pre, post);
4298 : 12 : need_temp = 0;
4299 : : }
4300 : :
4301 : : /* Substrings with dependencies are treated in the same
4302 : : way. */
4303 : 1730 : if (c->expr1->ts.type == BT_CHARACTER
4304 : 685 : && c->expr1->ref
4305 : 685 : && c->expr2->expr_type == EXPR_VARIABLE
4306 : 492 : && lsym == c->expr2->symtree->n.sym)
4307 : : {
4308 : 124 : for (lref = c->expr1->ref; lref; lref = lref->next)
4309 : 117 : if (lref->type == REF_SUBSTRING)
4310 : : break;
4311 : 124 : for (rref = c->expr2->ref; rref; rref = rref->next)
4312 : 117 : if (rref->type == REF_SUBSTRING)
4313 : : break;
4314 : :
4315 : 81 : if (rref && lref
4316 : 81 : && gfc_dep_compare_expr (rref->u.ss.start, lref->u.ss.start) < 0)
4317 : : {
4318 : 50 : forall_make_variable_temp (c, pre, post);
4319 : 50 : need_temp = 0;
4320 : : }
4321 : : }
4322 : : return need_temp;
4323 : : }
4324 : :
4325 : :
4326 : : static void
4327 : 62 : cleanup_forall_symtrees (gfc_code *c)
4328 : : {
4329 : 62 : forall_restore_symtree (c->expr1);
4330 : 62 : forall_restore_symtree (c->expr2);
4331 : 62 : free (new_symtree->n.sym);
4332 : 62 : free (new_symtree);
4333 : 62 : }
4334 : :
4335 : :
4336 : : /* Generate the loops for a FORALL block, specified by FORALL_TMP. BODY
4337 : : is the contents of the FORALL block/stmt to be iterated. MASK_FLAG
4338 : : indicates whether we should generate code to test the FORALLs mask
4339 : : array. OUTER is the loop header to be used for initializing mask
4340 : : indices.
4341 : :
4342 : : The generated loop format is:
4343 : : count = (end - start + step) / step
4344 : : loopvar = start
4345 : : while (1)
4346 : : {
4347 : : if (count <=0 )
4348 : : goto end_of_loop
4349 : : <body>
4350 : : loopvar += step
4351 : : count --
4352 : : }
4353 : : end_of_loop: */
4354 : :
4355 : : static tree
4356 : 3517 : gfc_trans_forall_loop (forall_info *forall_tmp, tree body,
4357 : : int mask_flag, stmtblock_t *outer)
4358 : : {
4359 : 3517 : int n, nvar;
4360 : 3517 : tree tmp;
4361 : 3517 : tree cond;
4362 : 3517 : stmtblock_t block;
4363 : 3517 : tree exit_label;
4364 : 3517 : tree count;
4365 : 3517 : tree var, start, end, step;
4366 : 3517 : iter_info *iter;
4367 : :
4368 : : /* Initialize the mask index outside the FORALL nest. */
4369 : 3517 : if (mask_flag && forall_tmp->mask)
4370 : 1067 : gfc_add_modify (outer, forall_tmp->maskindex, gfc_index_zero_node);
4371 : :
4372 : 3517 : iter = forall_tmp->this_loop;
4373 : 3517 : nvar = forall_tmp->nvar;
4374 : 9709 : for (n = 0; n < nvar; n++)
4375 : : {
4376 : 6192 : var = iter->var;
4377 : 6192 : start = iter->start;
4378 : 6192 : end = iter->end;
4379 : 6192 : step = iter->step;
4380 : :
4381 : 6192 : exit_label = gfc_build_label_decl (NULL_TREE);
4382 : 6192 : TREE_USED (exit_label) = 1;
4383 : :
4384 : : /* The loop counter. */
4385 : 6192 : count = gfc_create_var (TREE_TYPE (var), "count");
4386 : :
4387 : : /* The body of the loop. */
4388 : 6192 : gfc_init_block (&block);
4389 : :
4390 : : /* The exit condition. */
4391 : 6192 : cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
4392 : 6192 : count, build_int_cst (TREE_TYPE (count), 0));
4393 : :
4394 : : /* PR 83064 means that we cannot use annot_expr_parallel_kind until
4395 : : the autoparallelizer can handle this. */
4396 : 6192 : if (forall_tmp->do_concurrent || iter->annot.ivdep)
4397 : 155 : cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond,
4398 : : build_int_cst (integer_type_node,
4399 : : annot_expr_ivdep_kind),
4400 : : integer_zero_node);
4401 : :
4402 : 6192 : if (iter->annot.unroll && cond != error_mark_node)
4403 : 1 : cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond,
4404 : : build_int_cst (integer_type_node,
4405 : : annot_expr_unroll_kind),
4406 : 1 : build_int_cst (integer_type_node, iter->annot.unroll));
4407 : :
4408 : 6192 : if (iter->annot.vector && cond != error_mark_node)
4409 : 1 : cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond,
4410 : : build_int_cst (integer_type_node,
4411 : : annot_expr_vector_kind),
4412 : : integer_zero_node);
4413 : :
4414 : 6192 : if (iter->annot.novector && cond != error_mark_node)
4415 : 2 : cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond,
4416 : : build_int_cst (integer_type_node,
4417 : : annot_expr_no_vector_kind),
4418 : : integer_zero_node);
4419 : :
4420 : 6192 : tmp = build1_v (GOTO_EXPR, exit_label);
4421 : 6192 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
4422 : : cond, tmp, build_empty_stmt (input_location));
4423 : 6192 : gfc_add_expr_to_block (&block, tmp);
4424 : :
4425 : : /* The main loop body. */
4426 : 6192 : gfc_add_expr_to_block (&block, body);
4427 : :
4428 : : /* Increment the loop variable. */
4429 : 6192 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), var,
4430 : : step);
4431 : 6192 : gfc_add_modify (&block, var, tmp);
4432 : :
4433 : : /* Advance to the next mask element. Only do this for the
4434 : : innermost loop. */
4435 : 6192 : if (n == 0 && mask_flag && forall_tmp->mask)
4436 : : {
4437 : 1067 : tree maskindex = forall_tmp->maskindex;
4438 : 1067 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4439 : : maskindex, gfc_index_one_node);
4440 : 1067 : gfc_add_modify (&block, maskindex, tmp);
4441 : : }
4442 : :
4443 : : /* Decrement the loop counter. */
4444 : 6192 : tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (var), count,
4445 : 6192 : build_int_cst (TREE_TYPE (var), 1));
4446 : 6192 : gfc_add_modify (&block, count, tmp);
4447 : :
4448 : 6192 : body = gfc_finish_block (&block);
4449 : :
4450 : : /* Loop var initialization. */
4451 : 6192 : gfc_init_block (&block);
4452 : 6192 : gfc_add_modify (&block, var, start);
4453 : :
4454 : :
4455 : : /* Initialize the loop counter. */
4456 : 6192 : tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (var), step,
4457 : : start);
4458 : 6192 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), end,
4459 : : tmp);
4460 : 6192 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, TREE_TYPE (var),
4461 : : tmp, step);
4462 : 6192 : gfc_add_modify (&block, count, tmp);
4463 : :
4464 : : /* The loop expression. */
4465 : 6192 : tmp = build1_v (LOOP_EXPR, body);
4466 : 6192 : gfc_add_expr_to_block (&block, tmp);
4467 : :
4468 : : /* The exit label. */
4469 : 6192 : tmp = build1_v (LABEL_EXPR, exit_label);
4470 : 6192 : gfc_add_expr_to_block (&block, tmp);
4471 : :
4472 : 6192 : body = gfc_finish_block (&block);
4473 : 6192 : iter = iter->next;
4474 : : }
4475 : 3517 : return body;
4476 : : }
4477 : :
4478 : :
4479 : : /* Generate the body and loops according to MASK_FLAG. If MASK_FLAG
4480 : : is nonzero, the body is controlled by all masks in the forall nest.
4481 : : Otherwise, the innermost loop is not controlled by it's mask. This
4482 : : is used for initializing that mask. */
4483 : :
4484 : : static tree
4485 : 3317 : gfc_trans_nested_forall_loop (forall_info * nested_forall_info, tree body,
4486 : : int mask_flag)
4487 : : {
4488 : 3317 : tree tmp;
4489 : 3317 : stmtblock_t header;
4490 : 3317 : forall_info *forall_tmp;
4491 : 3317 : tree mask, maskindex;
4492 : :
4493 : 3317 : gfc_start_block (&header);
4494 : :
4495 : 3317 : forall_tmp = nested_forall_info;
4496 : 10151 : while (forall_tmp != NULL)
4497 : : {
4498 : : /* Generate body with masks' control. */
4499 : 3517 : if (mask_flag)
4500 : : {
4501 : 2794 : mask = forall_tmp->mask;
4502 : 2794 : maskindex = forall_tmp->maskindex;
4503 : :
4504 : : /* If a mask was specified make the assignment conditional. */
4505 : 2794 : if (mask)
4506 : : {
4507 : 1067 : tmp = gfc_build_array_ref (mask, maskindex, NULL);
4508 : 1067 : body = build3_v (COND_EXPR, tmp, body,
4509 : : build_empty_stmt (input_location));
4510 : : }
4511 : : }
4512 : 3517 : body = gfc_trans_forall_loop (forall_tmp, body, mask_flag, &header);
4513 : 3517 : forall_tmp = forall_tmp->prev_nest;
4514 : 3517 : mask_flag = 1;
4515 : : }
4516 : :
4517 : 3317 : gfc_add_expr_to_block (&header, body);
4518 : 3317 : return gfc_finish_block (&header);
4519 : : }
4520 : :
4521 : :
4522 : : /* Allocate data for holding a temporary array. Returns either a local
4523 : : temporary array or a pointer variable. */
4524 : :
4525 : : static tree
4526 : 1381 : gfc_do_allocate (tree bytesize, tree size, tree * pdata, stmtblock_t * pblock,
4527 : : tree elem_type)
4528 : : {
4529 : 1381 : tree tmpvar;
4530 : 1381 : tree type;
4531 : 1381 : tree tmp;
4532 : :
4533 : 1381 : if (INTEGER_CST_P (size))
4534 : 1139 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4535 : : size, gfc_index_one_node);
4536 : : else
4537 : : tmp = NULL_TREE;
4538 : :
4539 : 1381 : type = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
4540 : 1381 : type = build_array_type (elem_type, type);
4541 : 1381 : if (gfc_can_put_var_on_stack (bytesize) && INTEGER_CST_P (size))
4542 : : {
4543 : 1139 : tmpvar = gfc_create_var (type, "temp");
4544 : 1139 : *pdata = NULL_TREE;
4545 : : }
4546 : : else
4547 : : {
4548 : 242 : tmpvar = gfc_create_var (build_pointer_type (type), "temp");
4549 : 242 : *pdata = convert (pvoid_type_node, tmpvar);
4550 : :
4551 : 242 : tmp = gfc_call_malloc (pblock, TREE_TYPE (tmpvar), bytesize);
4552 : 242 : gfc_add_modify (pblock, tmpvar, tmp);
4553 : : }
4554 : 1381 : return tmpvar;
4555 : : }
4556 : :
4557 : :
4558 : : /* Generate codes to copy the temporary to the actual lhs. */
4559 : :
4560 : : static tree
4561 : 224 : generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree count3,
4562 : : tree count1,
4563 : : gfc_ss *lss, gfc_ss *rss,
4564 : : tree wheremask, bool invert)
4565 : : {
4566 : 224 : stmtblock_t block, body1;
4567 : 224 : gfc_loopinfo loop;
4568 : 224 : gfc_se lse;
4569 : 224 : gfc_se rse;
4570 : 224 : tree tmp;
4571 : 224 : tree wheremaskexpr;
4572 : :
4573 : 224 : (void) rss; /* TODO: unused. */
4574 : :
4575 : 224 : gfc_start_block (&block);
4576 : :
4577 : 224 : gfc_init_se (&rse, NULL);
4578 : 224 : gfc_init_se (&lse, NULL);
4579 : :
4580 : 224 : if (lss == gfc_ss_terminator)
4581 : : {
4582 : 149 : gfc_init_block (&body1);
4583 : 149 : gfc_conv_expr (&lse, expr);
4584 : 149 : rse.expr = gfc_build_array_ref (tmp1, count1, NULL);
4585 : : }
4586 : : else
4587 : : {
4588 : : /* Initialize the loop. */
4589 : 75 : gfc_init_loopinfo (&loop);
4590 : :
4591 : : /* We may need LSS to determine the shape of the expression. */
4592 : 75 : gfc_add_ss_to_loop (&loop, lss);
4593 : :
4594 : 75 : gfc_conv_ss_startstride (&loop);
4595 : 75 : gfc_conv_loop_setup (&loop, &expr->where);
4596 : :
4597 : 75 : gfc_mark_ss_chain_used (lss, 1);
4598 : : /* Start the loop body. */
4599 : 75 : gfc_start_scalarized_body (&loop, &body1);
4600 : :
4601 : : /* Translate the expression. */
4602 : 75 : gfc_copy_loopinfo_to_se (&lse, &loop);
4603 : 75 : lse.ss = lss;
4604 : 75 : gfc_conv_expr (&lse, expr);
4605 : :
4606 : : /* Form the expression of the temporary. */
4607 : 75 : rse.expr = gfc_build_array_ref (tmp1, count1, NULL);
4608 : : }
4609 : :
4610 : : /* Use the scalar assignment. */
4611 : 224 : rse.string_length = lse.string_length;
4612 : 448 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts,
4613 : 224 : expr->expr_type == EXPR_VARIABLE, false);
4614 : :
4615 : : /* Form the mask expression according to the mask tree list. */
4616 : 224 : if (wheremask)
4617 : : {
4618 : 27 : wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL);
4619 : 27 : if (invert)
4620 : 0 : wheremaskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
4621 : 0 : TREE_TYPE (wheremaskexpr),
4622 : : wheremaskexpr);
4623 : 27 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
4624 : : wheremaskexpr, tmp,
4625 : : build_empty_stmt (input_location));
4626 : : }
4627 : :
4628 : 224 : gfc_add_expr_to_block (&body1, tmp);
4629 : :
4630 : 224 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (count1),
4631 : : count1, gfc_index_one_node);
4632 : 224 : gfc_add_modify (&body1, count1, tmp);
4633 : :
4634 : 224 : if (lss == gfc_ss_terminator)
4635 : 149 : gfc_add_block_to_block (&block, &body1);
4636 : : else
4637 : : {
4638 : : /* Increment count3. */
4639 : 75 : if (count3)
4640 : : {
4641 : 27 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
4642 : : gfc_array_index_type,
4643 : : count3, gfc_index_one_node);
4644 : 27 : gfc_add_modify (&body1, count3, tmp);
4645 : : }
4646 : :
4647 : : /* Generate the copying loops. */
4648 : 75 : gfc_trans_scalarizing_loops (&loop, &body1);
4649 : :
4650 : 75 : gfc_add_block_to_block (&block, &loop.pre);
4651 : 75 : gfc_add_block_to_block (&block, &loop.post);
4652 : :
4653 : 75 : gfc_cleanup_loop (&loop);
4654 : : /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
4655 : : as tree nodes in SS may not be valid in different scope. */
4656 : : }
4657 : :
4658 : 224 : tmp = gfc_finish_block (&block);
4659 : 224 : return tmp;
4660 : : }
4661 : :
4662 : :
4663 : : /* Generate codes to copy rhs to the temporary. TMP1 is the address of
4664 : : temporary, LSS and RSS are formed in function compute_inner_temp_size(),
4665 : : and should not be freed. WHEREMASK is the conditional execution mask
4666 : : whose sense may be inverted by INVERT. */
4667 : :
4668 : : static tree
4669 : 224 : generate_loop_for_rhs_to_temp (gfc_expr *expr2, tree tmp1, tree count3,
4670 : : tree count1, gfc_ss *lss, gfc_ss *rss,
4671 : : tree wheremask, bool invert)
4672 : : {
4673 : 224 : stmtblock_t block, body1;
4674 : 224 : gfc_loopinfo loop;
4675 : 224 : gfc_se lse;
4676 : 224 : gfc_se rse;
4677 : 224 : tree tmp;
4678 : 224 : tree wheremaskexpr;
4679 : :
4680 : 224 : gfc_start_block (&block);
4681 : :
4682 : 224 : gfc_init_se (&rse, NULL);
4683 : 224 : gfc_init_se (&lse, NULL);
4684 : :
4685 : 224 : if (lss == gfc_ss_terminator)
4686 : : {
4687 : 149 : gfc_init_block (&body1);
4688 : 149 : gfc_conv_expr (&rse, expr2);
4689 : 149 : lse.expr = gfc_build_array_ref (tmp1, count1, NULL);
4690 : : }
4691 : : else
4692 : : {
4693 : : /* Initialize the loop. */
4694 : 75 : gfc_init_loopinfo (&loop);
4695 : :
4696 : : /* We may need LSS to determine the shape of the expression. */
4697 : 75 : gfc_add_ss_to_loop (&loop, lss);
4698 : 75 : gfc_add_ss_to_loop (&loop, rss);
4699 : :
4700 : 75 : gfc_conv_ss_startstride (&loop);
4701 : 75 : gfc_conv_loop_setup (&loop, &expr2->where);
4702 : :
4703 : 75 : gfc_mark_ss_chain_used (rss, 1);
4704 : : /* Start the loop body. */
4705 : 75 : gfc_start_scalarized_body (&loop, &body1);
4706 : :
4707 : : /* Translate the expression. */
4708 : 75 : gfc_copy_loopinfo_to_se (&rse, &loop);
4709 : 75 : rse.ss = rss;
4710 : 75 : gfc_conv_expr (&rse, expr2);
4711 : :
4712 : : /* Form the expression of the temporary. */
4713 : 75 : lse.expr = gfc_build_array_ref (tmp1, count1, NULL);
4714 : : }
4715 : :
4716 : : /* Use the scalar assignment. */
4717 : 224 : lse.string_length = rse.string_length;
4718 : 448 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts,
4719 : 224 : expr2->expr_type == EXPR_VARIABLE, false);
4720 : :
4721 : : /* Form the mask expression according to the mask tree list. */
4722 : 224 : if (wheremask)
4723 : : {
4724 : 27 : wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL);
4725 : 27 : if (invert)
4726 : 0 : wheremaskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
4727 : 0 : TREE_TYPE (wheremaskexpr),
4728 : : wheremaskexpr);
4729 : 27 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
4730 : : wheremaskexpr, tmp,
4731 : : build_empty_stmt (input_location));
4732 : : }
4733 : :
4734 : 224 : gfc_add_expr_to_block (&body1, tmp);
4735 : :
4736 : 224 : if (lss == gfc_ss_terminator)
4737 : : {
4738 : 149 : gfc_add_block_to_block (&block, &body1);
4739 : :
4740 : : /* Increment count1. */
4741 : 149 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (count1),
4742 : : count1, gfc_index_one_node);
4743 : 149 : gfc_add_modify (&block, count1, tmp);
4744 : : }
4745 : : else
4746 : : {
4747 : : /* Increment count1. */
4748 : 75 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4749 : : count1, gfc_index_one_node);
4750 : 75 : gfc_add_modify (&body1, count1, tmp);
4751 : :
4752 : : /* Increment count3. */
4753 : 75 : if (count3)
4754 : : {
4755 : 27 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
4756 : : gfc_array_index_type,
4757 : : count3, gfc_index_one_node);
4758 : 27 : gfc_add_modify (&body1, count3, tmp);
4759 : : }
4760 : :
4761 : : /* Generate the copying loops. */
4762 : 75 : gfc_trans_scalarizing_loops (&loop, &body1);
4763 : :
4764 : 75 : gfc_add_block_to_block (&block, &loop.pre);
4765 : 75 : gfc_add_block_to_block (&block, &loop.post);
4766 : :
4767 : 75 : gfc_cleanup_loop (&loop);
4768 : : /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
4769 : : as tree nodes in SS may not be valid in different scope. */
4770 : : }
4771 : :
4772 : 224 : tmp = gfc_finish_block (&block);
4773 : 224 : return tmp;
4774 : : }
4775 : :
4776 : :
4777 : : /* Calculate the size of temporary needed in the assignment inside forall.
4778 : : LSS and RSS are filled in this function. */
4779 : :
4780 : : static tree
4781 : 779 : compute_inner_temp_size (gfc_expr *expr1, gfc_expr *expr2,
4782 : : stmtblock_t * pblock,
4783 : : gfc_ss **lss, gfc_ss **rss)
4784 : : {
4785 : 779 : gfc_loopinfo loop;
4786 : 779 : tree size;
4787 : 779 : int i;
4788 : 779 : int save_flag;
4789 : 779 : tree tmp;
4790 : :
4791 : 779 : *lss = gfc_walk_expr (expr1);
4792 : 779 : *rss = NULL;
4793 : :
4794 : 779 : size = gfc_index_one_node;
4795 : 779 : if (*lss != gfc_ss_terminator)
4796 : : {
4797 : 481 : gfc_init_loopinfo (&loop);
4798 : :
4799 : : /* Walk the RHS of the expression. */
4800 : 481 : *rss = gfc_walk_expr (expr2);
4801 : 481 : if (*rss == gfc_ss_terminator)
4802 : : /* The rhs is scalar. Add a ss for the expression. */
4803 : 0 : *rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
4804 : :
4805 : : /* Associate the SS with the loop. */
4806 : 481 : gfc_add_ss_to_loop (&loop, *lss);
4807 : : /* We don't actually need to add the rhs at this point, but it might
4808 : : make guessing the loop bounds a bit easier. */
4809 : 481 : gfc_add_ss_to_loop (&loop, *rss);
4810 : :
4811 : : /* We only want the shape of the expression, not rest of the junk
4812 : : generated by the scalarizer. */
4813 : 481 : loop.array_parameter = 1;
4814 : :
4815 : : /* Calculate the bounds of the scalarization. */
4816 : 481 : save_flag = gfc_option.rtcheck;
4817 : 481 : gfc_option.rtcheck &= ~GFC_RTCHECK_BOUNDS;
4818 : 481 : gfc_conv_ss_startstride (&loop);
4819 : 481 : gfc_option.rtcheck = save_flag;
4820 : 481 : gfc_conv_loop_setup (&loop, &expr2->where);
4821 : :
4822 : : /* Figure out how many elements we need. */
4823 : 1473 : for (i = 0; i < loop.dimen; i++)
4824 : : {
4825 : 511 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
4826 : : gfc_array_index_type,
4827 : : gfc_index_one_node, loop.from[i]);
4828 : 511 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
4829 : : gfc_array_index_type, tmp, loop.to[i]);
4830 : 511 : size = fold_build2_loc (input_location, MULT_EXPR,
4831 : : gfc_array_index_type, size, tmp);
4832 : : }
4833 : 481 : gfc_add_block_to_block (pblock, &loop.pre);
4834 : 481 : size = gfc_evaluate_now (size, pblock);
4835 : 481 : gfc_add_block_to_block (pblock, &loop.post);
4836 : :
4837 : : /* TODO: write a function that cleans up a loopinfo without freeing
4838 : : the SS chains. Currently a NOP. */
4839 : : }
4840 : :
4841 : 779 : return size;
4842 : : }
4843 : :
4844 : :
4845 : : /* Calculate the overall iterator number of the nested forall construct.
4846 : : This routine actually calculates the number of times the body of the
4847 : : nested forall specified by NESTED_FORALL_INFO is executed and multiplies
4848 : : that by the expression INNER_SIZE. The BLOCK argument specifies the
4849 : : block in which to calculate the result, and the optional INNER_SIZE_BODY
4850 : : argument contains any statements that need to executed (inside the loop)
4851 : : to initialize or calculate INNER_SIZE. */
4852 : :
4853 : : static tree
4854 : 1298 : compute_overall_iter_number (forall_info *nested_forall_info, tree inner_size,
4855 : : stmtblock_t *inner_size_body, stmtblock_t *block)
4856 : : {
4857 : 1298 : forall_info *forall_tmp = nested_forall_info;
4858 : 1298 : tree tmp, number;
4859 : 1298 : stmtblock_t body;
4860 : :
4861 : : /* We can eliminate the innermost unconditional loops with constant
4862 : : array bounds. */
4863 : 1298 : if (INTEGER_CST_P (inner_size))
4864 : : {
4865 : : while (forall_tmp
4866 : 267 : && !forall_tmp->mask
4867 : 1506 : && INTEGER_CST_P (forall_tmp->size))
4868 : : {
4869 : 117 : inner_size = fold_build2_loc (input_location, MULT_EXPR,
4870 : : gfc_array_index_type,
4871 : : inner_size, forall_tmp->size);
4872 : 117 : forall_tmp = forall_tmp->prev_nest;
4873 : : }
4874 : :
4875 : : /* If there are no loops left, we have our constant result. */
4876 : 1207 : if (!forall_tmp)
4877 : : return inner_size;
4878 : : }
4879 : :
4880 : : /* Otherwise, create a temporary variable to compute the result. */
4881 : 241 : number = gfc_create_var (gfc_array_index_type, "num");
4882 : 241 : gfc_add_modify (block, number, gfc_index_zero_node);
4883 : :
4884 : 241 : gfc_start_block (&body);
4885 : 241 : if (inner_size_body)
4886 : 188 : gfc_add_block_to_block (&body, inner_size_body);
4887 : 241 : if (forall_tmp)
4888 : 225 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
4889 : : gfc_array_index_type, number, inner_size);
4890 : : else
4891 : : tmp = inner_size;
4892 : 241 : gfc_add_modify (&body, number, tmp);
4893 : 241 : tmp = gfc_finish_block (&body);
4894 : :
4895 : : /* Generate loops. */
4896 : 241 : if (forall_tmp != NULL)
4897 : 225 : tmp = gfc_trans_nested_forall_loop (forall_tmp, tmp, 1);
4898 : :
4899 : 241 : gfc_add_expr_to_block (block, tmp);
4900 : :
4901 : 241 : return number;
4902 : : }
4903 : :
4904 : :
4905 : : /* Allocate temporary for forall construct. SIZE is the size of temporary
4906 : : needed. PTEMP1 is returned for space free. */
4907 : :
4908 : : static tree
4909 : 1381 : allocate_temp_for_forall_nest_1 (tree type, tree size, stmtblock_t * block,
4910 : : tree * ptemp1)
4911 : : {
4912 : 1381 : tree bytesize;
4913 : 1381 : tree unit;
4914 : 1381 : tree tmp;
4915 : :
4916 : 1381 : unit = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (type));
4917 : 1381 : if (!integer_onep (unit))
4918 : 166 : bytesize = fold_build2_loc (input_location, MULT_EXPR,
4919 : : gfc_array_index_type, size, unit);
4920 : : else
4921 : : bytesize = size;
4922 : :
4923 : 1381 : *ptemp1 = NULL;
4924 : 1381 : tmp = gfc_do_allocate (bytesize, size, ptemp1, block, type);
4925 : :
4926 : 1381 : if (*ptemp1)
4927 : 242 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
4928 : 1381 : return tmp;
4929 : : }
4930 : :
4931 : :
4932 : : /* Allocate temporary for forall construct according to the information in
4933 : : nested_forall_info. INNER_SIZE is the size of temporary needed in the
4934 : : assignment inside forall. PTEMP1 is returned for space free. */
4935 : :
4936 : : static tree
4937 : 967 : allocate_temp_for_forall_nest (forall_info * nested_forall_info, tree type,
4938 : : tree inner_size, stmtblock_t * inner_size_body,
4939 : : stmtblock_t * block, tree * ptemp1)
4940 : : {
4941 : 967 : tree size;
4942 : :
4943 : : /* Calculate the total size of temporary needed in forall construct. */
4944 : 967 : size = compute_overall_iter_number (nested_forall_info, inner_size,
4945 : : inner_size_body, block);
4946 : :
4947 : 967 : return allocate_temp_for_forall_nest_1 (type, size, block, ptemp1);
4948 : : }
4949 : :
4950 : :
4951 : : /* Handle assignments inside forall which need temporary.
4952 : :
4953 : : forall (i=start:end:stride; maskexpr)
4954 : : e<i> = f<i>
4955 : : end forall
4956 : : (where e,f<i> are arbitrary expressions possibly involving i
4957 : : and there is a dependency between e<i> and f<i>)
4958 : : Translates to:
4959 : : masktmp(:) = maskexpr(:)
4960 : :
4961 : : maskindex = 0;
4962 : : count1 = 0;
4963 : : num = 0;
4964 : : for (i = start; i <= end; i += stride)
4965 : : num += SIZE (f<i>)
4966 : : count1 = 0;
4967 : : ALLOCATE (tmp(num))
4968 : : for (i = start; i <= end; i += stride)
4969 : : {
4970 : : if (masktmp[maskindex++])
4971 : : tmp[count1++] = f<i>
4972 : : }
4973 : : maskindex = 0;
4974 : : count1 = 0;
4975 : : for (i = start; i <= end; i += stride)
4976 : : {
4977 : : if (masktmp[maskindex++])
4978 : : e<i> = tmp[count1++]
4979 : : }
4980 : : DEALLOCATE (tmp)
4981 : : */
4982 : : static void
4983 : 224 : gfc_trans_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
4984 : : tree wheremask, bool invert,
4985 : : forall_info * nested_forall_info,
4986 : : stmtblock_t * block)
4987 : : {
4988 : 224 : tree type;
4989 : 224 : tree inner_size;
4990 : 224 : gfc_ss *lss, *rss;
4991 : 224 : tree count, count1;
4992 : 224 : tree tmp, tmp1;
4993 : 224 : tree ptemp1;
4994 : 224 : stmtblock_t inner_size_body;
4995 : :
4996 : : /* Create vars. count1 is the current iterator number of the nested
4997 : : forall. */
4998 : 224 : count1 = gfc_create_var (gfc_array_index_type, "count1");
4999 : :
5000 : : /* Count is the wheremask index. */
5001 : 224 : if (wheremask)
5002 : : {
5003 : 27 : count = gfc_create_var (gfc_array_index_type, "count");
5004 : 27 : gfc_add_modify (block, count, gfc_index_zero_node);
5005 : : }
5006 : : else
5007 : : count = NULL;
5008 : :
5009 : : /* Initialize count1. */
5010 : 224 : gfc_add_modify (block, count1, gfc_index_zero_node);
5011 : :
5012 : : /* Calculate the size of temporary needed in the assignment. Return loop, lss
5013 : : and rss which are used in function generate_loop_for_rhs_to_temp(). */
5014 : : /* The type of LHS. Used in function allocate_temp_for_forall_nest */
5015 : 224 : if (expr1->ts.type == BT_CHARACTER)
5016 : : {
5017 : 103 : type = NULL;
5018 : 103 : if (expr1->ref && expr1->ref->type == REF_SUBSTRING)
5019 : : {
5020 : 72 : gfc_se ssse;
5021 : 72 : gfc_init_se (&ssse, NULL);
5022 : 72 : gfc_conv_expr (&ssse, expr1);
5023 : 72 : type = gfc_get_character_type_len (gfc_default_character_kind,
5024 : : ssse.string_length);
5025 : 72 : }
5026 : : else
5027 : : {
5028 : 31 : if (!expr1->ts.u.cl->backend_decl)
5029 : : {
5030 : 6 : gfc_se tse;
5031 : 6 : gcc_assert (expr1->ts.u.cl->length);
5032 : 6 : gfc_init_se (&tse, NULL);
5033 : 6 : gfc_conv_expr (&tse, expr1->ts.u.cl->length);
5034 : 6 : expr1->ts.u.cl->backend_decl = tse.expr;
5035 : : }
5036 : 31 : type = gfc_get_character_type_len (gfc_default_character_kind,
5037 : 31 : expr1->ts.u.cl->backend_decl);
5038 : : }
5039 : : }
5040 : : else
5041 : 121 : type = gfc_typenode_for_spec (&expr1->ts);
5042 : :
5043 : 224 : gfc_init_block (&inner_size_body);
5044 : 224 : inner_size = compute_inner_temp_size (expr1, expr2, &inner_size_body,
5045 : : &lss, &rss);
5046 : :
5047 : : /* Allocate temporary for nested forall construct according to the
5048 : : information in nested_forall_info and inner_size. */
5049 : 224 : tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type, inner_size,
5050 : : &inner_size_body, block, &ptemp1);
5051 : :
5052 : : /* Generate codes to copy rhs to the temporary . */
5053 : 224 : tmp = generate_loop_for_rhs_to_temp (expr2, tmp1, count, count1, lss, rss,
5054 : : wheremask, invert);
5055 : :
5056 : : /* Generate body and loops according to the information in
5057 : : nested_forall_info. */
5058 : 224 : tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
5059 : 224 : gfc_add_expr_to_block (block, tmp);
5060 : :
5061 : : /* Reset count1. */
5062 : 224 : gfc_add_modify (block, count1, gfc_index_zero_node);
5063 : :
5064 : : /* Reset count. */
5065 : 224 : if (wheremask)
5066 : 27 : gfc_add_modify (block, count, gfc_index_zero_node);
5067 : :
5068 : : /* TODO: Second call to compute_inner_temp_size to initialize lss and
5069 : : rss; there must be a better way. */
5070 : 224 : inner_size = compute_inner_temp_size (expr1, expr2, &inner_size_body,
5071 : : &lss, &rss);
5072 : :
5073 : : /* Generate codes to copy the temporary to lhs. */
5074 : 224 : tmp = generate_loop_for_temp_to_lhs (expr1, tmp1, count, count1,
5075 : : lss, rss,
5076 : : wheremask, invert);
5077 : :
5078 : : /* Generate body and loops according to the information in
5079 : : nested_forall_info. */
5080 : 224 : tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
5081 : 224 : gfc_add_expr_to_block (block, tmp);
5082 : :
5083 : 224 : if (ptemp1)
5084 : : {
5085 : : /* Free the temporary. */
5086 : 145 : tmp = gfc_call_free (ptemp1);
5087 : 145 : gfc_add_expr_to_block (block, tmp);
5088 : : }
5089 : 224 : }
5090 : :
5091 : :
5092 : : /* Translate pointer assignment inside FORALL which need temporary. */
5093 : :
5094 : : static void
5095 : 20 : gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
5096 : : forall_info * nested_forall_info,
5097 : : stmtblock_t * block)
5098 : : {
5099 : 20 : tree type;
5100 : 20 : tree inner_size;
5101 : 20 : gfc_ss *lss, *rss;
5102 : 20 : gfc_se lse;
5103 : 20 : gfc_se rse;
5104 : 20 : gfc_array_info *info;
5105 : 20 : gfc_loopinfo loop;
5106 : 20 : tree desc;
5107 : 20 : tree parm;
5108 : 20 : tree parmtype;
5109 : 20 : stmtblock_t body;
5110 : 20 : tree count;
5111 : 20 : tree tmp, tmp1, ptemp1;
5112 : :
5113 : 20 : count = gfc_create_var (gfc_array_index_type, "count");
5114 : 20 : gfc_add_modify (block, count, gfc_index_zero_node);
5115 : :
5116 : 20 : inner_size = gfc_index_one_node;
5117 : 20 : lss = gfc_walk_expr (expr1);
5118 : 20 : rss = gfc_walk_expr (expr2);
5119 : 20 : if (lss == gfc_ss_terminator)
5120 : : {
5121 : 11 : type = gfc_typenode_for_spec (&expr1->ts);
5122 : 11 : type = build_pointer_type (type);
5123 : :
5124 : : /* Allocate temporary for nested forall construct according to the
5125 : : information in nested_forall_info and inner_size. */
5126 : 11 : tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type,
5127 : : inner_size, NULL, block, &ptemp1);
5128 : 11 : gfc_start_block (&body);
5129 : 11 : gfc_init_se (&lse, NULL);
5130 : 11 : lse.expr = gfc_build_array_ref (tmp1, count, NULL);
5131 : 11 : gfc_init_se (&rse, NULL);
5132 : 11 : rse.want_pointer = 1;
5133 : 11 : gfc_conv_expr (&rse, expr2);
5134 : 11 : gfc_add_block_to_block (&body, &rse.pre);
5135 : 11 : gfc_add_modify (&body, lse.expr,
5136 : 11 : fold_convert (TREE_TYPE (lse.expr), rse.expr));
5137 : 11 : gfc_add_block_to_block (&body, &rse.post);
5138 : :
5139 : : /* Increment count. */
5140 : 11 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5141 : : count, gfc_index_one_node);
5142 : 11 : gfc_add_modify (&body, count, tmp);
5143 : :
5144 : 11 : tmp = gfc_finish_block (&body);
5145 : :
5146 : : /* Generate body and loops according to the information in
5147 : : nested_forall_info. */
5148 : 11 : tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
5149 : 11 : gfc_add_expr_to_block (block, tmp);
5150 : :
5151 : : /* Reset count. */
5152 : 11 : gfc_add_modify (block, count, gfc_index_zero_node);
5153 : :
5154 : 11 : gfc_start_block (&body);
5155 : 11 : gfc_init_se (&lse, NULL);
5156 : 11 : gfc_init_se (&rse, NULL);
5157 : 11 : rse.expr = gfc_build_array_ref (tmp1, count, NULL);
5158 : 11 : lse.want_pointer = 1;
5159 : 11 : gfc_conv_expr (&lse, expr1);
5160 : 11 : gfc_add_block_to_block (&body, &lse.pre);
5161 : 11 : gfc_add_modify (&body, lse.expr, rse.expr);
5162 : 11 : gfc_add_block_to_block (&body, &lse.post);
5163 : : /* Increment count. */
5164 : 11 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5165 : : count, gfc_index_one_node);
5166 : 11 : gfc_add_modify (&body, count, tmp);
5167 : 11 : tmp = gfc_finish_block (&body);
5168 : :
5169 : : /* Generate body and loops according to the information in
5170 : : nested_forall_info. */
5171 : 11 : tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
5172 : 11 : gfc_add_expr_to_block (block, tmp);
5173 : : }
5174 : : else
5175 : : {
5176 : 9 : gfc_init_loopinfo (&loop);
5177 : :
5178 : : /* Associate the SS with the loop. */
5179 : 9 : gfc_add_ss_to_loop (&loop, rss);
5180 : :
5181 : : /* Setup the scalarizing loops and bounds. */
5182 : 9 : gfc_conv_ss_startstride (&loop);
5183 : :
5184 : 9 : gfc_conv_loop_setup (&loop, &expr2->where);
5185 : :
5186 : 9 : info = &rss->info->data.array;
5187 : 9 : desc = info->descriptor;
5188 : :
5189 : : /* Make a new descriptor. */
5190 : 9 : parmtype = gfc_get_element_type (TREE_TYPE (desc));
5191 : 9 : parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, 0,
5192 : : loop.from, loop.to, 1,
5193 : : GFC_ARRAY_UNKNOWN, true);
5194 : :
5195 : : /* Allocate temporary for nested forall construct. */
5196 : 9 : tmp1 = allocate_temp_for_forall_nest (nested_forall_info, parmtype,
5197 : : inner_size, NULL, block, &ptemp1);
5198 : 9 : gfc_start_block (&body);
5199 : 9 : gfc_init_se (&lse, NULL);
5200 : 9 : lse.expr = gfc_build_array_ref (tmp1, count, NULL);
5201 : 9 : lse.direct_byref = 1;
5202 : 9 : gfc_conv_expr_descriptor (&lse, expr2);
5203 : :
5204 : 9 : gfc_add_block_to_block (&body, &lse.pre);
5205 : 9 : gfc_add_block_to_block (&body, &lse.post);
5206 : :
5207 : : /* Increment count. */
5208 : 9 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5209 : : count, gfc_index_one_node);
5210 : 9 : gfc_add_modify (&body, count, tmp);
5211 : :
5212 : 9 : tmp = gfc_finish_block (&body);
5213 : :
5214 : : /* Generate body and loops according to the information in
5215 : : nested_forall_info. */
5216 : 9 : tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
5217 : 9 : gfc_add_expr_to_block (block, tmp);
5218 : :
5219 : : /* Reset count. */
5220 : 9 : gfc_add_modify (block, count, gfc_index_zero_node);
5221 : :
5222 : 9 : parm = gfc_build_array_ref (tmp1, count, NULL);
5223 : 9 : gfc_init_se (&lse, NULL);
5224 : 9 : gfc_conv_expr_descriptor (&lse, expr1);
5225 : 9 : gfc_add_modify (&lse.pre, lse.expr, parm);
5226 : 9 : gfc_start_block (&body);
5227 : 9 : gfc_add_block_to_block (&body, &lse.pre);
5228 : 9 : gfc_add_block_to_block (&body, &lse.post);
5229 : :
5230 : : /* Increment count. */
5231 : 9 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5232 : : count, gfc_index_one_node);
5233 : 9 : gfc_add_modify (&body, count, tmp);
5234 : :
5235 : 9 : tmp = gfc_finish_block (&body);
5236 : :
5237 : 9 : tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
5238 : 9 : gfc_add_expr_to_block (block, tmp);
5239 : : }
5240 : : /* Free the temporary. */
5241 : 20 : if (ptemp1)
5242 : : {
5243 : 1 : tmp = gfc_call_free (ptemp1);
5244 : 1 : gfc_add_expr_to_block (block, tmp);
5245 : : }
5246 : 20 : }
5247 : :
5248 : : /* For saving the outer-variable data when doing
5249 : : LOCAL and LOCAL_INIT substitution. */
5250 : : struct symbol_and_tree_t
5251 : : {
5252 : : gfc_symbol *sym;
5253 : : gfc_expr *value;
5254 : : tree decl;
5255 : : symbol_attribute attr;
5256 : : };
5257 : :
5258 : : /* Handle the LOCAL and LOCAL_INIT locality specifiers. This has to be
5259 : : called twice, once with after_body=false - and then after the loop
5260 : : body has been processed with after_body=true.
5261 : :
5262 : : Creates a copy of the variables that appear in the LOCAL and LOCAL_INIT
5263 : : locality specifiers of 'do concurrent' - and use it in the original
5264 : : gfc_symbol. The declaration is then reset by after_body=true.
5265 : :
5266 : : Variables in LOCAL_INIT are set in every loop iteration. */
5267 : :
5268 : : void
5269 : 276 : gfc_trans_concurrent_locality_spec (bool after_body, stmtblock_t *body,
5270 : : std::vector<symbol_and_tree_t> *saved_decls,
5271 : : gfc_expr_list **locality_list)
5272 : : {
5273 : 276 : if (!locality_list[LOCALITY_LOCAL] && !locality_list[LOCALITY_LOCAL_INIT])
5274 : : return;
5275 : :
5276 : 96 : if (after_body)
5277 : : {
5278 : 205 : for (unsigned i = 0; i < saved_decls->size (); i++)
5279 : : {
5280 : 157 : (*saved_decls)[i].sym->backend_decl = (*saved_decls)[i].decl;
5281 : 157 : (*saved_decls)[i].sym->attr = (*saved_decls)[i].attr;
5282 : 157 : (*saved_decls)[i].sym->value = (*saved_decls)[i].value;
5283 : : }
5284 : : return;
5285 : : }
5286 : :
5287 : : gfc_expr_list *el;
5288 : : int cnt = 0;
5289 : 144 : for (int i = 0; i <= 1; i++)
5290 : 96 : for (el = locality_list[i == 0 ? LOCALITY_LOCAL : LOCALITY_LOCAL_INIT];
5291 : 253 : el; el = el->next)
5292 : : {
5293 : 157 : gfc_symbol *outer_sym = el->expr->symtree->n.sym;
5294 : 157 : if (!outer_sym->backend_decl)
5295 : 0 : outer_sym->backend_decl = gfc_get_symbol_decl (outer_sym);
5296 : 157 : cnt++;
5297 : : }
5298 : 48 : saved_decls->resize (cnt);
5299 : :
5300 : : /* The variables have to be created in the scope of the loop body. */
5301 : 48 : if (!body->has_scope)
5302 : : {
5303 : 48 : gcc_checking_assert (body->head == NULL_TREE);
5304 : 48 : gfc_start_block (body);
5305 : : }
5306 : 48 : gfc_start_saved_local_decls ();
5307 : :
5308 : 48 : cnt = 0;
5309 : 48 : static_assert (LOCALITY_LOCAL_INIT - LOCALITY_LOCAL == 1, "locality_type");
5310 : 144 : for (int type = LOCALITY_LOCAL;
5311 : 144 : type <= LOCALITY_LOCAL_INIT; type++)
5312 : 253 : for (el = locality_list[type]; el; el = el->next)
5313 : : {
5314 : 157 : gfc_symbol *sym = el->expr->symtree->n.sym;
5315 : 157 : (*saved_decls)[cnt].sym = sym;
5316 : 157 : (*saved_decls)[cnt].attr = sym->attr;
5317 : 157 : (*saved_decls)[cnt].value = sym->value;
5318 : 157 : (*saved_decls)[cnt].decl = sym->backend_decl;
5319 : :
5320 : 157 : if (sym->attr.dimension && sym->as->type == AS_ASSUMED_SHAPE)
5321 : : {
5322 : 3 : gfc_error ("Sorry, %s specifier at %L for assumed-size array %qs "
5323 : : "is not yet supported",
5324 : : type == LOCALITY_LOCAL ? "LOCAL" : "LOCAL_INIT",
5325 : : &el->expr->where, sym->name);
5326 : 2 : continue;
5327 : : }
5328 : :
5329 : 155 : gfc_symbol outer_sym = *sym;
5330 : :
5331 : : /* Create the inner local variable. */
5332 : 155 : sym->backend_decl = NULL;
5333 : 155 : sym->value = NULL;
5334 : 155 : sym->attr.save = SAVE_NONE;
5335 : 155 : sym->attr.value = 0;
5336 : 155 : sym->attr.dummy = 0;
5337 : 155 : sym->attr.optional = 0;
5338 : :
5339 : 155 : {
5340 : : /* Slightly ugly hack for adding the decl via add_decl_as_local. */
5341 : 155 : gfc_symbol dummy_block_sym;
5342 : 155 : dummy_block_sym.attr.flavor = FL_LABEL;
5343 : 155 : gfc_symbol *saved_proc_name = sym->ns->proc_name;
5344 : 155 : sym->ns->proc_name = &dummy_block_sym;
5345 : :
5346 : 155 : gfc_get_symbol_decl (sym);
5347 : 310 : DECL_SOURCE_LOCATION (sym->backend_decl)
5348 : 155 : = gfc_get_location (&el->expr->where);
5349 : :
5350 : 155 : sym->ns->proc_name = saved_proc_name;
5351 : : }
5352 : :
5353 : 155 : symbol_attribute attr = gfc_expr_attr (el->expr);
5354 : 155 : if (type == LOCALITY_LOCAL
5355 : 89 : && !attr.pointer
5356 : 41 : && sym->ts.type == BT_DERIVED
5357 : 183 : && gfc_has_default_initializer (sym->ts.u.derived))
5358 : : /* Cf. PR fortran/ */
5359 : 4 : gfc_error ("Sorry, LOCAL specifier at %L for %qs of derived type with"
5360 : : " default initializer is not yet supported",
5361 : 4 : &el->expr->where, sym->name);
5362 : 155 : if (type == LOCALITY_LOCAL_INIT)
5363 : : {
5364 : : /* LOCAL_INIT: local_var = outer_var. */
5365 : 66 : gfc_symtree st = *el->expr->symtree;
5366 : 66 : st.n.sym = &outer_sym;
5367 : 66 : gfc_expr expr = *el->expr;
5368 : 66 : expr.symtree = &st;
5369 : 66 : tree t = (attr.pointer
5370 : 66 : ? gfc_trans_pointer_assignment (el->expr, &expr)
5371 : 42 : : gfc_trans_assignment (el->expr, &expr, false, false,
5372 : : false, false));
5373 : 66 : gfc_add_expr_to_block (body, t);
5374 : : }
5375 : 155 : cnt++;
5376 : : }
5377 : 48 : gfc_stop_saved_local_decls ();
5378 : : }
5379 : :
5380 : :
5381 : : /* FORALL and WHERE statements are really nasty, especially when you nest
5382 : : them. All the rhs of a forall assignment must be evaluated before the
5383 : : actual assignments are performed. Presumably this also applies to all the
5384 : : assignments in an inner where statement. */
5385 : :
5386 : : /* Generate code for a FORALL statement. Any temporaries are allocated as a
5387 : : linear array, relying on the fact that we process in the same order in all
5388 : : loops.
5389 : :
5390 : : forall (i=start:end:stride; maskexpr)
5391 : : e<i> = f<i>
5392 : : g<i> = h<i>
5393 : : end forall
5394 : : (where e,f,g,h<i> are arbitrary expressions possibly involving i)
5395 : : Translates to:
5396 : : count = ((end + 1 - start) / stride)
5397 : : masktmp(:) = maskexpr(:)
5398 : :
5399 : : maskindex = 0;
5400 : : for (i = start; i <= end; i += stride)
5401 : : {
5402 : : if (masktmp[maskindex++])
5403 : : e<i> = f<i>
5404 : : }
5405 : : maskindex = 0;
5406 : : for (i = start; i <= end; i += stride)
5407 : : {
5408 : : if (masktmp[maskindex++])
5409 : : g<i> = h<i>
5410 : : }
5411 : :
5412 : : Note that this code only works when there are no dependencies.
5413 : : Forall loop with array assignments and data dependencies are a real pain,
5414 : : because the size of the temporary cannot always be determined before the
5415 : : loop is executed. This problem is compounded by the presence of nested
5416 : : FORALL constructs.
5417 : : */
5418 : :
5419 : : static tree
5420 : 2101 : gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
5421 : : {
5422 : 2101 : stmtblock_t pre;
5423 : 2101 : stmtblock_t post;
5424 : 2101 : stmtblock_t block;
5425 : 2101 : stmtblock_t body;
5426 : 2101 : tree *var;
5427 : 2101 : tree *start;
5428 : 2101 : tree *end;
5429 : 2101 : tree *step;
5430 : 2101 : gfc_expr **varexpr;
5431 : 2101 : tree tmp;
5432 : 2101 : tree assign;
5433 : 2101 : tree size;
5434 : 2101 : tree maskindex;
5435 : 2101 : tree mask;
5436 : 2101 : tree pmask;
5437 : 2101 : tree cycle_label = NULL_TREE;
5438 : 2101 : int n;
5439 : 2101 : int nvar;
5440 : 2101 : int need_temp;
5441 : 2101 : gfc_forall_iterator *fa;
5442 : 2101 : gfc_se se;
5443 : 2101 : gfc_code *c;
5444 : 2101 : gfc_saved_var *saved_vars;
5445 : 2101 : iter_info *this_forall;
5446 : 2101 : forall_info *info;
5447 : 2101 : bool need_mask;
5448 : :
5449 : : /* Do nothing if the mask is false. */
5450 : 2101 : if (code->expr1
5451 : 725 : && code->expr1->expr_type == EXPR_CONSTANT
5452 : 2 : && !code->expr1->value.logical)
5453 : 1 : return build_empty_stmt (input_location);
5454 : :
5455 : 2100 : n = 0;
5456 : : /* Count the FORALL index number. */
5457 : 6110 : for (fa = code->ext.concur.forall_iterator; fa; fa = fa->next)
5458 : 4010 : n++;
5459 : 2100 : nvar = n;
5460 : :
5461 : : /* Allocate the space for var, start, end, step, varexpr. */
5462 : 2100 : var = XCNEWVEC (tree, nvar);
5463 : 2100 : start = XCNEWVEC (tree, nvar);
5464 : 2100 : end = XCNEWVEC (tree, nvar);
5465 : 2100 : step = XCNEWVEC (tree, nvar);
5466 : 2100 : varexpr = XCNEWVEC (gfc_expr *, nvar);
5467 : 2100 : saved_vars = XCNEWVEC (gfc_saved_var, nvar);
5468 : :
5469 : : /* Allocate the space for info. */
5470 : 2100 : info = XCNEW (forall_info);
5471 : :
5472 : 2100 : gfc_start_block (&pre);
5473 : 2100 : gfc_init_block (&post);
5474 : 2100 : gfc_init_block (&block);
5475 : :
5476 : 2100 : n = 0;
5477 : 6110 : for (fa = code->ext.concur.forall_iterator; fa; fa = fa->next)
5478 : : {
5479 : 4010 : gfc_symbol *sym = fa->var->symtree->n.sym;
5480 : :
5481 : : /* Allocate space for this_forall. */
5482 : 4010 : this_forall = XCNEW (iter_info);
5483 : :
5484 : : /* Create a temporary variable for the FORALL index. */
5485 : 4010 : tmp = gfc_typenode_for_spec (&sym->ts);
5486 : 4010 : var[n] = gfc_create_var (tmp, sym->name);
5487 : 4010 : gfc_shadow_sym (sym, var[n], &saved_vars[n]);
5488 : :
5489 : : /* Record it in this_forall. */
5490 : 4010 : this_forall->var = var[n];
5491 : :
5492 : : /* Replace the index symbol's backend_decl with the temporary decl. */
5493 : 4010 : sym->backend_decl = var[n];
5494 : :
5495 : : /* Work out the start, end and stride for the loop. */
5496 : 4010 : gfc_init_se (&se, NULL);
5497 : 4010 : gfc_conv_expr_val (&se, fa->start);
5498 : : /* Record it in this_forall. */
5499 : 4010 : this_forall->start = se.expr;
5500 : 4010 : gfc_add_block_to_block (&block, &se.pre);
5501 : 4010 : start[n] = se.expr;
5502 : :
5503 : 4010 : gfc_init_se (&se, NULL);
5504 : 4010 : gfc_conv_expr_val (&se, fa->end);
5505 : : /* Record it in this_forall. */
5506 : 4010 : this_forall->end = se.expr;
5507 : 4010 : gfc_make_safe_expr (&se);
5508 : 4010 : gfc_add_block_to_block (&block, &se.pre);
5509 : 4010 : end[n] = se.expr;
5510 : :
5511 : 4010 : gfc_init_se (&se, NULL);
5512 : 4010 : gfc_conv_expr_val (&se, fa->stride);
5513 : : /* Record it in this_forall. */
5514 : 4010 : this_forall->step = se.expr;
5515 : 4010 : gfc_make_safe_expr (&se);
5516 : 4010 : gfc_add_block_to_block (&block, &se.pre);
5517 : 4010 : step[n] = se.expr;
5518 : :
5519 : : /* Copy loop annotations. */
5520 : 4010 : this_forall->annot = fa->annot;
5521 : :
5522 : : /* Set the NEXT field of this_forall to NULL. */
5523 : 4010 : this_forall->next = NULL;
5524 : : /* Link this_forall to the info construct. */
5525 : 4010 : if (info->this_loop)
5526 : : {
5527 : : iter_info *iter_tmp = info->this_loop;
5528 : 2836 : while (iter_tmp->next != NULL)
5529 : : iter_tmp = iter_tmp->next;
5530 : 1910 : iter_tmp->next = this_forall;
5531 : : }
5532 : : else
5533 : 2100 : info->this_loop = this_forall;
5534 : :
5535 : 4010 : n++;
5536 : : }
5537 : 2100 : nvar = n;
5538 : :
5539 : : /* Calculate the size needed for the current forall level. */
5540 : 2100 : size = gfc_index_one_node;
5541 : 6110 : for (n = 0; n < nvar; n++)
5542 : : {
5543 : : /* size = (end + step - start) / step. */
5544 : 4010 : tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (start[n]),
5545 : 4010 : step[n], start[n]);
5546 : 4010 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (end[n]),
5547 : 4010 : end[n], tmp);
5548 : 4010 : tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, TREE_TYPE (tmp),
5549 : : tmp, step[n]);
5550 : 4010 : tmp = convert (gfc_array_index_type, tmp);
5551 : :
5552 : 4010 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5553 : : size, tmp);
5554 : : }
5555 : :
5556 : : /* Record the nvar and size of current forall level. */
5557 : 2100 : info->nvar = nvar;
5558 : 2100 : info->size = size;
5559 : :
5560 : 2100 : if (code->expr1)
5561 : : {
5562 : : /* If the mask is .true., consider the FORALL unconditional. */
5563 : 724 : if (code->expr1->expr_type == EXPR_CONSTANT
5564 : 1 : && code->expr1->value.logical)
5565 : : need_mask = false;
5566 : : else
5567 : 723 : need_mask = true;
5568 : : }
5569 : : else
5570 : : need_mask = false;
5571 : :
5572 : : /* First we need to allocate the mask. */
5573 : 723 : if (need_mask)
5574 : : {
5575 : : /* As the mask array can be very big, prefer compact boolean types. */
5576 : 723 : tree mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind);
5577 : 723 : mask = allocate_temp_for_forall_nest (nested_forall_info, mask_type,
5578 : : size, NULL, &block, &pmask);
5579 : 723 : maskindex = gfc_create_var_np (gfc_array_index_type, "mi");
5580 : :
5581 : : /* Record them in the info structure. */
5582 : 723 : info->maskindex = maskindex;
5583 : 723 : info->mask = mask;
5584 : : }
5585 : : else
5586 : : {
5587 : : /* No mask was specified. */
5588 : 1377 : maskindex = NULL_TREE;
5589 : 1377 : mask = pmask = NULL_TREE;
5590 : : }
5591 : :
5592 : : /* Link the current forall level to nested_forall_info. */
5593 : 2100 : info->prev_nest = nested_forall_info;
5594 : 2100 : nested_forall_info = info;
5595 : :
5596 : : /* Copy the mask into a temporary variable if required.
5597 : : For now we assume a mask temporary is needed. */
5598 : 2100 : if (need_mask)
5599 : : {
5600 : : /* As the mask array can be very big, prefer compact boolean types. */
5601 : 723 : tree mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind);
5602 : :
5603 : 723 : gfc_add_modify (&block, maskindex, gfc_index_zero_node);
5604 : :
5605 : : /* Start of mask assignment loop body. */
5606 : 723 : gfc_start_block (&body);
5607 : :
5608 : : /* Evaluate the mask expression. */
5609 : 723 : gfc_init_se (&se, NULL);
5610 : 723 : gfc_conv_expr_val (&se, code->expr1);
5611 : 723 : gfc_add_block_to_block (&body, &se.pre);
5612 : :
5613 : : /* Store the mask. */
5614 : 723 : se.expr = convert (mask_type, se.expr);
5615 : :
5616 : 723 : tmp = gfc_build_array_ref (mask, maskindex, NULL);
5617 : 723 : gfc_add_modify (&body, tmp, se.expr);
5618 : :
5619 : : /* Advance to the next mask element. */
5620 : 723 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5621 : : maskindex, gfc_index_one_node);
5622 : 723 : gfc_add_modify (&body, maskindex, tmp);
5623 : :
5624 : : /* Generate the loops. */
5625 : 723 : tmp = gfc_finish_block (&body);
5626 : 723 : tmp = gfc_trans_nested_forall_loop (info, tmp, 0);
5627 : 723 : gfc_add_expr_to_block (&block, tmp);
5628 : : }
5629 : :
5630 : 2100 : if (code->op == EXEC_DO_CONCURRENT)
5631 : : {
5632 : 138 : gfc_init_block (&body);
5633 : 138 : cycle_label = gfc_build_label_decl (NULL_TREE);
5634 : 138 : code->cycle_label = cycle_label;
5635 : :
5636 : : /* Handle LOCAL and LOCAL_INIT. */
5637 : 138 : std::vector<symbol_and_tree_t> saved_decls;
5638 : 138 : gfc_trans_concurrent_locality_spec (false, &body, &saved_decls,
5639 : 138 : code->ext.concur.locality);
5640 : :
5641 : : /* Translate the body. */
5642 : 138 : tmp = gfc_trans_code (code->block->next);
5643 : 138 : gfc_add_expr_to_block (&body, tmp);
5644 : :
5645 : : /* Reset locality variables. */
5646 : 138 : gfc_trans_concurrent_locality_spec (true, &body, &saved_decls,
5647 : : code->ext.concur.locality);
5648 : 138 : if (TREE_USED (cycle_label))
5649 : : {
5650 : 138 : tmp = build1_v (LABEL_EXPR, cycle_label);
5651 : 138 : gfc_add_expr_to_block (&body, tmp);
5652 : : }
5653 : :
5654 : 138 : tmp = gfc_finish_block (&body);
5655 : 138 : nested_forall_info->do_concurrent = true;
5656 : 138 : tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
5657 : 138 : gfc_add_expr_to_block (&block, tmp);
5658 : 138 : goto done;
5659 : 138 : }
5660 : :
5661 : 1962 : c = code->block->next;
5662 : :
5663 : : /* TODO: loop merging in FORALL statements. */
5664 : : /* Now that we've got a copy of the mask, generate the assignment loops. */
5665 : 3942 : while (c)
5666 : : {
5667 : 1980 : switch (c->op)
5668 : : {
5669 : 1825 : case EXEC_ASSIGN:
5670 : : /* A scalar or array assignment. DO the simple check for
5671 : : lhs to rhs dependencies. These make a temporary for the
5672 : : rhs and form a second forall block to copy to variable. */
5673 : 1825 : need_temp = check_forall_dependencies(c, &pre, &post);
5674 : :
5675 : : /* Temporaries due to array assignment data dependencies introduce
5676 : : no end of problems. */
5677 : 1825 : if (need_temp || flag_test_forall_temp)
5678 : 197 : gfc_trans_assign_need_temp (c->expr1, c->expr2, NULL, false,
5679 : : nested_forall_info, &block);
5680 : : else
5681 : : {
5682 : : /* Use the normal assignment copying routines. */
5683 : 1628 : assign = gfc_trans_assignment (c->expr1, c->expr2, false, true);
5684 : :
5685 : : /* Generate body and loops. */
5686 : 1628 : tmp = gfc_trans_nested_forall_loop (nested_forall_info,
5687 : : assign, 1);
5688 : 1628 : gfc_add_expr_to_block (&block, tmp);
5689 : : }
5690 : :
5691 : : /* Cleanup any temporary symtrees that have been made to deal
5692 : : with dependencies. */
5693 : 1825 : if (new_symtree)
5694 : 62 : cleanup_forall_symtrees (c);
5695 : :
5696 : : break;
5697 : :
5698 : 46 : case EXEC_WHERE:
5699 : : /* Translate WHERE or WHERE construct nested in FORALL. */
5700 : 46 : gfc_trans_where_2 (c, NULL, false, nested_forall_info, &block);
5701 : 46 : break;
5702 : :
5703 : : /* Pointer assignment inside FORALL. */
5704 : 27 : case EXEC_POINTER_ASSIGN:
5705 : 27 : need_temp = gfc_check_dependency (c->expr1, c->expr2, 0);
5706 : : /* Avoid cases where a temporary would never be needed and where
5707 : : the temp code is guaranteed to fail. */
5708 : 27 : if (need_temp
5709 : 7 : || (flag_test_forall_temp
5710 : 0 : && c->expr2->expr_type != EXPR_CONSTANT
5711 : 0 : && c->expr2->expr_type != EXPR_NULL))
5712 : 20 : gfc_trans_pointer_assign_need_temp (c->expr1, c->expr2,
5713 : : nested_forall_info, &block);
5714 : : else
5715 : : {
5716 : : /* Use the normal assignment copying routines. */
5717 : 7 : assign = gfc_trans_pointer_assignment (c->expr1, c->expr2);
5718 : :
5719 : : /* Generate body and loops. */
5720 : 7 : tmp = gfc_trans_nested_forall_loop (nested_forall_info,
5721 : : assign, 1);
5722 : 7 : gfc_add_expr_to_block (&block, tmp);
5723 : : }
5724 : : break;
5725 : :
5726 : 76 : case EXEC_FORALL:
5727 : 76 : tmp = gfc_trans_forall_1 (c, nested_forall_info);
5728 : 76 : gfc_add_expr_to_block (&block, tmp);
5729 : 76 : break;
5730 : :
5731 : : /* Explicit subroutine calls are prevented by the frontend but interface
5732 : : assignments can legitimately produce them. */
5733 : 6 : case EXEC_ASSIGN_CALL:
5734 : 6 : assign = gfc_trans_call (c, true, NULL_TREE, NULL_TREE, false);
5735 : 6 : tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1);
5736 : 6 : gfc_add_expr_to_block (&block, tmp);
5737 : 6 : break;
5738 : :
5739 : 0 : default:
5740 : 0 : gcc_unreachable ();
5741 : : }
5742 : :
5743 : 1980 : c = c->next;
5744 : : }
5745 : :
5746 : 1962 : done:
5747 : : /* Restore the original index variables. */
5748 : 6110 : for (fa = code->ext.concur.forall_iterator, n = 0; fa; fa = fa->next, n++)
5749 : 4010 : gfc_restore_sym (fa->var->symtree->n.sym, &saved_vars[n]);
5750 : :
5751 : : /* Free the space for var, start, end, step, varexpr. */
5752 : 2100 : free (var);
5753 : 2100 : free (start);
5754 : 2100 : free (end);
5755 : 2100 : free (step);
5756 : 2100 : free (varexpr);
5757 : 2100 : free (saved_vars);
5758 : :
5759 : 6110 : for (this_forall = info->this_loop; this_forall;)
5760 : : {
5761 : 4010 : iter_info *next = this_forall->next;
5762 : 4010 : free (this_forall);
5763 : 4010 : this_forall = next;
5764 : : }
5765 : :
5766 : : /* Free the space for this forall_info. */
5767 : 2100 : free (info);
5768 : :
5769 : 2100 : if (pmask)
5770 : : {
5771 : : /* Free the temporary for the mask. */
5772 : 52 : tmp = gfc_call_free (pmask);
5773 : 52 : gfc_add_expr_to_block (&block, tmp);
5774 : : }
5775 : 2100 : if (maskindex)
5776 : 723 : pushdecl (maskindex);
5777 : :
5778 : 2100 : gfc_add_block_to_block (&pre, &block);
5779 : 2100 : gfc_add_block_to_block (&pre, &post);
5780 : :
5781 : 2100 : return gfc_finish_block (&pre);
5782 : : }
5783 : :
5784 : :
5785 : : /* Translate the FORALL statement or construct. */
5786 : :
5787 : 1887 : tree gfc_trans_forall (gfc_code * code)
5788 : : {
5789 : 1887 : return gfc_trans_forall_1 (code, NULL);
5790 : : }
5791 : :
5792 : :
5793 : : /* Translate the DO CONCURRENT construct. */
5794 : :
5795 : 138 : tree gfc_trans_do_concurrent (gfc_code * code)
5796 : : {
5797 : 138 : return gfc_trans_forall_1 (code, NULL);
5798 : : }
5799 : :
5800 : :
5801 : : /* Evaluate the WHERE mask expression, copy its value to a temporary.
5802 : : If the WHERE construct is nested in FORALL, compute the overall temporary
5803 : : needed by the WHERE mask expression multiplied by the iterator number of
5804 : : the nested forall.
5805 : : ME is the WHERE mask expression.
5806 : : MASK is the current execution mask upon input, whose sense may or may
5807 : : not be inverted as specified by the INVERT argument.
5808 : : CMASK is the updated execution mask on output, or NULL if not required.
5809 : : PMASK is the pending execution mask on output, or NULL if not required.
5810 : : BLOCK is the block in which to place the condition evaluation loops. */
5811 : :
5812 : : static void
5813 : 527 : gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info,
5814 : : tree mask, bool invert, tree cmask, tree pmask,
5815 : : tree mask_type, stmtblock_t * block)
5816 : : {
5817 : 527 : tree tmp, tmp1;
5818 : 527 : gfc_ss *lss, *rss;
5819 : 527 : gfc_loopinfo loop;
5820 : 527 : stmtblock_t body, body1;
5821 : 527 : tree count, cond, mtmp;
5822 : 527 : gfc_se lse, rse;
5823 : :
5824 : 527 : gfc_init_loopinfo (&loop);
5825 : :
5826 : 527 : lss = gfc_walk_expr (me);
5827 : 527 : rss = gfc_walk_expr (me);
5828 : :
5829 : : /* Variable to index the temporary. */
5830 : 527 : count = gfc_create_var (gfc_array_index_type, "count");
5831 : : /* Initialize count. */
5832 : 527 : gfc_add_modify (block, count, gfc_index_zero_node);
5833 : :
5834 : 527 : gfc_start_block (&body);
5835 : :
5836 : 527 : gfc_init_se (&rse, NULL);
5837 : 527 : gfc_init_se (&lse, NULL);
5838 : :
5839 : 527 : if (lss == gfc_ss_terminator)
5840 : : {
5841 : 0 : gfc_init_block (&body1);
5842 : : }
5843 : : else
5844 : : {
5845 : : /* Initialize the loop. */
5846 : 527 : gfc_init_loopinfo (&loop);
5847 : :
5848 : : /* We may need LSS to determine the shape of the expression. */
5849 : 527 : gfc_add_ss_to_loop (&loop, lss);
5850 : 527 : gfc_add_ss_to_loop (&loop, rss);
5851 : :
5852 : 527 : gfc_conv_ss_startstride (&loop);
5853 : 527 : gfc_conv_loop_setup (&loop, &me->where);
5854 : :
5855 : 527 : gfc_mark_ss_chain_used (rss, 1);
5856 : : /* Start the loop body. */
5857 : 527 : gfc_start_scalarized_body (&loop, &body1);
5858 : :
5859 : : /* Translate the expression. */
5860 : 527 : gfc_copy_loopinfo_to_se (&rse, &loop);
5861 : 527 : rse.ss = rss;
5862 : 527 : gfc_conv_expr (&rse, me);
5863 : : }
5864 : :
5865 : : /* Variable to evaluate mask condition. */
5866 : 527 : cond = gfc_create_var (mask_type, "cond");
5867 : 527 : if (mask && (cmask || pmask))
5868 : 234 : mtmp = gfc_create_var (mask_type, "mask");
5869 : : else mtmp = NULL_TREE;
5870 : :
5871 : 527 : gfc_add_block_to_block (&body1, &lse.pre);
5872 : 527 : gfc_add_block_to_block (&body1, &rse.pre);
5873 : :
5874 : 527 : gfc_add_modify (&body1, cond, fold_convert (mask_type, rse.expr));
5875 : :
5876 : 527 : if (mask && (cmask || pmask))
5877 : : {
5878 : 234 : tmp = gfc_build_array_ref (mask, count, NULL);
5879 : 234 : if (invert)
5880 : 99 : tmp = fold_build1_loc (input_location, TRUTH_NOT_EXPR, mask_type, tmp);
5881 : 234 : gfc_add_modify (&body1, mtmp, tmp);
5882 : : }
5883 : :
5884 : 527 : if (cmask)
5885 : : {
5886 : 509 : tmp1 = gfc_build_array_ref (cmask, count, NULL);
5887 : 509 : tmp = cond;
5888 : 509 : if (mask)
5889 : 234 : tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, mask_type,
5890 : : mtmp, tmp);
5891 : 509 : gfc_add_modify (&body1, tmp1, tmp);
5892 : : }
5893 : :
5894 : 527 : if (pmask)
5895 : : {
5896 : 146 : tmp1 = gfc_build_array_ref (pmask, count, NULL);
5897 : 146 : tmp = fold_build1_loc (input_location, TRUTH_NOT_EXPR, mask_type, cond);
5898 : 146 : if (mask)
5899 : 146 : tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, mask_type, mtmp,
5900 : : tmp);
5901 : 146 : gfc_add_modify (&body1, tmp1, tmp);
5902 : : }
5903 : :
5904 : 527 : gfc_add_block_to_block (&body1, &lse.post);
5905 : 527 : gfc_add_block_to_block (&body1, &rse.post);
5906 : :
5907 : 527 : if (lss == gfc_ss_terminator)
5908 : : {
5909 : 0 : gfc_add_block_to_block (&body, &body1);
5910 : : }
5911 : : else
5912 : : {
5913 : : /* Increment count. */
5914 : 527 : tmp1 = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5915 : : count, gfc_index_one_node);
5916 : 527 : gfc_add_modify (&body1, count, tmp1);
5917 : :
5918 : : /* Generate the copying loops. */
5919 : 527 : gfc_trans_scalarizing_loops (&loop, &body1);
5920 : :
5921 : 527 : gfc_add_block_to_block (&body, &loop.pre);
5922 : 527 : gfc_add_block_to_block (&body, &loop.post);
5923 : :
5924 : 527 : gfc_cleanup_loop (&loop);
5925 : : /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
5926 : : as tree nodes in SS may not be valid in different scope. */
5927 : : }
5928 : :
5929 : 527 : tmp1 = gfc_finish_block (&body);
5930 : : /* If the WHERE construct is inside FORALL, fill the full temporary. */
5931 : 527 : if (nested_forall_info != NULL)
5932 : 64 : tmp1 = gfc_trans_nested_forall_loop (nested_forall_info, tmp1, 1);
5933 : :
5934 : 527 : gfc_add_expr_to_block (block, tmp1);
5935 : 527 : }
5936 : :
5937 : :
5938 : : /* Translate an assignment statement in a WHERE statement or construct
5939 : : statement. The MASK expression is used to control which elements
5940 : : of EXPR1 shall be assigned. The sense of MASK is specified by
5941 : : INVERT. */
5942 : :
5943 : : static tree
5944 : 544 : gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2,
5945 : : tree mask, bool invert,
5946 : : tree count1, tree count2,
5947 : : gfc_code *cnext)
5948 : : {
5949 : 544 : gfc_se lse;
5950 : 544 : gfc_se rse;
5951 : 544 : gfc_ss *lss;
5952 : 544 : gfc_ss *lss_section;
5953 : 544 : gfc_ss *rss;
5954 : :
5955 : 544 : gfc_loopinfo loop;
5956 : 544 : tree tmp;
5957 : 544 : stmtblock_t block;
5958 : 544 : stmtblock_t body;
5959 : 544 : tree index, maskexpr;
5960 : :
5961 : : /* A defined assignment. */
5962 : 544 : if (cnext && cnext->resolved_sym)
5963 : 44 : return gfc_trans_call (cnext, true, mask, count1, invert);
5964 : :
5965 : : #if 0
5966 : : /* TODO: handle this special case.
5967 : : Special case a single function returning an array. */
5968 : : if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
5969 : : {
5970 : : tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
5971 : : if (tmp)
5972 : : return tmp;
5973 : : }
5974 : : #endif
5975 : :
5976 : : /* Assignment of the form lhs = rhs. */
5977 : 500 : gfc_start_block (&block);
5978 : :
5979 : 500 : gfc_init_se (&lse, NULL);
5980 : 500 : gfc_init_se (&rse, NULL);
5981 : :
5982 : : /* Walk the lhs. */
5983 : 500 : lss = gfc_walk_expr (expr1);
5984 : 500 : rss = NULL;
5985 : :
5986 : : /* In each where-assign-stmt, the mask-expr and the variable being
5987 : : defined shall be arrays of the same shape. */
5988 : 500 : gcc_assert (lss != gfc_ss_terminator);
5989 : :
5990 : : /* The assignment needs scalarization. */
5991 : : lss_section = lss;
5992 : :
5993 : : /* Find a non-scalar SS from the lhs. */
5994 : : while (lss_section != gfc_ss_terminator
5995 : 500 : && lss_section->info->type != GFC_SS_SECTION)
5996 : 0 : lss_section = lss_section->next;
5997 : :
5998 : 500 : gcc_assert (lss_section != gfc_ss_terminator);
5999 : :
6000 : : /* Initialize the scalarizer. */
6001 : 500 : gfc_init_loopinfo (&loop);
6002 : :
6003 : : /* Walk the rhs. */
6004 : 500 : rss = gfc_walk_expr (expr2);
6005 : 500 : if (rss == gfc_ss_terminator)
6006 : : {
6007 : : /* The rhs is scalar. Add a ss for the expression. */
6008 : 343 : rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
6009 : 343 : rss->info->where = 1;
6010 : : }
6011 : :
6012 : : /* Associate the SS with the loop. */
6013 : 500 : gfc_add_ss_to_loop (&loop, lss);
6014 : 500 : gfc_add_ss_to_loop (&loop, rss);
6015 : :
6016 : : /* Calculate the bounds of the scalarization. */
6017 : 500 : gfc_conv_ss_startstride (&loop);
6018 : :
6019 : : /* Resolve any data dependencies in the statement. */
6020 : 500 : gfc_conv_resolve_dependencies (&loop, lss_section, rss);
6021 : :
6022 : : /* Setup the scalarizing loops. */
6023 : 500 : gfc_conv_loop_setup (&loop, &expr2->where);
6024 : :
6025 : : /* Setup the gfc_se structures. */
6026 : 500 : gfc_copy_loopinfo_to_se (&lse, &loop);
6027 : 500 : gfc_copy_loopinfo_to_se (&rse, &loop);
6028 : :
6029 : 500 : rse.ss = rss;
6030 : 500 : gfc_mark_ss_chain_used (rss, 1);
6031 : 500 : if (loop.temp_ss == NULL)
6032 : : {
6033 : 422 : lse.ss = lss;
6034 : 422 : gfc_mark_ss_chain_used (lss, 1);
6035 : : }
6036 : : else
6037 : : {
6038 : 78 : lse.ss = loop.temp_ss;
6039 : 78 : gfc_mark_ss_chain_used (lss, 3);
6040 : 78 : gfc_mark_ss_chain_used (loop.temp_ss, 3);
6041 : : }
6042 : :
6043 : : /* Start the scalarized loop body. */
6044 : 500 : gfc_start_scalarized_body (&loop, &body);
6045 : :
6046 : : /* Translate the expression. */
6047 : 500 : gfc_conv_expr (&rse, expr2);
6048 : 500 : if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
6049 : 78 : gfc_conv_tmp_array_ref (&lse);
6050 : : else
6051 : 422 : gfc_conv_expr (&lse, expr1);
6052 : :
6053 : : /* Form the mask expression according to the mask. */
6054 : 500 : index = count1;
6055 : 500 : maskexpr = gfc_build_array_ref (mask, index, NULL);
6056 : 500 : if (invert)
6057 : 24 : maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
6058 : 24 : TREE_TYPE (maskexpr), maskexpr);
6059 : :
6060 : : /* Use the scalar assignment as is. */
6061 : 1000 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
6062 : 500 : false, loop.temp_ss == NULL);
6063 : :
6064 : 500 : tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt (input_location));
6065 : :
6066 : 500 : gfc_add_expr_to_block (&body, tmp);
6067 : :
6068 : 500 : if (lss == gfc_ss_terminator)
6069 : : {
6070 : : /* Increment count1. */
6071 : : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6072 : : count1, gfc_index_one_node);
6073 : : gfc_add_modify (&body, count1, tmp);
6074 : :
6075 : : /* Use the scalar assignment as is. */
6076 : : gfc_add_block_to_block (&block, &body);
6077 : : }
6078 : : else
6079 : : {
6080 : 500 : gcc_assert (lse.ss == gfc_ss_terminator
6081 : : && rse.ss == gfc_ss_terminator);
6082 : :
6083 : 500 : if (loop.temp_ss != NULL)
6084 : : {
6085 : : /* Increment count1 before finish the main body of a scalarized
6086 : : expression. */
6087 : 78 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
6088 : : gfc_array_index_type, count1, gfc_index_one_node);
6089 : 78 : gfc_add_modify (&body, count1, tmp);
6090 : 78 : gfc_trans_scalarized_loop_boundary (&loop, &body);
6091 : :
6092 : : /* We need to copy the temporary to the actual lhs. */
6093 : 78 : gfc_init_se (&lse, NULL);
6094 : 78 : gfc_init_se (&rse, NULL);
6095 : 78 : gfc_copy_loopinfo_to_se (&lse, &loop);
6096 : 78 : gfc_copy_loopinfo_to_se (&rse, &loop);
6097 : :
6098 : 78 : rse.ss = loop.temp_ss;
6099 : 78 : lse.ss = lss;
6100 : :
6101 : 78 : gfc_conv_tmp_array_ref (&rse);
6102 : 78 : gfc_conv_expr (&lse, expr1);
6103 : :
6104 : 78 : gcc_assert (lse.ss == gfc_ss_terminator
6105 : : && rse.ss == gfc_ss_terminator);
6106 : :
6107 : : /* Form the mask expression according to the mask tree list. */
6108 : 78 : index = count2;
6109 : 78 : maskexpr = gfc_build_array_ref (mask, index, NULL);
6110 : 78 : if (invert)
6111 : 0 : maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
6112 : 0 : TREE_TYPE (maskexpr), maskexpr);
6113 : :
6114 : : /* Use the scalar assignment as is. */
6115 : 78 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, true);
6116 : 78 : tmp = build3_v (COND_EXPR, maskexpr, tmp,
6117 : : build_empty_stmt (input_location));
6118 : 78 : gfc_add_expr_to_block (&body, tmp);
6119 : :
6120 : : /* Increment count2. */
6121 : 78 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
6122 : : gfc_array_index_type, count2,
6123 : : gfc_index_one_node);
6124 : 78 : gfc_add_modify (&body, count2, tmp);
6125 : : }
6126 : : else
6127 : : {
6128 : : /* Increment count1. */
6129 : 422 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
6130 : : gfc_array_index_type, count1,
6131 : : gfc_index_one_node);
6132 : 422 : gfc_add_modify (&body, count1, tmp);
6133 : : }
6134 : :
6135 : : /* Generate the copying loops. */
6136 : 500 : gfc_trans_scalarizing_loops (&loop, &body);
6137 : :
6138 : : /* Wrap the whole thing up. */
6139 : 500 : gfc_add_block_to_block (&block, &loop.pre);
6140 : 500 : gfc_add_block_to_block (&block, &loop.post);
6141 : 500 : gfc_cleanup_loop (&loop);
6142 : : }
6143 : :
6144 : 500 : return gfc_finish_block (&block);
6145 : : }
6146 : :
6147 : :
6148 : : /* Translate the WHERE construct or statement.
6149 : : This function can be called iteratively to translate the nested WHERE
6150 : : construct or statement.
6151 : : MASK is the control mask. */
6152 : :
6153 : : static void
6154 : 349 : gfc_trans_where_2 (gfc_code * code, tree mask, bool invert,
6155 : : forall_info * nested_forall_info, stmtblock_t * block)
6156 : : {
6157 : 349 : stmtblock_t inner_size_body;
6158 : 349 : tree inner_size, size;
6159 : 349 : gfc_ss *lss, *rss;
6160 : 349 : tree mask_type;
6161 : 349 : gfc_expr *expr1;
6162 : 349 : gfc_expr *expr2;
6163 : 349 : gfc_code *cblock;
6164 : 349 : gfc_code *cnext;
6165 : 349 : tree tmp;
6166 : 349 : tree cond;
6167 : 349 : tree count1, count2;
6168 : 349 : bool need_cmask;
6169 : 349 : bool need_pmask;
6170 : 349 : int need_temp;
6171 : 349 : tree pcmask = NULL_TREE;
6172 : 349 : tree ppmask = NULL_TREE;
6173 : 349 : tree cmask = NULL_TREE;
6174 : 349 : tree pmask = NULL_TREE;
6175 : 349 : gfc_actual_arglist *arg;
6176 : :
6177 : : /* the WHERE statement or the WHERE construct statement. */
6178 : 349 : cblock = code->block;
6179 : :
6180 : : /* As the mask array can be very big, prefer compact boolean types. */
6181 : 349 : mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind);
6182 : :
6183 : : /* Determine which temporary masks are needed. */
6184 : 349 : if (!cblock->block)
6185 : : {
6186 : : /* One clause: No ELSEWHEREs. */
6187 : 168 : need_cmask = (cblock->next != 0);
6188 : 168 : need_pmask = false;
6189 : : }
6190 : 181 : else if (cblock->block->block)
6191 : : {
6192 : : /* Three or more clauses: Conditional ELSEWHEREs. */
6193 : : need_cmask = true;
6194 : : need_pmask = true;
6195 : : }
6196 : 102 : else if (cblock->next)
6197 : : {
6198 : : /* Two clauses, the first non-empty. */
6199 : 84 : need_cmask = true;
6200 : 84 : need_pmask = (mask != NULL_TREE
6201 : 84 : && cblock->block->next != 0);
6202 : : }
6203 : 18 : else if (!cblock->block->next)
6204 : : {
6205 : : /* Two clauses, both empty. */
6206 : : need_cmask = false;
6207 : : need_pmask = false;
6208 : : }
6209 : : /* Two clauses, the first empty, the second non-empty. */
6210 : 9 : else if (mask)
6211 : : {
6212 : 0 : need_cmask = (cblock->block->expr1 != 0);
6213 : 0 : need_pmask = true;
6214 : : }
6215 : : else
6216 : : {
6217 : : need_cmask = true;
6218 : : need_pmask = false;
6219 : : }
6220 : :
6221 : 168 : if (need_cmask || need_pmask)
6222 : : {
6223 : : /* Calculate the size of temporary needed by the mask-expr. */
6224 : 331 : gfc_init_block (&inner_size_body);
6225 : 331 : inner_size = compute_inner_temp_size (cblock->expr1, cblock->expr1,
6226 : : &inner_size_body, &lss, &rss);
6227 : :
6228 : 331 : gfc_free_ss_chain (lss);
6229 : 331 : gfc_free_ss_chain (rss);
6230 : :
6231 : : /* Calculate the total size of temporary needed. */
6232 : 331 : size = compute_overall_iter_number (nested_forall_info, inner_size,
6233 : : &inner_size_body, block);
6234 : :
6235 : : /* Check whether the size is negative. */
6236 : 331 : cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, size,
6237 : : gfc_index_zero_node);
6238 : 331 : size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
6239 : : cond, gfc_index_zero_node, size);
6240 : 331 : size = gfc_evaluate_now (size, block);
6241 : :
6242 : : /* Allocate temporary for WHERE mask if needed. */
6243 : 331 : if (need_cmask)
6244 : 331 : cmask = allocate_temp_for_forall_nest_1 (mask_type, size, block,
6245 : : &pcmask);
6246 : :
6247 : : /* Allocate temporary for !mask if needed. */
6248 : 331 : if (need_pmask)
6249 : 83 : pmask = allocate_temp_for_forall_nest_1 (mask_type, size, block,
6250 : : &ppmask);
6251 : : }
6252 : :
6253 : 994 : while (cblock)
6254 : : {
6255 : : /* Each time around this loop, the where clause is conditional
6256 : : on the value of mask and invert, which are updated at the
6257 : : bottom of the loop. */
6258 : :
6259 : : /* Has mask-expr. */
6260 : 645 : if (cblock->expr1)
6261 : : {
6262 : : /* Ensure that the WHERE mask will be evaluated exactly once.
6263 : : If there are no statements in this WHERE/ELSEWHERE clause,
6264 : : then we don't need to update the control mask (cmask).
6265 : : If this is the last clause of the WHERE construct, then
6266 : : we don't need to update the pending control mask (pmask). */
6267 : 527 : if (mask)
6268 : 234 : gfc_evaluate_where_mask (cblock->expr1, nested_forall_info,
6269 : : mask, invert,
6270 : 234 : cblock->next ? cmask : NULL_TREE,
6271 : 234 : cblock->block ? pmask : NULL_TREE,
6272 : : mask_type, block);
6273 : : else
6274 : 293 : gfc_evaluate_where_mask (cblock->expr1, nested_forall_info,
6275 : : NULL_TREE, false,
6276 : 293 : (cblock->next || cblock->block)
6277 : : ? cmask : NULL_TREE,
6278 : : NULL_TREE, mask_type, block);
6279 : :
6280 : : invert = false;
6281 : : }
6282 : : /* It's a final elsewhere-stmt. No mask-expr is present. */
6283 : : else
6284 : : cmask = mask;
6285 : :
6286 : : /* The body of this where clause are controlled by cmask with
6287 : : sense specified by invert. */
6288 : :
6289 : : /* Get the assignment statement of a WHERE statement, or the first
6290 : : statement in where-body-construct of a WHERE construct. */
6291 : 645 : cnext = cblock->next;
6292 : 1272 : while (cnext)
6293 : : {
6294 : 627 : switch (cnext->op)
6295 : : {
6296 : : /* WHERE assignment statement. */
6297 : 44 : case EXEC_ASSIGN_CALL:
6298 : :
6299 : 44 : arg = cnext->ext.actual;
6300 : 44 : expr1 = expr2 = NULL;
6301 : 132 : for (; arg; arg = arg->next)
6302 : : {
6303 : 88 : if (!arg->expr)
6304 : 0 : continue;
6305 : 88 : if (expr1 == NULL)
6306 : : expr1 = arg->expr;
6307 : : else
6308 : 44 : expr2 = arg->expr;
6309 : : }
6310 : 44 : goto evaluate;
6311 : :
6312 : 527 : case EXEC_ASSIGN:
6313 : 527 : expr1 = cnext->expr1;
6314 : 527 : expr2 = cnext->expr2;
6315 : 571 : evaluate:
6316 : 571 : if (nested_forall_info != NULL)
6317 : : {
6318 : 65 : need_temp = gfc_check_dependency (expr1, expr2, 0);
6319 : 65 : if ((need_temp || flag_test_forall_temp)
6320 : 28 : && cnext->op != EXEC_ASSIGN_CALL)
6321 : 27 : gfc_trans_assign_need_temp (expr1, expr2,
6322 : : cmask, invert,
6323 : : nested_forall_info, block);
6324 : : else
6325 : : {
6326 : : /* Variables to control maskexpr. */
6327 : 38 : count1 = gfc_create_var (gfc_array_index_type, "count1");
6328 : 38 : count2 = gfc_create_var (gfc_array_index_type, "count2");
6329 : 38 : gfc_add_modify (block, count1, gfc_index_zero_node);
6330 : 38 : gfc_add_modify (block, count2, gfc_index_zero_node);
6331 : :
6332 : 38 : tmp = gfc_trans_where_assign (expr1, expr2,
6333 : : cmask, invert,
6334 : : count1, count2,
6335 : : cnext);
6336 : :
6337 : 38 : tmp = gfc_trans_nested_forall_loop (nested_forall_info,
6338 : : tmp, 1);
6339 : 38 : gfc_add_expr_to_block (block, tmp);
6340 : : }
6341 : : }
6342 : : else
6343 : : {
6344 : : /* Variables to control maskexpr. */
6345 : 506 : count1 = gfc_create_var (gfc_array_index_type, "count1");
6346 : 506 : count2 = gfc_create_var (gfc_array_index_type, "count2");
6347 : 506 : gfc_add_modify (block, count1, gfc_index_zero_node);
6348 : 506 : gfc_add_modify (block, count2, gfc_index_zero_node);
6349 : :
6350 : 506 : tmp = gfc_trans_where_assign (expr1, expr2,
6351 : : cmask, invert,
6352 : : count1, count2,
6353 : : cnext);
6354 : 506 : gfc_add_expr_to_block (block, tmp);
6355 : :
6356 : : }
6357 : : break;
6358 : :
6359 : : /* WHERE or WHERE construct is part of a where-body-construct. */
6360 : 56 : case EXEC_WHERE:
6361 : 56 : gfc_trans_where_2 (cnext, cmask, invert,
6362 : : nested_forall_info, block);
6363 : 56 : break;
6364 : :
6365 : 0 : default:
6366 : 0 : gcc_unreachable ();
6367 : : }
6368 : :
6369 : : /* The next statement within the same where-body-construct. */
6370 : 627 : cnext = cnext->next;
6371 : : }
6372 : : /* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt. */
6373 : 645 : cblock = cblock->block;
6374 : 645 : if (mask == NULL_TREE)
6375 : : {
6376 : : /* If we're the initial WHERE, we can simply invert the sense
6377 : : of the current mask to obtain the "mask" for the remaining
6378 : : ELSEWHEREs. */
6379 : : invert = true;
6380 : : mask = cmask;
6381 : : }
6382 : : else
6383 : : {
6384 : : /* Otherwise, for nested WHERE's we need to use the pending mask. */
6385 : 343 : invert = false;
6386 : 343 : mask = pmask;
6387 : : }
6388 : : }
6389 : :
6390 : : /* If we allocated a pending mask array, deallocate it now. */
6391 : 349 : if (ppmask)
6392 : : {
6393 : 1 : tmp = gfc_call_free (ppmask);
6394 : 1 : gfc_add_expr_to_block (block, tmp);
6395 : : }
6396 : :
6397 : : /* If we allocated a current mask array, deallocate it now. */
6398 : 349 : if (pcmask)
6399 : : {
6400 : 43 : tmp = gfc_call_free (pcmask);
6401 : 43 : gfc_add_expr_to_block (block, tmp);
6402 : : }
6403 : 349 : }
6404 : :
6405 : : /* Translate a simple WHERE construct or statement without dependencies.
6406 : : CBLOCK is the "then" clause of the WHERE statement, where CBLOCK->EXPR
6407 : : is the mask condition, and EBLOCK if non-NULL is the "else" clause.
6408 : : Currently both CBLOCK and EBLOCK are restricted to single assignments. */
6409 : :
6410 : : static tree
6411 : 94 : gfc_trans_where_3 (gfc_code * cblock, gfc_code * eblock)
6412 : : {
6413 : 94 : stmtblock_t block, body;
6414 : 94 : gfc_expr *cond, *tdst, *tsrc, *edst, *esrc;
6415 : 94 : tree tmp, cexpr, tstmt, estmt;
6416 : 94 : gfc_ss *css, *tdss, *tsss;
6417 : 94 : gfc_se cse, tdse, tsse, edse, esse;
6418 : 94 : gfc_loopinfo loop;
6419 : 94 : gfc_ss *edss = 0;
6420 : 94 : gfc_ss *esss = 0;
6421 : 94 : bool maybe_workshare = false;
6422 : :
6423 : : /* Allow the scalarizer to workshare simple where loops. */
6424 : 94 : if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_BODY))
6425 : : == OMPWS_WORKSHARE_FLAG)
6426 : : {
6427 : 13 : maybe_workshare = true;
6428 : 13 : ompws_flags |= OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY;
6429 : : }
6430 : :
6431 : 94 : cond = cblock->expr1;
6432 : 94 : tdst = cblock->next->expr1;
6433 : 94 : tsrc = cblock->next->expr2;
6434 : 94 : edst = eblock ? eblock->next->expr1 : NULL;
6435 : 13 : esrc = eblock ? eblock->next->expr2 : NULL;
6436 : :
6437 : 94 : gfc_start_block (&block);
6438 : 94 : gfc_init_loopinfo (&loop);
6439 : :
6440 : : /* Handle the condition. */
6441 : 94 : gfc_init_se (&cse, NULL);
6442 : 94 : css = gfc_walk_expr (cond);
6443 : 94 : gfc_add_ss_to_loop (&loop, css);
6444 : :
6445 : : /* Handle the then-clause. */
6446 : 94 : gfc_init_se (&tdse, NULL);
6447 : 94 : gfc_init_se (&tsse, NULL);
6448 : 94 : tdss = gfc_walk_expr (tdst);
6449 : 94 : tsss = gfc_walk_expr (tsrc);
6450 : 94 : if (tsss == gfc_ss_terminator)
6451 : : {
6452 : 58 : tsss = gfc_get_scalar_ss (gfc_ss_terminator, tsrc);
6453 : 58 : tsss->info->where = 1;
6454 : : }
6455 : 94 : gfc_add_ss_to_loop (&loop, tdss);
6456 : 94 : gfc_add_ss_to_loop (&loop, tsss);
6457 : :
6458 : 94 : if (eblock)
6459 : : {
6460 : : /* Handle the else clause. */
6461 : 13 : gfc_init_se (&edse, NULL);
6462 : 13 : gfc_init_se (&esse, NULL);
6463 : 13 : edss = gfc_walk_expr (edst);
6464 : 13 : esss = gfc_walk_expr (esrc);
6465 : 13 : if (esss == gfc_ss_terminator)
6466 : : {
6467 : 13 : esss = gfc_get_scalar_ss (gfc_ss_terminator, esrc);
6468 : 13 : esss->info->where = 1;
6469 : : }
6470 : 13 : gfc_add_ss_to_loop (&loop, edss);
6471 : 13 : gfc_add_ss_to_loop (&loop, esss);
6472 : : }
6473 : :
6474 : 94 : gfc_conv_ss_startstride (&loop);
6475 : 94 : gfc_conv_loop_setup (&loop, &tdst->where);
6476 : :
6477 : 94 : gfc_mark_ss_chain_used (css, 1);
6478 : 94 : gfc_mark_ss_chain_used (tdss, 1);
6479 : 94 : gfc_mark_ss_chain_used (tsss, 1);
6480 : 94 : if (eblock)
6481 : : {
6482 : 13 : gfc_mark_ss_chain_used (edss, 1);
6483 : 13 : gfc_mark_ss_chain_used (esss, 1);
6484 : : }
6485 : :
6486 : 94 : gfc_start_scalarized_body (&loop, &body);
6487 : :
6488 : 94 : gfc_copy_loopinfo_to_se (&cse, &loop);
6489 : 94 : gfc_copy_loopinfo_to_se (&tdse, &loop);
6490 : 94 : gfc_copy_loopinfo_to_se (&tsse, &loop);
6491 : 94 : cse.ss = css;
6492 : 94 : tdse.ss = tdss;
6493 : 94 : tsse.ss = tsss;
6494 : 94 : if (eblock)
6495 : : {
6496 : 13 : gfc_copy_loopinfo_to_se (&edse, &loop);
6497 : 13 : gfc_copy_loopinfo_to_se (&esse, &loop);
6498 : 13 : edse.ss = edss;
6499 : 13 : esse.ss = esss;
6500 : : }
6501 : :
6502 : 94 : gfc_conv_expr (&cse, cond);
6503 : 94 : gfc_add_block_to_block (&body, &cse.pre);
6504 : 94 : cexpr = cse.expr;
6505 : :
6506 : 94 : gfc_conv_expr (&tsse, tsrc);
6507 : 94 : if (tdss != gfc_ss_terminator && loop.temp_ss != NULL)
6508 : 0 : gfc_conv_tmp_array_ref (&tdse);
6509 : : else
6510 : 94 : gfc_conv_expr (&tdse, tdst);
6511 : :
6512 : 94 : if (eblock)
6513 : : {
6514 : 13 : gfc_conv_expr (&esse, esrc);
6515 : 13 : if (edss != gfc_ss_terminator && loop.temp_ss != NULL)
6516 : 0 : gfc_conv_tmp_array_ref (&edse);
6517 : : else
6518 : 13 : gfc_conv_expr (&edse, edst);
6519 : : }
6520 : :
6521 : 94 : tstmt = gfc_trans_scalar_assign (&tdse, &tsse, tdst->ts, false, true);
6522 : 94 : estmt = eblock ? gfc_trans_scalar_assign (&edse, &esse, edst->ts,
6523 : : false, true)
6524 : 81 : : build_empty_stmt (input_location);
6525 : 94 : tmp = build3_v (COND_EXPR, cexpr, tstmt, estmt);
6526 : 94 : gfc_add_expr_to_block (&body, tmp);
6527 : 94 : gfc_add_block_to_block (&body, &cse.post);
6528 : :
6529 : 94 : if (maybe_workshare)
6530 : 13 : ompws_flags &= ~OMPWS_SCALARIZER_BODY;
6531 : 94 : gfc_trans_scalarizing_loops (&loop, &body);
6532 : 94 : gfc_add_block_to_block (&block, &loop.pre);
6533 : 94 : gfc_add_block_to_block (&block, &loop.post);
6534 : 94 : gfc_cleanup_loop (&loop);
6535 : :
6536 : 94 : return gfc_finish_block (&block);
6537 : : }
6538 : :
6539 : : /* As the WHERE or WHERE construct statement can be nested, we call
6540 : : gfc_trans_where_2 to do the translation, and pass the initial
6541 : : NULL values for both the control mask and the pending control mask. */
6542 : :
6543 : : tree
6544 : 341 : gfc_trans_where (gfc_code * code)
6545 : : {
6546 : 341 : stmtblock_t block;
6547 : 341 : gfc_code *cblock;
6548 : 341 : gfc_code *eblock;
6549 : :
6550 : 341 : cblock = code->block;
6551 : 341 : if (cblock->next
6552 : 314 : && cblock->next->op == EXEC_ASSIGN
6553 : 269 : && !cblock->next->next)
6554 : : {
6555 : 267 : eblock = cblock->block;
6556 : 267 : if (!eblock)
6557 : : {
6558 : : /* A simple "WHERE (cond) x = y" statement or block is
6559 : : dependence free if cond is not dependent upon writing x,
6560 : : and the source y is unaffected by the destination x. */
6561 : 162 : if (!gfc_check_dependency (cblock->next->expr1,
6562 : : cblock->expr1, 0)
6563 : 268 : && !gfc_check_dependency (cblock->next->expr1,
6564 : 106 : cblock->next->expr2, 0))
6565 : 81 : return gfc_trans_where_3 (cblock, NULL);
6566 : : }
6567 : 105 : else if (!eblock->expr1
6568 : 35 : && !eblock->block
6569 : 35 : && eblock->next
6570 : 26 : && eblock->next->op == EXEC_ASSIGN
6571 : 25 : && !eblock->next->next)
6572 : : {
6573 : : /* A simple "WHERE (cond) x1 = y1 ELSEWHERE x2 = y2 ENDWHERE"
6574 : : block is dependence free if cond is not dependent on writes
6575 : : to x1 and x2, y1 is not dependent on writes to x2, and y2
6576 : : is not dependent on writes to x1, and both y's are not
6577 : : dependent upon their own x's. In addition to this, the
6578 : : final two dependency checks below exclude all but the same
6579 : : array reference if the where and elswhere destinations
6580 : : are the same. In short, this is VERY conservative and this
6581 : : is needed because the two loops, required by the standard
6582 : : are coalesced in gfc_trans_where_3. */
6583 : 25 : if (!gfc_check_dependency (cblock->next->expr1,
6584 : : cblock->expr1, 0)
6585 : 25 : && !gfc_check_dependency (eblock->next->expr1,
6586 : : cblock->expr1, 0)
6587 : 25 : && !gfc_check_dependency (cblock->next->expr1,
6588 : 25 : eblock->next->expr2, 1)
6589 : 19 : && !gfc_check_dependency (eblock->next->expr1,
6590 : 19 : cblock->next->expr2, 1)
6591 : 19 : && !gfc_check_dependency (cblock->next->expr1,
6592 : 19 : cblock->next->expr2, 1)
6593 : 19 : && !gfc_check_dependency (eblock->next->expr1,
6594 : 19 : eblock->next->expr2, 1)
6595 : 19 : && !gfc_check_dependency (cblock->next->expr1,
6596 : 19 : eblock->next->expr1, 0)
6597 : 44 : && !gfc_check_dependency (eblock->next->expr1,
6598 : 19 : cblock->next->expr1, 0))
6599 : 13 : return gfc_trans_where_3 (cblock, eblock);
6600 : : }
6601 : : }
6602 : :
6603 : 247 : gfc_start_block (&block);
6604 : :
6605 : 247 : gfc_trans_where_2 (code, NULL, false, NULL, &block);
6606 : :
6607 : 247 : return gfc_finish_block (&block);
6608 : : }
6609 : :
6610 : :
6611 : : /* CYCLE a DO loop. The label decl has already been created by
6612 : : gfc_trans_do(), it's in TREE_PURPOSE (backend_decl) of the gfc_code
6613 : : node at the head of the loop. We must mark the label as used. */
6614 : :
6615 : : tree
6616 : 118 : gfc_trans_cycle (gfc_code * code)
6617 : : {
6618 : 118 : tree cycle_label;
6619 : :
6620 : 118 : cycle_label = code->ext.which_construct->cycle_label;
6621 : 118 : gcc_assert (cycle_label);
6622 : :
6623 : 118 : TREE_USED (cycle_label) = 1;
6624 : 118 : return build1_v (GOTO_EXPR, cycle_label);
6625 : : }
6626 : :
6627 : :
6628 : : /* EXIT a DO loop. Similar to CYCLE, but now the label is in
6629 : : TREE_VALUE (backend_decl) of the gfc_code node at the head of the
6630 : : loop. */
6631 : :
6632 : : tree
6633 : 682 : gfc_trans_exit (gfc_code * code)
6634 : : {
6635 : 682 : tree exit_label;
6636 : :
6637 : 682 : exit_label = code->ext.which_construct->exit_label;
6638 : 682 : gcc_assert (exit_label);
6639 : :
6640 : 682 : TREE_USED (exit_label) = 1;
6641 : 682 : return build1_v (GOTO_EXPR, exit_label);
6642 : : }
6643 : :
6644 : :
6645 : : /* Get the initializer expression for the code and expr of an allocate.
6646 : : When no initializer is needed return NULL. */
6647 : :
6648 : : static gfc_expr *
6649 : 13055 : allocate_get_initializer (gfc_code * code, gfc_expr * expr)
6650 : : {
6651 : 13055 : if (!gfc_bt_struct (expr->ts.type) && expr->ts.type != BT_CLASS)
6652 : : return NULL;
6653 : :
6654 : : /* An explicit type was given in allocate ( T:: object). */
6655 : 3728 : if (code->ext.alloc.ts.type == BT_DERIVED
6656 : 3728 : && (code->ext.alloc.ts.u.derived->attr.alloc_comp
6657 : 511 : || gfc_has_default_initializer (code->ext.alloc.ts.u.derived)))
6658 : 351 : return gfc_default_initializer (&code->ext.alloc.ts);
6659 : :
6660 : 557 : if (gfc_bt_struct (expr->ts.type)
6661 : 3377 : && (expr->ts.u.derived->attr.alloc_comp
6662 : 1878 : || gfc_has_default_initializer (expr->ts.u.derived)))
6663 : 1395 : return gfc_default_initializer (&expr->ts);
6664 : :
6665 : 1982 : if (expr->ts.type == BT_CLASS
6666 : 1982 : && (CLASS_DATA (expr)->ts.u.derived->attr.alloc_comp
6667 : 467 : || gfc_has_default_initializer (CLASS_DATA (expr)->ts.u.derived)))
6668 : 173 : return gfc_default_initializer (&CLASS_DATA (expr)->ts);
6669 : :
6670 : : return NULL;
6671 : : }
6672 : :
6673 : : /* Translate the ALLOCATE statement. */
6674 : :
6675 : : tree
6676 : 13855 : gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate)
6677 : : {
6678 : 13855 : gfc_alloc *al;
6679 : 13855 : gfc_expr *expr, *e3rhs = NULL, *init_expr;
6680 : 13855 : gfc_se se, se_sz;
6681 : 13855 : tree tmp;
6682 : 13855 : tree parm;
6683 : 13855 : tree stat;
6684 : 13855 : tree errmsg;
6685 : 13855 : tree errlen;
6686 : 13855 : tree label_errmsg;
6687 : 13855 : tree label_finish;
6688 : 13855 : tree memsz;
6689 : 13855 : tree al_vptr, al_len;
6690 : : /* If an expr3 is present, then store the tree for accessing its
6691 : : _vptr, and _len components in the variables, respectively. The
6692 : : element size, i.e. _vptr%size, is stored in expr3_esize. Any of
6693 : : the trees may be the NULL_TREE indicating that this is not
6694 : : available for expr3's type. */
6695 : 13855 : tree expr3, expr3_vptr, expr3_len, expr3_esize;
6696 : : /* Classify what expr3 stores. */
6697 : 13855 : enum { E3_UNSET = 0, E3_SOURCE, E3_MOLD, E3_DESC } e3_is;
6698 : 13855 : stmtblock_t block;
6699 : 13855 : stmtblock_t post;
6700 : 13855 : stmtblock_t final_block;
6701 : 13855 : bool upoly_expr, tmp_expr3_len_flag = false, al_len_needs_set, is_coarray;
6702 : 13855 : bool needs_caf_sync, caf_refs_comp;
6703 : 13855 : bool e3_has_nodescriptor = false;
6704 : 13855 : gfc_symtree *newsym = NULL;
6705 : 13855 : symbol_attribute caf_attr;
6706 : 13855 : gfc_actual_arglist *param_list;
6707 : 13855 : tree ts_string_length = NULL_TREE;
6708 : :
6709 : 13855 : if (!code->ext.alloc.list)
6710 : : return NULL_TREE;
6711 : :
6712 : 13855 : stat = tmp = memsz = al_vptr = al_len = NULL_TREE;
6713 : 13855 : expr3 = expr3_vptr = expr3_len = expr3_esize = NULL_TREE;
6714 : 13855 : label_errmsg = label_finish = errmsg = errlen = NULL_TREE;
6715 : 13855 : e3_is = E3_UNSET;
6716 : 13855 : is_coarray = needs_caf_sync = false;
6717 : :
6718 : 13855 : gfc_init_block (&block);
6719 : 13855 : gfc_init_block (&post);
6720 : 13855 : gfc_init_block (&final_block);
6721 : :
6722 : : /* STAT= (and maybe ERRMSG=) is present. */
6723 : 13855 : if (code->expr1)
6724 : : {
6725 : : /* STAT=. */
6726 : 278 : tree gfc_int4_type_node = gfc_get_int_type (4);
6727 : 278 : stat = gfc_create_var (gfc_int4_type_node, "stat");
6728 : :
6729 : : /* ERRMSG= only makes sense with STAT=. */
6730 : 278 : if (code->expr2)
6731 : : {
6732 : 68 : gfc_init_se (&se, NULL);
6733 : 68 : se.want_pointer = 1;
6734 : 68 : gfc_conv_expr_lhs (&se, code->expr2);
6735 : 68 : errmsg = se.expr;
6736 : 68 : errlen = se.string_length;
6737 : : }
6738 : : else
6739 : : {
6740 : 210 : errmsg = null_pointer_node;
6741 : 210 : errlen = build_int_cst (gfc_charlen_type_node, 0);
6742 : : }
6743 : :
6744 : : /* GOTO destinations. */
6745 : 278 : label_errmsg = gfc_build_label_decl (NULL_TREE);
6746 : 278 : label_finish = gfc_build_label_decl (NULL_TREE);
6747 : 278 : TREE_USED (label_finish) = 0;
6748 : : }
6749 : :
6750 : : /* When an expr3 is present evaluate it only once. The standards prevent a
6751 : : dependency of expr3 on the objects in the allocate list. An expr3 can
6752 : : be pre-evaluated in all cases. One just has to make sure, to use the
6753 : : correct way, i.e., to get the descriptor or to get a reference
6754 : : expression. */
6755 : 13855 : if (code->expr3)
6756 : : {
6757 : 3767 : bool vtab_needed = false, temp_var_needed = false,
6758 : 3767 : temp_obj_created = false;
6759 : :
6760 : 3767 : is_coarray = gfc_is_coarray (code->expr3);
6761 : :
6762 : 279 : if (code->expr3->expr_type == EXPR_FUNCTION && !code->expr3->mold
6763 : 4010 : && (gfc_is_class_array_function (code->expr3)
6764 : 213 : || gfc_is_alloc_class_scalar_function (code->expr3)))
6765 : 78 : code->expr3->must_finalize = 1;
6766 : :
6767 : : /* Figure whether we need the vtab from expr3. */
6768 : 7546 : for (al = code->ext.alloc.list; !vtab_needed && al != NULL;
6769 : 3779 : al = al->next)
6770 : 3779 : vtab_needed = (al->expr->ts.type == BT_CLASS);
6771 : :
6772 : 3767 : gfc_init_se (&se, NULL);
6773 : : /* When expr3 is a variable, i.e., a very simple expression, then
6774 : : convert it once here. If one has a source expression that has
6775 : : substring references, part-refs, or %re/%im inquiries, wrap the
6776 : : entity in parentheses to force evaluation of the expression. */
6777 : 3767 : if (code->expr3->expr_type == EXPR_VARIABLE
6778 : 3767 : && is_subref_array (code->expr3))
6779 : 60 : code->expr3 = gfc_get_parentheses (code->expr3);
6780 : :
6781 : 3767 : if (code->expr3->expr_type == EXPR_VARIABLE
6782 : 2483 : || code->expr3->expr_type == EXPR_ARRAY
6783 : 1459 : || code->expr3->expr_type == EXPR_CONSTANT)
6784 : : {
6785 : 2725 : if (!code->expr3->mold
6786 : 232 : || code->expr3->ts.type == BT_CHARACTER
6787 : 104 : || vtab_needed
6788 : 69 : || code->ext.alloc.arr_spec_from_expr3)
6789 : : {
6790 : : /* Convert expr3 to a tree. For all "simple" expression just
6791 : : get the descriptor or the reference, respectively, depending
6792 : : on the rank of the expr. */
6793 : 2725 : if (code->ext.alloc.arr_spec_from_expr3 || code->expr3->rank != 0)
6794 : 1580 : gfc_conv_expr_descriptor (&se, code->expr3);
6795 : : else
6796 : : {
6797 : 1145 : gfc_conv_expr_reference (&se, code->expr3);
6798 : :
6799 : : /* gfc_conv_expr_reference wraps POINTER_PLUS_EXPR in a
6800 : : NOP_EXPR, which prevents gfortran from getting the vptr
6801 : : from the source=-expression. Remove the NOP_EXPR and go
6802 : : with the POINTER_PLUS_EXPR in this case. */
6803 : 1145 : if (code->expr3->ts.type == BT_CLASS
6804 : 256 : && TREE_CODE (se.expr) == NOP_EXPR
6805 : 1301 : && (TREE_CODE (TREE_OPERAND (se.expr, 0))
6806 : : == POINTER_PLUS_EXPR
6807 : 138 : || is_coarray))
6808 : 30 : se.expr = TREE_OPERAND (se.expr, 0);
6809 : : }
6810 : : /* Create a temp variable only for component refs to prevent
6811 : : having to go through the full deref-chain each time and to
6812 : : simplify computation of array properties. */
6813 : 2725 : temp_var_needed = TREE_CODE (se.expr) == COMPONENT_REF;
6814 : : }
6815 : : }
6816 : : else
6817 : : {
6818 : : /* In all other cases evaluate the expr3. */
6819 : 1042 : symbol_attribute attr;
6820 : : /* Get the descriptor for all arrays, that are not allocatable or
6821 : : pointer, because the latter are descriptors already.
6822 : : The exception are function calls returning a class object:
6823 : : The descriptor is stored in their results _data component, which
6824 : : is easier to access, when first a temporary variable for the
6825 : : result is created and the descriptor retrieved from there. */
6826 : 1042 : attr = gfc_expr_attr (code->expr3);
6827 : 1042 : if (code->expr3->rank != 0
6828 : 248 : && ((!attr.allocatable && !attr.pointer)
6829 : 71 : || (code->expr3->expr_type == EXPR_FUNCTION
6830 : 71 : && (code->expr3->ts.type != BT_CLASS
6831 : 53 : || (code->expr3->value.function.isym
6832 : 12 : && code->expr3->value.function.isym
6833 : 12 : ->transformational)))))
6834 : 207 : gfc_conv_expr_descriptor (&se, code->expr3);
6835 : : else
6836 : 835 : gfc_conv_expr_reference (&se, code->expr3);
6837 : 1042 : if (code->expr3->ts.type == BT_CLASS)
6838 : 132 : gfc_conv_class_to_class (&se, code->expr3,
6839 : : code->expr3->ts,
6840 : : false, true,
6841 : : false, false);
6842 : 1042 : temp_obj_created = temp_var_needed = !VAR_P (se.expr);
6843 : : }
6844 : 3767 : gfc_add_block_to_block (&block, &se.pre);
6845 : 3767 : if (code->expr3->must_finalize)
6846 : : {
6847 : 78 : gfc_add_block_to_block (&final_block, &se.finalblock);
6848 : 78 : gfc_add_block_to_block (&final_block, &se.post);
6849 : : }
6850 : : else
6851 : 3689 : gfc_add_block_to_block (&post, &se.post);
6852 : :
6853 : : /* Special case when string in expr3 is scalar and has length zero. */
6854 : 3767 : if (code->expr3->ts.type == BT_CHARACTER
6855 : 841 : && code->expr3->rank == 0
6856 : 4261 : && integer_zerop (se.string_length))
6857 : : {
6858 : 6 : gfc_init_se (&se, NULL);
6859 : 6 : temp_var_needed = false;
6860 : 6 : expr3_len = build_zero_cst (gfc_charlen_type_node);
6861 : 6 : e3_is = E3_MOLD;
6862 : : }
6863 : : /* Prevent aliasing, i.e., se.expr may be already a
6864 : : variable declaration. */
6865 : 3761 : else if (se.expr != NULL_TREE && temp_var_needed)
6866 : : {
6867 : 908 : tree var, desc;
6868 : 908 : tmp = (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))
6869 : 846 : || is_coarray
6870 : 834 : || (code->expr3->ts.type == BT_CHARACTER
6871 : 930 : && code->expr3->rank == 0)) ?
6872 : : se.expr
6873 : 812 : : build_fold_indirect_ref_loc (input_location, se.expr);
6874 : :
6875 : : /* Get the array descriptor and prepare it to be assigned to the
6876 : : temporary variable var. For classes the array descriptor is
6877 : : in the _data component and the object goes into the
6878 : : GFC_DECL_SAVED_DESCRIPTOR. */
6879 : 908 : if (code->expr3->ts.type == BT_CLASS
6880 : 187 : && code->expr3->rank != 0)
6881 : : {
6882 : : /* When an array_ref was in expr3, then the descriptor is the
6883 : : first operand. */
6884 : 96 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)) || is_coarray)
6885 : : {
6886 : 49 : desc = TREE_OPERAND (tmp, 0);
6887 : : }
6888 : : else
6889 : : {
6890 : 47 : desc = tmp;
6891 : 47 : tmp = gfc_class_data_get (tmp);
6892 : : }
6893 : 96 : if (code->ext.alloc.arr_spec_from_expr3)
6894 : 39 : e3_is = E3_DESC;
6895 : : }
6896 : : else
6897 : 824 : desc = !is_coarray ? se.expr
6898 : 12 : : TREE_OPERAND (TREE_OPERAND (se.expr, 0), 0);
6899 : : /* We need a regular (non-UID) symbol here, therefore give a
6900 : : prefix. */
6901 : 908 : var = gfc_create_var (TREE_TYPE (tmp), "source");
6902 : 908 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)) || is_coarray)
6903 : : {
6904 : 121 : gfc_allocate_lang_decl (var);
6905 : 121 : GFC_DECL_SAVED_DESCRIPTOR (var) = desc;
6906 : : }
6907 : 908 : gfc_add_modify_loc (input_location, &block, var, tmp);
6908 : :
6909 : 908 : expr3 = var;
6910 : 908 : if (se.string_length)
6911 : : /* Evaluate it assuming that it also is complicated like expr3. */
6912 : 29 : expr3_len = gfc_evaluate_now (se.string_length, &block);
6913 : : }
6914 : : else
6915 : : {
6916 : 2853 : expr3 = se.expr;
6917 : 2853 : expr3_len = se.string_length;
6918 : : }
6919 : :
6920 : : /* Deallocate any allocatable components in expressions that use a
6921 : : temporary object, i.e. are not a simple alias of to an EXPR_VARIABLE.
6922 : : E.g. temporaries of a function call need freeing of their components
6923 : : here. Explicit derived type allocation of class entities uses expr3
6924 : : to carry the default initializer. This must not be deallocated or
6925 : : finalized. */
6926 : 3767 : if ((code->expr3->ts.type == BT_DERIVED
6927 : 2498 : || code->expr3->ts.type == BT_CLASS)
6928 : 1790 : && (code->expr3->expr_type != EXPR_VARIABLE || temp_obj_created)
6929 : 1205 : && code->expr3->ts.u.derived->attr.alloc_comp
6930 : 302 : && !code->expr3->must_finalize
6931 : 296 : && !code->ext.alloc.expr3_not_explicit)
6932 : : {
6933 : 216 : tmp = gfc_deallocate_alloc_comp (code->expr3->ts.u.derived,
6934 : : expr3, code->expr3->rank);
6935 : 216 : gfc_prepend_expr_to_block (&post, tmp);
6936 : : }
6937 : :
6938 : : /* Store what the expr3 is to be used for. */
6939 : 3767 : if (e3_is == E3_UNSET)
6940 : 6120 : e3_is = expr3 != NULL_TREE ?
6941 : 3722 : (code->ext.alloc.arr_spec_from_expr3 ?
6942 : : E3_DESC
6943 : 2571 : : (code->expr3->mold ? E3_MOLD : E3_SOURCE))
6944 : : : E3_UNSET;
6945 : :
6946 : : /* Figure how to get the _vtab entry. This also obtains the tree
6947 : : expression for accessing the _len component, because only
6948 : : unlimited polymorphic objects, which are a subcategory of class
6949 : : types, have a _len component. */
6950 : 3767 : if (code->expr3->ts.type == BT_CLASS)
6951 : : {
6952 : 521 : gfc_expr *rhs;
6953 : 777 : tmp = expr3 != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (expr3)) ?
6954 : 256 : build_fold_indirect_ref (expr3): expr3;
6955 : : /* Polymorphic SOURCE: VPTR must be determined at run time.
6956 : : expr3 may be a temporary array declaration, therefore check for
6957 : : GFC_CLASS_TYPE_P before trying to get the _vptr component. */
6958 : 521 : if (tmp != NULL_TREE
6959 : 521 : && (e3_is == E3_DESC
6960 : 440 : || (GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
6961 : 280 : && (VAR_P (tmp) || !code->expr3->ref))
6962 : 186 : || (VAR_P (tmp) && DECL_LANG_SPECIFIC (tmp))))
6963 : 440 : tmp = gfc_class_vptr_get (expr3);
6964 : : else
6965 : : {
6966 : 81 : rhs = gfc_find_and_cut_at_last_class_ref (code->expr3);
6967 : 81 : gfc_add_vptr_component (rhs);
6968 : 81 : gfc_init_se (&se, NULL);
6969 : 81 : se.want_pointer = 1;
6970 : 81 : gfc_conv_expr (&se, rhs);
6971 : 81 : tmp = se.expr;
6972 : 81 : gfc_free_expr (rhs);
6973 : : }
6974 : : /* Set the element size. */
6975 : 521 : expr3_esize = gfc_vptr_size_get (tmp);
6976 : 521 : if (vtab_needed)
6977 : 515 : expr3_vptr = tmp;
6978 : : /* Initialize the ref to the _len component. */
6979 : 521 : if (expr3_len == NULL_TREE && UNLIMITED_POLY (code->expr3))
6980 : : {
6981 : : /* Same like for retrieving the _vptr. */
6982 : 164 : if (expr3 != NULL_TREE && !code->expr3->ref)
6983 : 92 : expr3_len = gfc_class_len_get (expr3);
6984 : : else
6985 : : {
6986 : 72 : rhs = gfc_find_and_cut_at_last_class_ref (code->expr3);
6987 : 72 : gfc_add_len_component (rhs);
6988 : 72 : gfc_init_se (&se, NULL);
6989 : 72 : gfc_conv_expr (&se, rhs);
6990 : 72 : expr3_len = se.expr;
6991 : 72 : gfc_free_expr (rhs);
6992 : : }
6993 : : }
6994 : : }
6995 : : else
6996 : : {
6997 : : /* When the object to allocate is polymorphic type, then it
6998 : : needs its vtab set correctly, so deduce the required _vtab
6999 : : and _len from the source expression. */
7000 : 3246 : if (vtab_needed)
7001 : : {
7002 : : /* VPTR is fixed at compile time. */
7003 : 1194 : gfc_symbol *vtab;
7004 : :
7005 : 1194 : vtab = gfc_find_vtab (&code->expr3->ts);
7006 : 1194 : gcc_assert (vtab);
7007 : 1194 : expr3_vptr = gfc_get_symbol_decl (vtab);
7008 : 1194 : expr3_vptr = gfc_build_addr_expr (NULL_TREE,
7009 : : expr3_vptr);
7010 : : }
7011 : : /* _len component needs to be set, when ts is a character
7012 : : array. */
7013 : 3246 : if (expr3_len == NULL_TREE
7014 : 2405 : && code->expr3->ts.type == BT_CHARACTER)
7015 : : {
7016 : 0 : if (code->expr3->ts.u.cl
7017 : 0 : && code->expr3->ts.u.cl->length)
7018 : : {
7019 : 0 : gfc_init_se (&se, NULL);
7020 : 0 : gfc_conv_expr (&se, code->expr3->ts.u.cl->length);
7021 : 0 : gfc_add_block_to_block (&block, &se.pre);
7022 : 0 : expr3_len = gfc_evaluate_now (se.expr, &block);
7023 : : }
7024 : 0 : gcc_assert (expr3_len);
7025 : : }
7026 : : /* For character arrays only the kind's size is needed, because
7027 : : the array mem_size is _len * (elem_size = kind_size).
7028 : : For all other get the element size in the normal way. */
7029 : 3246 : if (code->expr3->ts.type == BT_CHARACTER)
7030 : 841 : expr3_esize = TYPE_SIZE_UNIT (
7031 : : gfc_get_char_type (code->expr3->ts.kind));
7032 : : else
7033 : 2405 : expr3_esize = TYPE_SIZE_UNIT (
7034 : : gfc_typenode_for_spec (&code->expr3->ts));
7035 : : }
7036 : 3767 : gcc_assert (expr3_esize);
7037 : 3767 : expr3_esize = fold_convert (sizetype, expr3_esize);
7038 : 3767 : if (e3_is == E3_MOLD)
7039 : : /* The expr3 is no longer valid after this point. */
7040 : 179 : expr3 = NULL_TREE;
7041 : : }
7042 : 10088 : else if (code->ext.alloc.ts.type != BT_UNKNOWN)
7043 : : {
7044 : : /* Compute the explicit typespec given only once for all objects
7045 : : to allocate. */
7046 : 1238 : if (code->ext.alloc.ts.type != BT_CHARACTER)
7047 : 792 : expr3_esize = TYPE_SIZE_UNIT (
7048 : : gfc_typenode_for_spec (&code->ext.alloc.ts));
7049 : 446 : else if (code->ext.alloc.ts.u.cl->length != NULL)
7050 : : {
7051 : 440 : gfc_expr *sz;
7052 : 440 : sz = gfc_copy_expr (code->ext.alloc.ts.u.cl->length);
7053 : 440 : gfc_init_se (&se_sz, NULL);
7054 : 440 : gfc_conv_expr (&se_sz, sz);
7055 : 440 : gfc_free_expr (sz);
7056 : 440 : ts_string_length = fold_convert (gfc_charlen_type_node, se_sz.expr);
7057 : 440 : tmp = gfc_get_char_type (code->ext.alloc.ts.kind);
7058 : 440 : tmp = TYPE_SIZE_UNIT (tmp);
7059 : 440 : tmp = fold_convert (TREE_TYPE (se_sz.expr), tmp);
7060 : 440 : gfc_add_block_to_block (&block, &se_sz.pre);
7061 : 440 : expr3_esize = fold_build2_loc (input_location, MULT_EXPR,
7062 : 440 : TREE_TYPE (se_sz.expr),
7063 : : tmp, se_sz.expr);
7064 : 440 : expr3_esize = gfc_evaluate_now (expr3_esize, &block);
7065 : : }
7066 : : else
7067 : : expr3_esize = NULL_TREE;
7068 : : }
7069 : :
7070 : : /* The routine gfc_trans_assignment () already implements all
7071 : : techniques needed. Unfortunately we may have a temporary
7072 : : variable for the source= expression here. When that is the
7073 : : case convert this variable into a temporary gfc_expr of type
7074 : : EXPR_VARIABLE and used it as rhs for the assignment. The
7075 : : advantage is, that we get scalarizer support for free,
7076 : : don't have to take care about scalar to array treatment and
7077 : : will benefit of every enhancements gfc_trans_assignment ()
7078 : : gets.
7079 : : No need to check whether e3_is is E3_UNSET, because that is
7080 : : done by expr3 != NULL_TREE.
7081 : : Exclude variables since the following block does not handle
7082 : : array sections. In any case, there is no harm in sending
7083 : : variables to gfc_trans_assignment because there is no
7084 : : evaluation of variables. */
7085 : 13855 : if (code->expr3)
7086 : : {
7087 : 3767 : if (code->expr3->expr_type != EXPR_VARIABLE
7088 : 2483 : && e3_is != E3_MOLD && expr3 != NULL_TREE
7089 : 6182 : && DECL_P (expr3) && DECL_ARTIFICIAL (expr3))
7090 : : {
7091 : : /* Build a temporary symtree and symbol. Do not add it to the current
7092 : : namespace to prevent accidentaly modifying a colliding
7093 : : symbol's as. */
7094 : 2032 : newsym = XCNEW (gfc_symtree);
7095 : : /* The name of the symtree should be unique, because gfc_create_var ()
7096 : : took care about generating the identifier. */
7097 : 2032 : newsym->name
7098 : 2032 : = gfc_get_string ("%s", IDENTIFIER_POINTER (DECL_NAME (expr3)));
7099 : 2032 : newsym->n.sym = gfc_new_symbol (newsym->name, NULL);
7100 : : /* The backend_decl is known. It is expr3, which is inserted
7101 : : here. */
7102 : 2032 : newsym->n.sym->backend_decl = expr3;
7103 : 2032 : e3rhs = gfc_get_expr ();
7104 : 2032 : e3rhs->rank = code->expr3->rank;
7105 : 2032 : e3rhs->corank = code->expr3->corank;
7106 : 2032 : e3rhs->symtree = newsym;
7107 : : /* Mark the symbol referenced or gfc_trans_assignment will bug. */
7108 : 2032 : newsym->n.sym->attr.referenced = 1;
7109 : 2032 : e3rhs->expr_type = EXPR_VARIABLE;
7110 : 2032 : e3rhs->where = code->expr3->where;
7111 : : /* Set the symbols type, upto it was BT_UNKNOWN. */
7112 : 2032 : if (IS_CLASS_ARRAY (code->expr3)
7113 : 54 : && code->expr3->expr_type == EXPR_FUNCTION
7114 : 42 : && code->expr3->value.function.isym
7115 : 12 : && code->expr3->value.function.isym->transformational)
7116 : : {
7117 : 12 : e3rhs->ts = CLASS_DATA (code->expr3)->ts;
7118 : : }
7119 : 2020 : else if (code->expr3->ts.type == BT_CLASS
7120 : 2020 : && !GFC_CLASS_TYPE_P (TREE_TYPE (expr3)))
7121 : 46 : e3rhs->ts = CLASS_DATA (code->expr3)->ts;
7122 : : else
7123 : 1974 : e3rhs->ts = code->expr3->ts;
7124 : 2032 : newsym->n.sym->ts = e3rhs->ts;
7125 : : /* Check whether the expr3 is array valued. */
7126 : 2032 : if (e3rhs->rank)
7127 : : {
7128 : 1265 : gfc_array_spec *arr;
7129 : 1265 : arr = gfc_get_array_spec ();
7130 : 1265 : arr->rank = e3rhs->rank;
7131 : 1265 : arr->corank = e3rhs->corank;
7132 : 1265 : arr->type = AS_DEFERRED;
7133 : : /* Set the dimension and pointer attribute for arrays
7134 : : to be on the safe side. */
7135 : 1265 : newsym->n.sym->attr.dimension = 1;
7136 : 1265 : newsym->n.sym->attr.pointer = 1;
7137 : 1265 : newsym->n.sym->as = arr;
7138 : 1265 : if (IS_CLASS_ARRAY (code->expr3)
7139 : 54 : && code->expr3->expr_type == EXPR_FUNCTION
7140 : 42 : && code->expr3->value.function.isym
7141 : 12 : && code->expr3->value.function.isym->transformational)
7142 : : {
7143 : 12 : gfc_array_spec *tarr;
7144 : 12 : tarr = gfc_get_array_spec ();
7145 : 12 : *tarr = *arr;
7146 : 12 : e3rhs->ts.u.derived->as = tarr;
7147 : : }
7148 : 1265 : gfc_add_full_array_ref (e3rhs, arr);
7149 : : }
7150 : 767 : else if (POINTER_TYPE_P (TREE_TYPE (expr3)))
7151 : 45 : newsym->n.sym->attr.pointer = 1;
7152 : : /* The string length is known, too. Set it for char arrays. */
7153 : 2032 : if (e3rhs->ts.type == BT_CHARACTER)
7154 : 329 : newsym->n.sym->ts.u.cl->backend_decl = expr3_len;
7155 : 2032 : gfc_commit_symbol (newsym->n.sym);
7156 : : }
7157 : : else
7158 : 1735 : e3rhs = gfc_copy_expr (code->expr3);
7159 : :
7160 : : // We need to propagate the bounds of the expr3 for source=/mold=.
7161 : : // However, for non-named arrays, the lbound has to be 1 and neither the
7162 : : // bound used inside the called function even when returning an
7163 : : // allocatable/pointer nor the zero used internally.
7164 : 3767 : if (e3_is == E3_DESC
7165 : 1190 : && code->expr3->expr_type != EXPR_VARIABLE)
7166 : 13855 : e3_has_nodescriptor = true;
7167 : : }
7168 : :
7169 : : /* Loop over all objects to allocate. */
7170 : 30661 : for (al = code->ext.alloc.list; al != NULL; al = al->next)
7171 : : {
7172 : 16806 : expr = gfc_copy_expr (al->expr);
7173 : : /* UNLIMITED_POLY () needs the _data component to be set, when
7174 : : expr is a unlimited polymorphic object. But the _data component
7175 : : has not been set yet, so check the derived type's attr for the
7176 : : unlimited polymorphic flag to be safe. */
7177 : 16806 : upoly_expr = UNLIMITED_POLY (expr)
7178 : 33019 : || (expr->ts.type == BT_DERIVED
7179 : 2508 : && expr->ts.u.derived->attr.unlimited_polymorphic);
7180 : 16806 : gfc_init_se (&se, NULL);
7181 : :
7182 : : /* For class types prepare the expressions to ref the _vptr
7183 : : and the _len component. The latter for unlimited polymorphic
7184 : : types only. */
7185 : 16806 : if (expr->ts.type == BT_CLASS)
7186 : : {
7187 : 3449 : gfc_expr *expr_ref_vptr, *expr_ref_len;
7188 : 3449 : gfc_add_data_component (expr);
7189 : : /* Prep the vptr handle. */
7190 : 3449 : expr_ref_vptr = gfc_copy_expr (al->expr);
7191 : 3449 : gfc_add_vptr_component (expr_ref_vptr);
7192 : 3449 : se.want_pointer = 1;
7193 : 3449 : gfc_conv_expr (&se, expr_ref_vptr);
7194 : 3449 : al_vptr = se.expr;
7195 : 3449 : se.want_pointer = 0;
7196 : 3449 : gfc_free_expr (expr_ref_vptr);
7197 : : /* Allocated unlimited polymorphic objects always have a _len
7198 : : component. */
7199 : 3449 : if (upoly_expr)
7200 : : {
7201 : 593 : expr_ref_len = gfc_copy_expr (al->expr);
7202 : 593 : gfc_add_len_component (expr_ref_len);
7203 : 593 : gfc_conv_expr (&se, expr_ref_len);
7204 : 593 : al_len = se.expr;
7205 : 593 : gfc_free_expr (expr_ref_len);
7206 : : }
7207 : : else
7208 : : /* In a loop ensure that all loop variable dependent variables
7209 : : are initialized at the same spot in all execution paths. */
7210 : : al_len = NULL_TREE;
7211 : : }
7212 : : else
7213 : : al_vptr = al_len = NULL_TREE;
7214 : :
7215 : 16806 : se.want_pointer = 1;
7216 : 16806 : se.descriptor_only = 1;
7217 : :
7218 : 16806 : gfc_conv_expr (&se, expr);
7219 : 16806 : if (expr->ts.type == BT_CHARACTER && expr->ts.deferred)
7220 : : /* se.string_length now stores the .string_length variable of expr
7221 : : needed to allocate character(len=:) arrays. */
7222 : 1073 : al_len = se.string_length;
7223 : :
7224 : 16806 : al_len_needs_set = al_len != NULL_TREE;
7225 : : /* When allocating an array one cannot use much of the
7226 : : pre-evaluated expr3 expressions, because for most of them the
7227 : : scalarizer is needed which is not available in the pre-evaluation
7228 : : step. Therefore gfc_array_allocate () is responsible (and able)
7229 : : to handle the complete array allocation. Only the element size
7230 : : needs to be provided, which is done most of the time by the
7231 : : pre-evaluation step. */
7232 : 16806 : if (expr3_len && (code->expr3->ts.type == BT_CHARACTER
7233 : 1011 : || code->expr3->ts.type == BT_CLASS))
7234 : : {
7235 : : /* When al is an array, then the element size for each element
7236 : : in the array is needed, which is the product of the len and
7237 : : esize for char arrays. For unlimited polymorphics len can be
7238 : : zero, therefore take the maximum of len and one. */
7239 : 1011 : tree lhs_len;
7240 : :
7241 : : /* If an allocatable character variable has fixed length, use it.
7242 : : Otherwise use source length. As different lengths are not
7243 : : allowed by the standard, generate a runtime check. */
7244 : 1011 : if (expr->ts.type == BT_CHARACTER && !expr->ts.deferred)
7245 : : {
7246 : 135 : gfc_trans_same_strlen_check ("ALLOCATE with SOURCE= or MOLD=",
7247 : : &code->expr3->where,
7248 : : se.string_length, expr3_len,
7249 : : &block);
7250 : 135 : lhs_len = fold_convert (TREE_TYPE (expr3_len), se.string_length);
7251 : : }
7252 : : else
7253 : : lhs_len = expr3_len;
7254 : :
7255 : 2022 : tmp = fold_build2_loc (input_location, MAX_EXPR,
7256 : 1011 : TREE_TYPE (expr3_len),
7257 : 1011 : lhs_len, fold_convert (TREE_TYPE (expr3_len),
7258 : : integer_one_node));
7259 : 2022 : tmp = fold_build2_loc (input_location, MULT_EXPR,
7260 : 1011 : TREE_TYPE (expr3_esize), expr3_esize,
7261 : 1011 : fold_convert (TREE_TYPE (expr3_esize), tmp));
7262 : 1011 : }
7263 : : else
7264 : : tmp = expr3_esize;
7265 : :
7266 : : /* Create runtime check for ALLOCATE of character with type-spec. */
7267 : 16806 : if (expr->ts.type == BT_CHARACTER && !expr->ts.deferred
7268 : 761 : && ts_string_length
7269 : 19 : && se.string_length)
7270 : 19 : gfc_trans_same_strlen_check ("ALLOCATE with type-spec",
7271 : 19 : &al->expr->where,
7272 : : ts_string_length, se.string_length,
7273 : : &block);
7274 : :
7275 : 16806 : gfc_omp_namelist *omp_alloc_item = NULL;
7276 : 16806 : if (omp_allocate)
7277 : : {
7278 : : gfc_omp_namelist *n = NULL;
7279 : : gfc_omp_namelist *n_null = NULL;
7280 : 130 : for (n = omp_allocate; n; n = n->next)
7281 : : {
7282 : 88 : if (n->sym == NULL)
7283 : : {
7284 : 41 : n_null = n;
7285 : 41 : continue;
7286 : : }
7287 : 47 : if (expr->expr_type == EXPR_VARIABLE
7288 : 47 : && expr->symtree->n.sym == n->sym)
7289 : : {
7290 : 25 : gfc_ref *ref;
7291 : 38 : for (ref = expr->ref; ref; ref = ref->next)
7292 : 16 : if (ref->type == REF_COMPONENT)
7293 : : break;
7294 : : if (ref == NULL)
7295 : : break;
7296 : : }
7297 : : }
7298 : 64 : omp_alloc_item = n ? n : n_null;
7299 : :
7300 : : }
7301 : :
7302 : 16806 : if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, label_finish,
7303 : : tmp, e3rhs ? e3rhs : code->expr3,
7304 : : e3_is == E3_DESC ? expr3 : NULL_TREE,
7305 : : e3_has_nodescriptor, omp_alloc_item,
7306 : 16806 : code->ext.alloc.ts.type != BT_UNKNOWN))
7307 : : {
7308 : : /* A scalar or derived type. First compute the size to
7309 : : allocate.
7310 : :
7311 : : expr3_len is set when expr3 is an unlimited polymorphic
7312 : : object or a deferred length string.
7313 : :
7314 : : If an allocatable character variable has fixed length, use it.
7315 : : Otherwise use source length. As different lengths are not
7316 : : allowed by the standard, a runtime check was inserted
7317 : : above. */
7318 : 5078 : if (expr3_len != NULL_TREE)
7319 : : {
7320 : 537 : tree lhs_len;
7321 : 537 : if (expr->ts.type == BT_CHARACTER && !expr->ts.deferred)
7322 : 56 : lhs_len = fold_convert (TREE_TYPE (expr3_len),
7323 : : se.string_length);
7324 : : else
7325 : : lhs_len = expr3_len;
7326 : :
7327 : 537 : tmp = fold_convert (TREE_TYPE (expr3_esize), lhs_len);
7328 : 537 : tmp = fold_build2_loc (input_location, MULT_EXPR,
7329 : 537 : TREE_TYPE (expr3_esize),
7330 : : expr3_esize, tmp);
7331 : 537 : if (code->expr3->ts.type != BT_CLASS)
7332 : : /* expr3 is a deferred length string, i.e., we are
7333 : : done. */
7334 : : memsz = tmp;
7335 : : else
7336 : : {
7337 : : /* For unlimited polymorphic enties build
7338 : : (len > 0) ? element_size * len : element_size
7339 : : to compute the number of bytes to allocate.
7340 : : This allows the allocation of unlimited polymorphic
7341 : : objects from an expr3 that is also unlimited
7342 : : polymorphic and stores a _len dependent object,
7343 : : e.g., a string. */
7344 : 98 : memsz = fold_build2_loc (input_location, GT_EXPR,
7345 : : logical_type_node, expr3_len,
7346 : : build_zero_cst
7347 : 98 : (TREE_TYPE (expr3_len)));
7348 : 98 : memsz = fold_build3_loc (input_location, COND_EXPR,
7349 : 98 : TREE_TYPE (expr3_esize),
7350 : : memsz, tmp, expr3_esize);
7351 : : }
7352 : : }
7353 : 4541 : else if (expr3_esize != NULL_TREE)
7354 : : /* Any other object in expr3 just needs element size in
7355 : : bytes. */
7356 : : memsz = expr3_esize;
7357 : 2769 : else if ((expr->ts.type == BT_CHARACTER && expr->ts.deferred)
7358 : 2769 : || (upoly_expr
7359 : 0 : && code->ext.alloc.ts.type == BT_CHARACTER))
7360 : : {
7361 : : /* Allocating deferred length char arrays need the length
7362 : : to allocate in the alloc_type_spec. But also unlimited
7363 : : polymorphic objects may be allocated as char arrays.
7364 : : Both are handled here. */
7365 : 0 : gfc_init_se (&se_sz, NULL);
7366 : 0 : gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length);
7367 : 0 : gfc_add_block_to_block (&se.pre, &se_sz.pre);
7368 : 0 : se_sz.expr = gfc_evaluate_now (se_sz.expr, &se.pre);
7369 : 0 : gfc_add_block_to_block (&se.pre, &se_sz.post);
7370 : 0 : expr3_len = se_sz.expr;
7371 : 0 : tmp_expr3_len_flag = true;
7372 : 0 : tmp = TYPE_SIZE_UNIT (
7373 : : gfc_get_char_type (code->ext.alloc.ts.kind));
7374 : 0 : memsz = fold_build2_loc (input_location, MULT_EXPR,
7375 : 0 : TREE_TYPE (tmp),
7376 : 0 : fold_convert (TREE_TYPE (tmp),
7377 : : expr3_len),
7378 : : tmp);
7379 : : }
7380 : 2769 : else if (expr->ts.type == BT_CHARACTER)
7381 : : {
7382 : : /* Compute the number of bytes needed to allocate a fixed
7383 : : length char array. */
7384 : 164 : gcc_assert (se.string_length != NULL_TREE);
7385 : 164 : tmp = TYPE_SIZE_UNIT (gfc_get_char_type (expr->ts.kind));
7386 : 328 : memsz = fold_build2_loc (input_location, MULT_EXPR,
7387 : 164 : TREE_TYPE (tmp), tmp,
7388 : 164 : fold_convert (TREE_TYPE (tmp),
7389 : : se.string_length));
7390 : : }
7391 : 2605 : else if (code->ext.alloc.ts.type != BT_UNKNOWN)
7392 : : /* Handle all types, where the alloc_type_spec is set. */
7393 : 0 : memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts));
7394 : : else
7395 : : /* Handle size computation of the type declared to alloc. */
7396 : 2605 : memsz = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr)));
7397 : :
7398 : 5078 : bool use_coarray_alloc
7399 : 5078 : = (flag_coarray == GFC_FCOARRAY_LIB
7400 : 5078 : && (caf_attr = gfc_caf_attr (expr, true, &caf_refs_comp))
7401 : 70 : .codimension);
7402 : 5078 : tree omp_cond = NULL_TREE;
7403 : 5078 : tree omp_alt_alloc = NULL_TREE;
7404 : 5078 : tree succ_add_expr = NULL_TREE;
7405 : 5078 : if (!use_coarray_alloc && omp_alloc_item)
7406 : : {
7407 : 28 : tree align, alloc, sz;
7408 : 28 : gfc_se se2;
7409 : :
7410 : 28 : omp_cond = boolean_true_node;
7411 : 28 : if (omp_alloc_item->u2.allocator)
7412 : : {
7413 : 2 : gfc_init_se (&se2, NULL);
7414 : 2 : gfc_conv_expr (&se2, omp_alloc_item->u2.allocator);
7415 : 2 : gfc_add_block_to_block (&se.pre, &se2.pre);
7416 : 2 : alloc = gfc_evaluate_now (se2.expr, &se.pre);
7417 : 2 : gfc_add_block_to_block (&se.pre, &se2.post);
7418 : : }
7419 : : else
7420 : 26 : alloc = build_zero_cst (ptr_type_node);
7421 : 28 : tmp = TREE_TYPE (TREE_TYPE (se.expr));
7422 : 28 : if (tmp == void_type_node)
7423 : 3 : tmp = gfc_typenode_for_spec (&expr->ts, 0);
7424 : 28 : if (omp_alloc_item->u.align)
7425 : : {
7426 : 14 : gfc_init_se (&se2, NULL);
7427 : 14 : gfc_conv_expr (&se2, omp_alloc_item->u.align);
7428 : 14 : gcc_assert (CONSTANT_CLASS_P (se2.expr)
7429 : : && se2.pre.head == NULL
7430 : : && se2.post.head == NULL);
7431 : 14 : align = build_int_cst (size_type_node,
7432 : 14 : MAX (tree_to_uhwi (se2.expr),
7433 : : TYPE_ALIGN_UNIT (tmp)));
7434 : : }
7435 : : else
7436 : 14 : align = build_int_cst (size_type_node, TYPE_ALIGN_UNIT (tmp));
7437 : 28 : sz = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
7438 : : fold_convert (size_type_node, memsz),
7439 : : build_int_cst (size_type_node, 1));
7440 : 28 : omp_alt_alloc = builtin_decl_explicit (BUILT_IN_GOMP_ALLOC);
7441 : 28 : DECL_ATTRIBUTES (omp_alt_alloc)
7442 : 28 : = tree_cons (get_identifier ("omp allocator"),
7443 : : build_tree_list (NULL_TREE, alloc),
7444 : 28 : DECL_ATTRIBUTES (omp_alt_alloc));
7445 : 28 : omp_alt_alloc = build_call_expr (omp_alt_alloc, 3, align, sz, alloc);
7446 : 28 : succ_add_expr = gfc_omp_call_add_alloc (se.expr);
7447 : : }
7448 : :
7449 : : /* Store the caf-attributes for latter use. */
7450 : 5078 : if (use_coarray_alloc)
7451 : : {
7452 : : /* Scalar allocatable components in coarray'ed derived types make
7453 : : it here and are treated now. */
7454 : 65 : tree caf_decl, token;
7455 : 65 : gfc_se caf_se;
7456 : :
7457 : 65 : is_coarray = true;
7458 : : /* Set flag, to add synchronize after the allocate. */
7459 : 130 : needs_caf_sync = needs_caf_sync
7460 : 65 : || caf_attr.coarray_comp || !caf_refs_comp;
7461 : :
7462 : 65 : gfc_init_se (&caf_se, NULL);
7463 : :
7464 : 65 : caf_decl = gfc_get_tree_for_caf_expr (expr);
7465 : 65 : gfc_get_caf_token_offset (&caf_se, &token, NULL, caf_decl,
7466 : : NULL_TREE, NULL);
7467 : 65 : gfc_add_block_to_block (&se.pre, &caf_se.pre);
7468 : 65 : gfc_allocate_allocatable (&se.pre, se.expr, memsz,
7469 : : gfc_build_addr_expr (NULL_TREE, token),
7470 : : NULL_TREE, NULL_TREE, NULL_TREE,
7471 : : label_finish, expr, 1);
7472 : : }
7473 : : /* Allocate - for non-pointers with re-alloc checking. */
7474 : 5013 : else if (gfc_expr_attr (expr).allocatable)
7475 : 3454 : gfc_allocate_allocatable (&se.pre, se.expr, memsz,
7476 : : NULL_TREE, stat, errmsg, errlen,
7477 : : label_finish, expr, 0,
7478 : : omp_cond, omp_alt_alloc, succ_add_expr);
7479 : : else
7480 : 1559 : gfc_allocate_using_malloc (&se.pre, se.expr, memsz, stat,
7481 : : omp_cond, omp_alt_alloc, succ_add_expr);
7482 : : }
7483 : : else
7484 : : {
7485 : : /* Allocating coarrays needs a sync after the allocate executed.
7486 : : Set the flag to add the sync after all objects are allocated. */
7487 : 11728 : if (flag_coarray == GFC_FCOARRAY_LIB
7488 : 11728 : && (caf_attr = gfc_caf_attr (expr, true, &caf_refs_comp))
7489 : 347 : .codimension)
7490 : : {
7491 : 305 : is_coarray = true;
7492 : 305 : needs_caf_sync = needs_caf_sync
7493 : 305 : || caf_attr.coarray_comp || !caf_refs_comp;
7494 : : }
7495 : :
7496 : 11728 : if (expr->ts.type == BT_CHARACTER && al_len != NULL_TREE
7497 : 1067 : && expr3_len != NULL_TREE)
7498 : : {
7499 : : /* Arrays need to have a _len set before the array
7500 : : descriptor is filled. */
7501 : 308 : gfc_add_modify (&block, al_len,
7502 : 308 : fold_convert (TREE_TYPE (al_len), expr3_len));
7503 : : /* Prevent setting the length twice. */
7504 : 308 : al_len_needs_set = false;
7505 : : }
7506 : 11420 : else if (expr->ts.type == BT_CHARACTER && al_len != NULL_TREE
7507 : 228 : && code->ext.alloc.ts.u.cl->length)
7508 : : {
7509 : : /* Cover the cases where a string length is explicitly
7510 : : specified by a type spec for deferred length character
7511 : : arrays or unlimited polymorphic objects without a
7512 : : source= or mold= expression. */
7513 : 228 : gfc_init_se (&se_sz, NULL);
7514 : 228 : gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length);
7515 : 228 : gfc_add_block_to_block (&block, &se_sz.pre);
7516 : 228 : gfc_add_modify (&block, al_len,
7517 : 228 : fold_convert (TREE_TYPE (al_len),
7518 : : se_sz.expr));
7519 : 228 : al_len_needs_set = false;
7520 : : }
7521 : : }
7522 : :
7523 : 16806 : gfc_add_block_to_block (&block, &se.pre);
7524 : :
7525 : : /* Error checking -- Note: ERRMSG only makes sense with STAT. */
7526 : 16806 : if (code->expr1)
7527 : : {
7528 : 290 : tmp = build1_v (GOTO_EXPR, label_errmsg);
7529 : 290 : parm = fold_build2_loc (input_location, NE_EXPR,
7530 : : logical_type_node, stat,
7531 : 290 : build_int_cst (TREE_TYPE (stat), 0));
7532 : 290 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
7533 : : gfc_unlikely (parm, PRED_FORTRAN_FAIL_ALLOC),
7534 : : tmp, build_empty_stmt (input_location));
7535 : 290 : gfc_add_expr_to_block (&block, tmp);
7536 : : }
7537 : :
7538 : : /* Set the vptr only when no source= is set. When source= is set, then
7539 : : the trans_assignment below will set the vptr. */
7540 : 16806 : if (al_vptr != NULL_TREE && (!code->expr3 || code->expr3->mold))
7541 : : {
7542 : 1687 : if (expr3_vptr != NULL_TREE)
7543 : : /* The vtab is already known, so just assign it. */
7544 : 73 : gfc_add_modify (&block, al_vptr,
7545 : 73 : fold_convert (TREE_TYPE (al_vptr), expr3_vptr));
7546 : : else
7547 : : {
7548 : : /* VPTR is fixed at compile time. */
7549 : 1614 : gfc_symbol *vtab;
7550 : 1614 : gfc_typespec *ts;
7551 : :
7552 : 1614 : if (code->expr3)
7553 : : /* Although expr3 is pre-evaluated above, it may happen,
7554 : : that for arrays or in mold= cases the pre-evaluation
7555 : : was not successful. In these rare cases take the vtab
7556 : : from the typespec of expr3 here. */
7557 : 0 : ts = &code->expr3->ts;
7558 : 1614 : else if (code->ext.alloc.ts.type == BT_DERIVED || upoly_expr)
7559 : : /* The alloc_type_spec gives the type to allocate or the
7560 : : al is unlimited polymorphic, which enforces the use of
7561 : : an alloc_type_spec that is not necessarily a BT_DERIVED. */
7562 : 725 : ts = &code->ext.alloc.ts;
7563 : : else
7564 : : /* Prepare for setting the vtab as declared. */
7565 : 889 : ts = &expr->ts;
7566 : :
7567 : 1614 : vtab = gfc_find_vtab (ts);
7568 : 1614 : gcc_assert (vtab);
7569 : 1614 : tmp = gfc_build_addr_expr (NULL_TREE,
7570 : : gfc_get_symbol_decl (vtab));
7571 : 1614 : gfc_add_modify (&block, al_vptr,
7572 : 1614 : fold_convert (TREE_TYPE (al_vptr), tmp));
7573 : : }
7574 : : }
7575 : :
7576 : : /* Add assignment for string length. */
7577 : 16806 : if (al_len != NULL_TREE && al_len_needs_set)
7578 : : {
7579 : 1130 : if (expr3_len != NULL_TREE)
7580 : : {
7581 : 568 : gfc_add_modify (&block, al_len,
7582 : 568 : fold_convert (TREE_TYPE (al_len),
7583 : : expr3_len));
7584 : : /* When tmp_expr3_len_flag is set, then expr3_len is
7585 : : abused to carry the length information from the
7586 : : alloc_type. Clear it to prevent setting incorrect len
7587 : : information in future loop iterations. */
7588 : 568 : if (tmp_expr3_len_flag)
7589 : : /* No need to reset tmp_expr3_len_flag, because the
7590 : : presence of an expr3 cannot change within in the
7591 : : loop. */
7592 : 562 : expr3_len = NULL_TREE;
7593 : : }
7594 : 562 : else if (code->ext.alloc.ts.type == BT_CHARACTER
7595 : 227 : && code->ext.alloc.ts.u.cl->length)
7596 : : {
7597 : : /* Cover the cases where a string length is explicitly
7598 : : specified by a type spec for deferred length character
7599 : : arrays or unlimited polymorphic objects without a
7600 : : source= or mold= expression. */
7601 : 227 : if (expr3_esize == NULL_TREE || code->ext.alloc.ts.kind != 1)
7602 : : {
7603 : 75 : gfc_init_se (&se_sz, NULL);
7604 : 75 : gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length);
7605 : 75 : gfc_add_block_to_block (&block, &se_sz.pre);
7606 : 75 : gfc_add_modify (&block, al_len,
7607 : 75 : fold_convert (TREE_TYPE (al_len),
7608 : : se_sz.expr));
7609 : : }
7610 : : else
7611 : 152 : gfc_add_modify (&block, al_len,
7612 : 152 : fold_convert (TREE_TYPE (al_len),
7613 : : expr3_esize));
7614 : : }
7615 : : else
7616 : : /* No length information needed, because type to allocate
7617 : : has no length. Set _len to 0. */
7618 : 335 : gfc_add_modify (&block, al_len,
7619 : 335 : fold_convert (TREE_TYPE (al_len),
7620 : : integer_zero_node));
7621 : : }
7622 : :
7623 : 16806 : init_expr = NULL;
7624 : 16806 : if (code->expr3 && !code->expr3->mold && e3_is != E3_MOLD)
7625 : : {
7626 : : /* Initialization via SOURCE block (or static default initializer).
7627 : : Switch off automatic reallocation since we have just done the
7628 : : ALLOCATE. */
7629 : 3605 : int realloc_lhs = flag_realloc_lhs;
7630 : 3605 : gfc_expr *init_expr = gfc_expr_to_initialize (expr);
7631 : 3605 : gfc_expr *rhs = e3rhs ? e3rhs : gfc_copy_expr (code->expr3);
7632 : 3605 : flag_realloc_lhs = 0;
7633 : :
7634 : : /* The handling of code->expr3 above produces a derived type of
7635 : : type "STAR", whose size defaults to size(void*). In order to
7636 : : have the right type information for the assignment, we must
7637 : : reconstruct an unlimited polymorphic rhs. */
7638 : 3605 : if (UNLIMITED_POLY (code->expr3)
7639 : 151 : && e3rhs && e3rhs->ts.type == BT_DERIVED
7640 : 6 : && !strcmp (e3rhs->ts.u.derived->name, "STAR"))
7641 : : {
7642 : 6 : gfc_ref *ref;
7643 : 6 : gcc_assert (TREE_CODE (expr3_vptr) == COMPONENT_REF);
7644 : 6 : tmp = gfc_create_var (gfc_typenode_for_spec (&code->expr3->ts),
7645 : : "e3");
7646 : 6 : gfc_add_modify (&block, tmp,
7647 : : gfc_get_class_from_expr (expr3_vptr));
7648 : 6 : rhs->symtree->n.sym->backend_decl = tmp;
7649 : 6 : rhs->ts = code->expr3->ts;
7650 : 6 : rhs->symtree->n.sym->ts = rhs->ts;
7651 : 6 : for (ref = init_expr->ref; ref; ref = ref->next)
7652 : : {
7653 : : /* Copy over the lhs _data component ref followed by the
7654 : : full array reference for source expressions with rank.
7655 : : Otherwise, just copy the _data component ref. */
7656 : 6 : if (code->expr3->rank
7657 : 6 : && ref && ref->next && !ref->next->next)
7658 : : {
7659 : 6 : rhs->ref = gfc_copy_ref (ref);
7660 : 6 : break;
7661 : : }
7662 : 0 : else if ((init_expr->rank && !code->expr3->rank
7663 : 0 : && ref && ref->next && !ref->next->next)
7664 : 0 : || (ref && !ref->next))
7665 : : {
7666 : 0 : rhs->ref = gfc_copy_ref (ref);
7667 : 0 : gfc_free_ref_list (rhs->ref->next);
7668 : 0 : rhs->ref->next = NULL;
7669 : 0 : break;
7670 : : }
7671 : : }
7672 : : }
7673 : :
7674 : : /* Set the symbol to be artificial so that the result is not finalized. */
7675 : 3605 : init_expr->symtree->n.sym->attr.artificial = 1;
7676 : 3605 : tmp = gfc_trans_assignment (init_expr, rhs, true, false, true,
7677 : : false);
7678 : 3605 : init_expr->symtree->n.sym->attr.artificial = 0;
7679 : :
7680 : 3605 : flag_realloc_lhs = realloc_lhs;
7681 : : /* Free the expression allocated for init_expr. */
7682 : 3605 : gfc_free_expr (init_expr);
7683 : 3605 : if (rhs != e3rhs)
7684 : 0 : gfc_free_expr (rhs);
7685 : 3605 : gfc_add_expr_to_block (&block, tmp);
7686 : 3605 : }
7687 : : /* Set KIND and LEN PDT components and allocate those that are
7688 : : parameterized. */
7689 : 13201 : else if (expr->ts.type == BT_DERIVED
7690 : 3278 : && expr->ts.u.derived->attr.pdt_type)
7691 : : {
7692 : 85 : if (code->expr3 && code->expr3->param_list)
7693 : : param_list = code->expr3->param_list;
7694 : 85 : else if (expr->param_list)
7695 : : param_list = expr->param_list;
7696 : : else
7697 : 28 : param_list = expr->symtree->n.sym->param_list;
7698 : 85 : tmp = gfc_allocate_pdt_comp (expr->ts.u.derived, se.expr,
7699 : : expr->rank, param_list);
7700 : 85 : gfc_add_expr_to_block (&block, tmp);
7701 : : }
7702 : : /* Ditto for CLASS expressions. */
7703 : 13116 : else if (expr->ts.type == BT_CLASS
7704 : 596 : && CLASS_DATA (expr)->ts.u.derived->attr.pdt_type)
7705 : : {
7706 : 0 : if (code->expr3 && code->expr3->param_list)
7707 : : param_list = code->expr3->param_list;
7708 : 0 : else if (expr->param_list)
7709 : : param_list = expr->param_list;
7710 : : else
7711 : 0 : param_list = expr->symtree->n.sym->param_list;
7712 : 0 : tmp = gfc_allocate_pdt_comp (CLASS_DATA (expr)->ts.u.derived,
7713 : : se.expr, expr->rank, param_list);
7714 : 0 : gfc_add_expr_to_block (&block, tmp);
7715 : : }
7716 : 13116 : else if (code->expr3 && code->expr3->mold
7717 : 294 : && code->expr3->ts.type == BT_CLASS)
7718 : : {
7719 : : /* Use class_init_assign to initialize expr. */
7720 : 61 : gfc_code *ini;
7721 : 61 : ini = gfc_get_code (EXEC_ALLOCATE);
7722 : 61 : ini->expr1 = gfc_find_and_cut_at_last_class_ref (expr, true);
7723 : 61 : tmp = gfc_trans_class_init_assign (ini);
7724 : 61 : gfc_free_statements (ini);
7725 : 61 : if (tmp != NULL_TREE)
7726 : 61 : gfc_add_expr_to_block (&block, tmp);
7727 : : }
7728 : 13055 : else if ((init_expr = allocate_get_initializer (code, expr)))
7729 : : {
7730 : : /* Use class_init_assign to initialize expr. */
7731 : 1919 : gfc_code *ini;
7732 : 1919 : int realloc_lhs = flag_realloc_lhs;
7733 : 1919 : ini = gfc_get_code (EXEC_INIT_ASSIGN);
7734 : 1919 : ini->expr1 = gfc_expr_to_initialize (expr);
7735 : 1919 : ini->expr2 = init_expr;
7736 : 1919 : flag_realloc_lhs = 0;
7737 : 1919 : tmp= gfc_trans_init_assign (ini);
7738 : 1919 : flag_realloc_lhs = realloc_lhs;
7739 : 1919 : gfc_free_statements (ini);
7740 : : /* Init_expr is freeed by above free_statements, just need to null
7741 : : it here. */
7742 : 1919 : init_expr = NULL;
7743 : 1919 : gfc_add_expr_to_block (&block, tmp);
7744 : : }
7745 : :
7746 : : /* Nullify all pointers in derived type coarrays. This registers a
7747 : : token for them which allows their allocation. */
7748 : 16806 : if (is_coarray)
7749 : : {
7750 : 409 : gfc_symbol *type = NULL;
7751 : 409 : symbol_attribute caf_attr;
7752 : 409 : int rank = 0;
7753 : 409 : if (code->ext.alloc.ts.type == BT_DERIVED
7754 : 9 : && code->ext.alloc.ts.u.derived->attr.pointer_comp)
7755 : : {
7756 : 0 : type = code->ext.alloc.ts.u.derived;
7757 : 0 : rank = type->attr.dimension ? type->as->rank : 0;
7758 : 0 : gfc_clear_attr (&caf_attr);
7759 : : }
7760 : 409 : else if (expr->ts.type == BT_DERIVED
7761 : 95 : && expr->ts.u.derived->attr.pointer_comp)
7762 : : {
7763 : 14 : type = expr->ts.u.derived;
7764 : 14 : rank = expr->rank;
7765 : 14 : caf_attr = gfc_caf_attr (expr, true);
7766 : : }
7767 : :
7768 : : /* Initialize the tokens of pointer components in derived type
7769 : : coarrays. */
7770 : 14 : if (type)
7771 : : {
7772 : 16 : tmp = (caf_attr.codimension && !caf_attr.dimension)
7773 : 16 : ? gfc_conv_descriptor_data_get (se.expr) : se.expr;
7774 : 14 : tmp = gfc_nullify_alloc_comp (type, tmp, rank,
7775 : : GFC_STRUCTURE_CAF_MODE_IN_COARRAY);
7776 : 14 : gfc_add_expr_to_block (&block, tmp);
7777 : : }
7778 : : }
7779 : :
7780 : 16806 : gfc_free_expr (expr);
7781 : : } // for-loop
7782 : :
7783 : 13855 : if (e3rhs)
7784 : : {
7785 : 3767 : if (newsym)
7786 : : {
7787 : 2032 : gfc_free_symbol (newsym->n.sym);
7788 : 2032 : XDELETE (newsym);
7789 : : }
7790 : 3767 : gfc_free_expr (e3rhs);
7791 : : }
7792 : : /* STAT. */
7793 : 13855 : if (code->expr1)
7794 : : {
7795 : 278 : tmp = build1_v (LABEL_EXPR, label_errmsg);
7796 : 278 : gfc_add_expr_to_block (&block, tmp);
7797 : : }
7798 : :
7799 : : /* ERRMSG - only useful if STAT is present. */
7800 : 13855 : if (code->expr1 && code->expr2)
7801 : : {
7802 : 68 : const char *msg = "Attempt to allocate an allocated object";
7803 : 68 : const char *oommsg = "Insufficient virtual memory";
7804 : 68 : tree slen, dlen, errmsg_str, oom_str, oom_loc;
7805 : 68 : stmtblock_t errmsg_block;
7806 : :
7807 : 68 : gfc_init_block (&errmsg_block);
7808 : :
7809 : 68 : errmsg_str = gfc_create_var (pchar_type_node, "ERRMSG");
7810 : 68 : gfc_add_modify (&errmsg_block, errmsg_str,
7811 : : gfc_build_addr_expr (pchar_type_node,
7812 : : gfc_build_localized_cstring_const (msg)));
7813 : :
7814 : 68 : slen = build_int_cst (gfc_charlen_type_node, strlen (msg));
7815 : 68 : dlen = gfc_get_expr_charlen (code->expr2);
7816 : 68 : slen = fold_build2_loc (input_location, MIN_EXPR,
7817 : 68 : TREE_TYPE (slen), dlen, slen);
7818 : :
7819 : 68 : gfc_trans_string_copy (&errmsg_block, dlen, errmsg,
7820 : 68 : code->expr2->ts.kind,
7821 : : slen, errmsg_str,
7822 : : gfc_default_character_kind);
7823 : 68 : dlen = gfc_finish_block (&errmsg_block);
7824 : :
7825 : 68 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7826 : 68 : stat, build_int_cst (TREE_TYPE (stat),
7827 : : LIBERROR_ALLOCATION));
7828 : :
7829 : 68 : tmp = build3_v (COND_EXPR, tmp,
7830 : : dlen, build_empty_stmt (input_location));
7831 : :
7832 : 68 : gfc_add_expr_to_block (&block, tmp);
7833 : :
7834 : 68 : oom_str = gfc_create_var (pchar_type_node, "OOMMSG");
7835 : 68 : oom_loc = gfc_build_localized_cstring_const (oommsg);
7836 : 68 : gfc_add_modify (&errmsg_block, oom_str,
7837 : : gfc_build_addr_expr (pchar_type_node, oom_loc));
7838 : :
7839 : 68 : slen = build_int_cst (gfc_charlen_type_node, strlen (oommsg));
7840 : 68 : dlen = gfc_get_expr_charlen (code->expr2);
7841 : 68 : slen = fold_build2_loc (input_location, MIN_EXPR,
7842 : 68 : TREE_TYPE (slen), dlen, slen);
7843 : :
7844 : 68 : gfc_trans_string_copy (&errmsg_block, dlen, errmsg,
7845 : 68 : code->expr2->ts.kind,
7846 : : slen, oom_str,
7847 : : gfc_default_character_kind);
7848 : 68 : dlen = gfc_finish_block (&errmsg_block);
7849 : :
7850 : 68 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7851 : 68 : stat, build_int_cst (TREE_TYPE (stat),
7852 : : LIBERROR_NO_MEMORY));
7853 : :
7854 : 68 : tmp = build3_v (COND_EXPR, tmp,
7855 : : dlen, build_empty_stmt (input_location));
7856 : :
7857 : 68 : gfc_add_expr_to_block (&block, tmp);
7858 : : }
7859 : :
7860 : : /* STAT block. */
7861 : 13855 : if (code->expr1)
7862 : : {
7863 : 278 : if (TREE_USED (label_finish))
7864 : : {
7865 : 12 : tmp = build1_v (LABEL_EXPR, label_finish);
7866 : 12 : gfc_add_expr_to_block (&block, tmp);
7867 : : }
7868 : :
7869 : 278 : gfc_init_se (&se, NULL);
7870 : 278 : gfc_conv_expr_lhs (&se, code->expr1);
7871 : 278 : tmp = convert (TREE_TYPE (se.expr), stat);
7872 : 278 : gfc_add_modify (&block, se.expr, tmp);
7873 : : }
7874 : :
7875 : 13855 : if (needs_caf_sync)
7876 : : {
7877 : : /* Add a sync all after the allocation has been executed. */
7878 : 150 : tree zero_size = build_zero_cst (size_type_node);
7879 : 150 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all,
7880 : : 3, null_pointer_node, null_pointer_node,
7881 : : zero_size);
7882 : 150 : gfc_add_expr_to_block (&post, tmp);
7883 : : }
7884 : :
7885 : 13855 : gfc_add_block_to_block (&block, &se.post);
7886 : 13855 : gfc_add_block_to_block (&block, &post);
7887 : 13855 : if (code->expr3 && code->expr3->must_finalize)
7888 : 78 : gfc_add_block_to_block (&block, &final_block);
7889 : :
7890 : 13855 : return gfc_finish_block (&block);
7891 : : }
7892 : :
7893 : :
7894 : : /* Translate a DEALLOCATE statement. */
7895 : :
7896 : : tree
7897 : 8131 : gfc_trans_deallocate (gfc_code *code)
7898 : : {
7899 : 8131 : gfc_se se;
7900 : 8131 : gfc_alloc *al;
7901 : 8131 : tree apstat, pstat, stat, errmsg, errlen, tmp;
7902 : 8131 : tree label_finish, label_errmsg;
7903 : 8131 : stmtblock_t block;
7904 : :
7905 : 8131 : pstat = apstat = stat = errmsg = errlen = tmp = NULL_TREE;
7906 : 8131 : label_finish = label_errmsg = NULL_TREE;
7907 : :
7908 : 8131 : gfc_start_block (&block);
7909 : :
7910 : : /* Count the number of failed deallocations. If deallocate() was
7911 : : called with STAT= , then set STAT to the count. If deallocate
7912 : : was called with ERRMSG, then set ERRMG to a string. */
7913 : 8131 : if (code->expr1)
7914 : : {
7915 : 2269 : tree gfc_int4_type_node = gfc_get_int_type (4);
7916 : :
7917 : 2269 : stat = gfc_create_var (gfc_int4_type_node, "stat");
7918 : 2269 : pstat = gfc_build_addr_expr (NULL_TREE, stat);
7919 : :
7920 : : /* GOTO destinations. */
7921 : 2269 : label_errmsg = gfc_build_label_decl (NULL_TREE);
7922 : 2269 : label_finish = gfc_build_label_decl (NULL_TREE);
7923 : 2269 : TREE_USED (label_finish) = 0;
7924 : : }
7925 : :
7926 : : /* Set ERRMSG - only needed if STAT is available. */
7927 : 8131 : if (code->expr1 && code->expr2)
7928 : : {
7929 : 51 : gfc_init_se (&se, NULL);
7930 : 51 : se.want_pointer = 1;
7931 : 51 : gfc_conv_expr_lhs (&se, code->expr2);
7932 : 51 : errmsg = se.expr;
7933 : 51 : errlen = se.string_length;
7934 : : }
7935 : :
7936 : 18484 : for (al = code->ext.alloc.list; al != NULL; al = al->next)
7937 : : {
7938 : 10353 : gfc_expr *expr = gfc_copy_expr (al->expr);
7939 : 10353 : bool is_coarray = false, is_coarray_array = false;
7940 : 10353 : int caf_mode = 0;
7941 : 10353 : gfc_ref * ref;
7942 : 10353 : gfc_actual_arglist * param_list;
7943 : :
7944 : 10353 : gcc_assert (expr->expr_type == EXPR_VARIABLE);
7945 : :
7946 : 10353 : if (expr->ts.type == BT_CLASS)
7947 : 1942 : gfc_add_data_component (expr);
7948 : :
7949 : 10353 : gfc_init_se (&se, NULL);
7950 : 10353 : gfc_start_block (&se.pre);
7951 : :
7952 : 10353 : se.want_pointer = 1;
7953 : 10353 : se.descriptor_only = 1;
7954 : 10353 : gfc_conv_expr (&se, expr);
7955 : :
7956 : : /* Deallocate PDT components that are parameterized. */
7957 : 10353 : tmp = NULL;
7958 : 10353 : param_list = expr->param_list;
7959 : 10353 : if (!param_list && expr->symtree->n.sym->param_list)
7960 : : param_list = expr->symtree->n.sym->param_list;
7961 : 24318 : for (ref = expr->ref; ref; ref = ref->next)
7962 : 13965 : if (ref->type == REF_COMPONENT
7963 : 6331 : && ref->u.c.component->ts.type == BT_DERIVED
7964 : 3413 : && ref->u.c.component->ts.u.derived->attr.pdt_type
7965 : 49 : && ref->u.c.component->param_list)
7966 : 13965 : param_list = ref->u.c.component->param_list;
7967 : 10353 : if (expr->ts.type == BT_DERIVED
7968 : 2638 : && ((expr->ts.u.derived->attr.pdt_type && param_list)
7969 : 2544 : || expr->ts.u.derived->attr.pdt_comp))
7970 : 94 : tmp = gfc_deallocate_pdt_comp (expr->ts.u.derived, se.expr, expr->rank);
7971 : 10259 : else if (expr->ts.type == BT_CLASS
7972 : 1070 : && CLASS_DATA (expr)->ts.u.derived->attr.pdt_type
7973 : 0 : && expr->symtree->n.sym->param_list)
7974 : 0 : tmp = gfc_deallocate_pdt_comp (CLASS_DATA (expr)->ts.u.derived,
7975 : : se.expr, expr->rank);
7976 : :
7977 : 94 : if (tmp)
7978 : 30 : gfc_add_expr_to_block (&block, tmp);
7979 : :
7980 : 10353 : if (flag_coarray == GFC_FCOARRAY_LIB
7981 : 10353 : || flag_coarray == GFC_FCOARRAY_SINGLE)
7982 : : {
7983 : 393 : bool comp_ref;
7984 : 393 : symbol_attribute caf_attr = gfc_caf_attr (expr, false, &comp_ref);
7985 : 393 : if (caf_attr.codimension)
7986 : : {
7987 : 280 : is_coarray = true;
7988 : 126 : is_coarray_array = caf_attr.dimension || !comp_ref
7989 : 332 : || caf_attr.coarray_comp;
7990 : :
7991 : 280 : if (flag_coarray == GFC_FCOARRAY_LIB)
7992 : : /* When the expression to deallocate is referencing a
7993 : : component, then only deallocate it, but do not
7994 : : deregister. */
7995 : 69 : caf_mode = GFC_STRUCTURE_CAF_MODE_IN_COARRAY
7996 : 175 : | (comp_ref && !caf_attr.coarray_comp
7997 : : ? GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY : 0);
7998 : : }
7999 : : }
8000 : :
8001 : 10353 : if (expr->rank || is_coarray_array)
8002 : : {
8003 : 7023 : gfc_ref *ref;
8004 : :
8005 : 5903 : if (gfc_bt_struct (expr->ts.type)
8006 : 1120 : && expr->ts.u.derived->attr.alloc_comp
8007 : 7546 : && !gfc_is_finalizable (expr->ts.u.derived, NULL))
8008 : : {
8009 : 520 : gfc_ref *last = NULL;
8010 : :
8011 : 1388 : for (ref = expr->ref; ref; ref = ref->next)
8012 : 868 : if (ref->type == REF_COMPONENT)
8013 : 300 : last = ref;
8014 : :
8015 : : /* Do not deallocate the components of a derived type
8016 : : ultimate pointer component. */
8017 : 520 : if (!(last && last->u.c.component->attr.pointer)
8018 : 247 : && !(!last && expr->symtree->n.sym->attr.pointer))
8019 : : {
8020 : 26 : if (is_coarray && expr->rank == 0
8021 : 18 : && (!last || !last->u.c.component->attr.dimension)
8022 : 514 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)))
8023 : : {
8024 : : /* Add the ref to the data member only, when this is not
8025 : : a regular array or deallocate_alloc_comp will try to
8026 : : add another one. */
8027 : 18 : tmp = gfc_conv_descriptor_data_get (se.expr);
8028 : : }
8029 : : else
8030 : 478 : tmp = se.expr;
8031 : 496 : tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp,
8032 : : expr->rank, caf_mode);
8033 : 496 : gfc_add_expr_to_block (&se.pre, tmp);
8034 : : }
8035 : : }
8036 : :
8037 : 7023 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)))
8038 : : {
8039 : 6984 : gfc_coarray_deregtype caf_dtype;
8040 : :
8041 : 6984 : if (is_coarray)
8042 : 411 : caf_dtype = gfc_caf_is_dealloc_only (caf_mode)
8043 : 240 : ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
8044 : : : GFC_CAF_COARRAY_DEREGISTER;
8045 : : else
8046 : : caf_dtype = GFC_CAF_COARRAY_NOCOARRAY;
8047 : 6984 : tmp = gfc_deallocate_with_status (se.expr, pstat, errmsg, errlen,
8048 : : label_finish, false, expr,
8049 : : caf_dtype);
8050 : 6984 : gfc_add_expr_to_block (&se.pre, tmp);
8051 : : }
8052 : 39 : else if (TREE_CODE (se.expr) == COMPONENT_REF
8053 : 39 : && TREE_CODE (TREE_TYPE (se.expr)) == ARRAY_TYPE
8054 : 78 : && TREE_CODE (TREE_TYPE (TREE_TYPE (se.expr)))
8055 : : == RECORD_TYPE)
8056 : : {
8057 : : /* class.cc(finalize_component) generates these, when a
8058 : : finalizable entity has a non-allocatable derived type array
8059 : : component, which has allocatable components. Obtain the
8060 : : derived type of the array and deallocate the allocatable
8061 : : components. */
8062 : 45 : for (ref = expr->ref; ref; ref = ref->next)
8063 : : {
8064 : 45 : if (ref->u.c.component->attr.dimension
8065 : 39 : && ref->u.c.component->ts.type == BT_DERIVED)
8066 : : break;
8067 : : }
8068 : :
8069 : 39 : if (ref && ref->u.c.component->ts.u.derived->attr.alloc_comp
8070 : 78 : && !gfc_is_finalizable (ref->u.c.component->ts.u.derived,
8071 : : NULL))
8072 : : {
8073 : 39 : tmp = gfc_deallocate_alloc_comp
8074 : 39 : (ref->u.c.component->ts.u.derived,
8075 : : se.expr, expr->rank);
8076 : 39 : gfc_add_expr_to_block (&se.pre, tmp);
8077 : : }
8078 : : }
8079 : :
8080 : 7023 : if (al->expr->ts.type == BT_CLASS)
8081 : : {
8082 : 1079 : gfc_reset_vptr (&se.pre, al->expr);
8083 : 1079 : if (UNLIMITED_POLY (al->expr)
8084 : 732 : || (al->expr->ts.type == BT_DERIVED
8085 : 0 : && al->expr->ts.u.derived->attr.unlimited_polymorphic))
8086 : : /* Clear _len, too. */
8087 : 347 : gfc_reset_len (&se.pre, al->expr);
8088 : : }
8089 : : }
8090 : : else
8091 : : {
8092 : 6660 : tmp = gfc_deallocate_scalar_with_status (se.expr, pstat, label_finish,
8093 : : false, al->expr,
8094 : 3330 : al->expr->ts, NULL_TREE,
8095 : : is_coarray);
8096 : 3330 : gfc_add_expr_to_block (&se.pre, tmp);
8097 : :
8098 : : /* Set to zero after deallocation. */
8099 : 3330 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
8100 : : se.expr,
8101 : 3330 : build_int_cst (TREE_TYPE (se.expr), 0));
8102 : 3330 : gfc_add_expr_to_block (&se.pre, tmp);
8103 : :
8104 : 3330 : if (al->expr->ts.type == BT_CLASS)
8105 : : {
8106 : 863 : gfc_reset_vptr (&se.pre, al->expr);
8107 : 863 : if (UNLIMITED_POLY (al->expr)
8108 : 631 : || (al->expr->ts.type == BT_DERIVED
8109 : 0 : && al->expr->ts.u.derived->attr.unlimited_polymorphic))
8110 : : /* Clear _len, too. */
8111 : 232 : gfc_reset_len (&se.pre, al->expr);
8112 : : }
8113 : : }
8114 : :
8115 : 10353 : if (code->expr1)
8116 : : {
8117 : 2308 : tree cond;
8118 : :
8119 : 2308 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, stat,
8120 : 2308 : build_int_cst (TREE_TYPE (stat), 0));
8121 : 2308 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
8122 : : gfc_unlikely (cond, PRED_FORTRAN_FAIL_ALLOC),
8123 : : build1_v (GOTO_EXPR, label_errmsg),
8124 : : build_empty_stmt (input_location));
8125 : 2308 : gfc_add_expr_to_block (&se.pre, tmp);
8126 : : }
8127 : :
8128 : 10353 : tmp = gfc_finish_block (&se.pre);
8129 : 10353 : gfc_add_expr_to_block (&block, tmp);
8130 : 10353 : gfc_free_expr (expr);
8131 : : }
8132 : :
8133 : 8131 : if (code->expr1)
8134 : : {
8135 : 2269 : tmp = build1_v (LABEL_EXPR, label_errmsg);
8136 : 2269 : gfc_add_expr_to_block (&block, tmp);
8137 : : }
8138 : :
8139 : : /* Set ERRMSG - only needed if STAT is available. */
8140 : 8131 : if (code->expr1 && code->expr2)
8141 : : {
8142 : 51 : const char *msg = "Attempt to deallocate an unallocated object";
8143 : 51 : stmtblock_t errmsg_block;
8144 : 51 : tree errmsg_str, slen, dlen, cond;
8145 : :
8146 : 51 : gfc_init_block (&errmsg_block);
8147 : :
8148 : 51 : errmsg_str = gfc_create_var (pchar_type_node, "ERRMSG");
8149 : 51 : gfc_add_modify (&errmsg_block, errmsg_str,
8150 : : gfc_build_addr_expr (pchar_type_node,
8151 : : gfc_build_localized_cstring_const (msg)));
8152 : 51 : slen = build_int_cst (gfc_charlen_type_node, strlen (msg));
8153 : 51 : dlen = gfc_get_expr_charlen (code->expr2);
8154 : :
8155 : 51 : gfc_trans_string_copy (&errmsg_block, dlen, errmsg, code->expr2->ts.kind,
8156 : : slen, errmsg_str, gfc_default_character_kind);
8157 : 51 : tmp = gfc_finish_block (&errmsg_block);
8158 : :
8159 : 51 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, stat,
8160 : 51 : build_int_cst (TREE_TYPE (stat), 0));
8161 : 51 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
8162 : : gfc_unlikely (cond, PRED_FORTRAN_FAIL_ALLOC), tmp,
8163 : : build_empty_stmt (input_location));
8164 : :
8165 : 51 : gfc_add_expr_to_block (&block, tmp);
8166 : : }
8167 : :
8168 : 8131 : if (code->expr1 && TREE_USED (label_finish))
8169 : : {
8170 : 14 : tmp = build1_v (LABEL_EXPR, label_finish);
8171 : 14 : gfc_add_expr_to_block (&block, tmp);
8172 : : }
8173 : :
8174 : : /* Set STAT. */
8175 : 8131 : if (code->expr1)
8176 : : {
8177 : 2269 : gfc_init_se (&se, NULL);
8178 : 2269 : gfc_conv_expr_lhs (&se, code->expr1);
8179 : 2269 : tmp = convert (TREE_TYPE (se.expr), stat);
8180 : 2269 : gfc_add_modify (&block, se.expr, tmp);
8181 : : }
8182 : :
8183 : 8131 : return gfc_finish_block (&block);
8184 : : }
8185 : :
8186 : : #include "gt-fortran-trans-stmt.h"
|
