Branch data Line data Source code
1 : : /* Code translation -- generate GCC trees from gfc_code.
2 : : Copyright (C) 2002-2025 Free Software Foundation, Inc.
3 : : Contributed by Paul Brook
4 : :
5 : : This file is part of GCC.
6 : :
7 : : GCC is free software; you can redistribute it and/or modify it under
8 : : the terms of the GNU General Public License as published by the Free
9 : : Software Foundation; either version 3, or (at your option) any later
10 : : version.
11 : :
12 : : GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 : : WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 : : FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15 : : for more details.
16 : :
17 : : You should have received a copy of the GNU General Public License
18 : : along with GCC; see the file COPYING3. If not see
19 : : <http://www.gnu.org/licenses/>. */
20 : :
21 : : #include "config.h"
22 : : #include "system.h"
23 : : #include "coretypes.h"
24 : : #include "options.h"
25 : : #include "tree.h"
26 : : #include "gfortran.h"
27 : : #include "gimple-expr.h" /* For create_tmp_var_raw. */
28 : : #include "trans.h"
29 : : #include "stringpool.h"
30 : : #include "fold-const.h"
31 : : #include "tree-iterator.h"
32 : : #include "trans-stmt.h"
33 : : #include "trans-array.h"
34 : : #include "trans-types.h"
35 : : #include "trans-const.h"
36 : :
37 : : /* Naming convention for backend interface code:
38 : :
39 : : gfc_trans_* translate gfc_code into STMT trees.
40 : :
41 : : gfc_conv_* expression conversion
42 : :
43 : : gfc_get_* get a backend tree representation of a decl or type */
44 : :
45 : : const char gfc_msg_fault[] = N_("Array reference out of bounds");
46 : :
47 : :
48 : : /* Advance along TREE_CHAIN n times. */
49 : :
50 : : tree
51 : 5471258 : gfc_advance_chain (tree t, int n)
52 : : {
53 : 15824909 : for (; n > 0; n--)
54 : : {
55 : 10353651 : gcc_assert (t != NULL_TREE);
56 : 10353651 : t = DECL_CHAIN (t);
57 : : }
58 : 5471258 : return t;
59 : : }
60 : :
61 : : void
62 : 93947 : gfc_locus_from_location (locus *where, location_t loc)
63 : : {
64 : 93947 : where->nextc = (gfc_char_t *) -1;
65 : 93947 : where->u.location = loc;
66 : 93947 : }
67 : :
68 : :
69 : : static int num_var;
70 : :
71 : : #define MAX_PREFIX_LEN 20
72 : :
73 : : static tree
74 : 0 : create_var_debug_raw (tree type, const char *prefix)
75 : : {
76 : : /* Space for prefix + "_" + 10-digit-number + \0. */
77 : 0 : char name_buf[MAX_PREFIX_LEN + 1 + 10 + 1];
78 : 0 : tree t;
79 : 0 : int i;
80 : :
81 : 0 : if (prefix == NULL)
82 : : prefix = "gfc";
83 : : else
84 : 0 : gcc_assert (strlen (prefix) <= MAX_PREFIX_LEN);
85 : :
86 : 0 : for (i = 0; prefix[i] != 0; i++)
87 : 0 : name_buf[i] = gfc_wide_toupper (prefix[i]);
88 : :
89 : 0 : snprintf (name_buf + i, sizeof (name_buf) - i, "_%d", num_var++);
90 : :
91 : 0 : t = build_decl (input_location, VAR_DECL, get_identifier (name_buf), type);
92 : :
93 : : /* Not setting this causes some regressions. */
94 : 0 : DECL_ARTIFICIAL (t) = 1;
95 : :
96 : : /* We want debug info for it. */
97 : 0 : DECL_IGNORED_P (t) = 0;
98 : : /* It should not be nameless. */
99 : 0 : DECL_NAMELESS (t) = 0;
100 : :
101 : : /* Make the variable writable. */
102 : 0 : TREE_READONLY (t) = 0;
103 : :
104 : 0 : DECL_EXTERNAL (t) = 0;
105 : 0 : TREE_STATIC (t) = 0;
106 : 0 : TREE_USED (t) = 1;
107 : :
108 : 0 : return t;
109 : : }
110 : :
111 : : /* Creates a variable declaration with a given TYPE. */
112 : :
113 : : tree
114 : 1506249 : gfc_create_var_np (tree type, const char *prefix)
115 : : {
116 : 1506249 : tree t;
117 : :
118 : 1506249 : if (flag_debug_aux_vars)
119 : 0 : return create_var_debug_raw (type, prefix);
120 : :
121 : 1506249 : t = create_tmp_var_raw (type, prefix);
122 : :
123 : : /* No warnings for anonymous variables. */
124 : 1506249 : if (prefix == NULL)
125 : 925421 : suppress_warning (t);
126 : :
127 : : return t;
128 : : }
129 : :
130 : :
131 : : /* Like above, but also adds it to the current scope. */
132 : :
133 : : tree
134 : 1387710 : gfc_create_var (tree type, const char *prefix)
135 : : {
136 : 1387710 : tree tmp;
137 : :
138 : 1387710 : tmp = gfc_create_var_np (type, prefix);
139 : :
140 : 1387710 : pushdecl (tmp);
141 : :
142 : 1387710 : return tmp;
143 : : }
144 : :
145 : :
146 : : /* If the expression is not constant, evaluate it now. We assign the
147 : : result of the expression to an artificially created variable VAR, and
148 : : return a pointer to the VAR_DECL node for this variable. */
149 : :
150 : : tree
151 : 2013584 : gfc_evaluate_now_loc (location_t loc, tree expr, stmtblock_t * pblock)
152 : : {
153 : 2013584 : tree var;
154 : :
155 : 2013584 : if (CONSTANT_CLASS_P (expr))
156 : : return expr;
157 : :
158 : 793517 : var = gfc_create_var (TREE_TYPE (expr), NULL);
159 : 793517 : gfc_add_modify_loc (loc, pblock, var, expr);
160 : :
161 : 793517 : return var;
162 : : }
163 : :
164 : :
165 : : tree
166 : 1981380 : gfc_evaluate_now (tree expr, stmtblock_t * pblock)
167 : : {
168 : 1981380 : return gfc_evaluate_now_loc (input_location, expr, pblock);
169 : : }
170 : :
171 : :
172 : : /* Returns a fresh pointer variable pointing to the same data as EXPR, adding
173 : : in BLOCK the initialization code that makes it point to EXPR. */
174 : :
175 : : tree
176 : 666 : gfc_evaluate_data_ref_now (tree expr, stmtblock_t *block)
177 : : {
178 : 666 : tree t = expr;
179 : :
180 : 666 : STRIP_NOPS (t);
181 : :
182 : : /* If EXPR can be used as lhs of an assignment, we have to take the address
183 : : of EXPR. Otherwise, reassigning the pointer would retarget it to some
184 : : other data without EXPR being retargetted as well. */
185 : 666 : bool lvalue_p = DECL_P (t) || REFERENCE_CLASS_P (t) || INDIRECT_REF_P (t);
186 : :
187 : 143 : tree value;
188 : 143 : if (lvalue_p)
189 : : {
190 : 523 : value = gfc_build_addr_expr (NULL_TREE, expr);
191 : 523 : value = gfc_evaluate_now (value, block);
192 : 523 : return build_fold_indirect_ref_loc (input_location, value);
193 : : }
194 : : else
195 : 143 : return gfc_evaluate_now (expr, block);
196 : : }
197 : :
198 : :
199 : : /* Like gfc_evaluate_now, but add the created variable to the
200 : : function scope. */
201 : :
202 : : tree
203 : 114 : gfc_evaluate_now_function_scope (tree expr, stmtblock_t * pblock)
204 : : {
205 : 114 : tree var;
206 : 114 : var = gfc_create_var_np (TREE_TYPE (expr), NULL);
207 : 114 : gfc_add_decl_to_function (var);
208 : 114 : gfc_add_modify (pblock, var, expr);
209 : :
210 : 114 : return var;
211 : : }
212 : :
213 : : /* Build a MODIFY_EXPR node and add it to a given statement block PBLOCK.
214 : : A MODIFY_EXPR is an assignment:
215 : : LHS <- RHS. */
216 : :
217 : : void
218 : 3471538 : gfc_add_modify_loc (location_t loc, stmtblock_t * pblock, tree lhs, tree rhs)
219 : : {
220 : 3471538 : tree tmp;
221 : :
222 : 3471538 : tree t1, t2;
223 : 3471538 : t1 = TREE_TYPE (rhs);
224 : 3471538 : t2 = TREE_TYPE (lhs);
225 : : /* Make sure that the types of the rhs and the lhs are compatible
226 : : for scalar assignments. We should probably have something
227 : : similar for aggregates, but right now removing that check just
228 : : breaks everything. */
229 : 3471538 : gcc_checking_assert (TYPE_MAIN_VARIANT (t1) == TYPE_MAIN_VARIANT (t2)
230 : : || AGGREGATE_TYPE_P (TREE_TYPE (lhs)));
231 : :
232 : 3471538 : tmp = fold_build2_loc (loc, MODIFY_EXPR, void_type_node, lhs,
233 : : rhs);
234 : 3471538 : gfc_add_expr_to_block (pblock, tmp);
235 : 3471538 : }
236 : :
237 : :
238 : : void
239 : 2622469 : gfc_add_modify (stmtblock_t * pblock, tree lhs, tree rhs)
240 : : {
241 : 2622469 : gfc_add_modify_loc (input_location, pblock, lhs, rhs);
242 : 2622469 : }
243 : :
244 : : tree
245 : 790 : gfc_trans_force_lval (stmtblock_t *pblock, tree e)
246 : : {
247 : 790 : if (VAR_P (e))
248 : : return e;
249 : :
250 : 708 : tree v = gfc_create_var (TREE_TYPE (e), NULL);
251 : 708 : gfc_add_modify (pblock, v, e);
252 : 708 : return v;
253 : : }
254 : :
255 : : /* Create a new scope/binding level and initialize a block. Care must be
256 : : taken when translating expressions as any temporaries will be placed in
257 : : the innermost scope. */
258 : :
259 : : void
260 : 2132316 : gfc_start_block (stmtblock_t * block)
261 : : {
262 : : /* Start a new binding level. */
263 : 2132316 : pushlevel ();
264 : 2132316 : block->has_scope = 1;
265 : :
266 : : /* The block is empty. */
267 : 2132316 : block->head = NULL_TREE;
268 : 2132316 : }
269 : :
270 : :
271 : : /* Initialize a block without creating a new scope. */
272 : :
273 : : void
274 : 16144259 : gfc_init_block (stmtblock_t * block)
275 : : {
276 : 16144259 : block->head = NULL_TREE;
277 : 16144259 : block->has_scope = 0;
278 : 16144259 : }
279 : :
280 : :
281 : : /* Sometimes we create a scope but it turns out that we don't actually
282 : : need it. This function merges the scope of BLOCK with its parent.
283 : : Only variable decls will be merged, you still need to add the code. */
284 : :
285 : : void
286 : 85 : gfc_merge_block_scope (stmtblock_t * block)
287 : : {
288 : 85 : tree decl;
289 : 85 : tree next;
290 : :
291 : 85 : gcc_assert (block->has_scope);
292 : 85 : block->has_scope = 0;
293 : :
294 : : /* Remember the decls in this scope. */
295 : 85 : decl = getdecls ();
296 : 85 : poplevel (0, 0);
297 : :
298 : : /* Add them to the parent scope. */
299 : 283 : while (decl != NULL_TREE)
300 : : {
301 : 113 : next = DECL_CHAIN (decl);
302 : 113 : DECL_CHAIN (decl) = NULL_TREE;
303 : :
304 : 113 : pushdecl (decl);
305 : 113 : decl = next;
306 : : }
307 : 85 : }
308 : :
309 : :
310 : : /* Finish a scope containing a block of statements. */
311 : :
312 : : tree
313 : 3749321 : gfc_finish_block (stmtblock_t * stmtblock)
314 : : {
315 : 3749321 : tree decl;
316 : 3749321 : tree expr;
317 : 3749321 : tree block;
318 : :
319 : 3749321 : expr = stmtblock->head;
320 : 3749321 : if (!expr)
321 : 476384 : expr = build_empty_stmt (input_location);
322 : :
323 : 3749321 : stmtblock->head = NULL_TREE;
324 : :
325 : 3749321 : if (stmtblock->has_scope)
326 : : {
327 : 2132224 : decl = getdecls ();
328 : :
329 : 2132224 : if (decl)
330 : : {
331 : 530952 : block = poplevel (1, 0);
332 : 530952 : expr = build3_v (BIND_EXPR, decl, expr, block);
333 : : }
334 : : else
335 : 1601272 : poplevel (0, 0);
336 : : }
337 : :
338 : 3749321 : return expr;
339 : : }
340 : :
341 : :
342 : : /* Build an ADDR_EXPR and cast the result to TYPE. If TYPE is NULL, the
343 : : natural type is used. */
344 : :
345 : : tree
346 : 1493788 : gfc_build_addr_expr (tree type, tree t)
347 : : {
348 : 1493788 : tree base_type = TREE_TYPE (t);
349 : 1493788 : tree natural_type;
350 : :
351 : 635788 : if (type && POINTER_TYPE_P (type)
352 : 635788 : && TREE_CODE (base_type) == ARRAY_TYPE
353 : 2064656 : && TYPE_MAIN_VARIANT (TREE_TYPE (type))
354 : 570868 : == TYPE_MAIN_VARIANT (TREE_TYPE (base_type)))
355 : : {
356 : 395775 : tree min_val = size_zero_node;
357 : 395775 : tree type_domain = TYPE_DOMAIN (base_type);
358 : 395775 : if (type_domain && TYPE_MIN_VALUE (type_domain))
359 : 395775 : min_val = TYPE_MIN_VALUE (type_domain);
360 : 395775 : t = fold (build4_loc (input_location, ARRAY_REF, TREE_TYPE (type),
361 : : t, min_val, NULL_TREE, NULL_TREE));
362 : 395775 : natural_type = type;
363 : : }
364 : : else
365 : 1098013 : natural_type = build_pointer_type (base_type);
366 : :
367 : 1493788 : if (INDIRECT_REF_P (t))
368 : : {
369 : 146970 : if (!type)
370 : 72175 : type = natural_type;
371 : 146970 : t = TREE_OPERAND (t, 0);
372 : 146970 : natural_type = TREE_TYPE (t);
373 : : }
374 : : else
375 : : {
376 : 1346818 : tree base = get_base_address (t);
377 : 1346818 : if (base && DECL_P (base))
378 : 936217 : TREE_ADDRESSABLE (base) = 1;
379 : 1346818 : t = fold_build1_loc (input_location, ADDR_EXPR, natural_type, t);
380 : : }
381 : :
382 : 1493788 : if (type && natural_type != type)
383 : 183808 : t = convert (type, t);
384 : :
385 : 1493788 : return t;
386 : : }
387 : :
388 : :
389 : : static tree
390 : 19587 : get_array_span (tree type, tree decl)
391 : : {
392 : 19587 : tree span;
393 : :
394 : : /* Component references are guaranteed to have a reliable value for
395 : : 'span'. Likewise indirect references since they emerge from the
396 : : conversion of a CFI descriptor or the hidden dummy descriptor. */
397 : 19587 : if (TREE_CODE (decl) == COMPONENT_REF
398 : 19587 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
399 : 3065 : return gfc_conv_descriptor_span_get (decl);
400 : 16522 : else if (INDIRECT_REF_P (decl)
401 : 16522 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
402 : 2321 : return gfc_conv_descriptor_span_get (decl);
403 : :
404 : : /* Return the span for deferred character length array references. */
405 : 14201 : if (type
406 : 14201 : && (TREE_CODE (type) == ARRAY_TYPE || TREE_CODE (type) == INTEGER_TYPE)
407 : 23614 : && TYPE_STRING_FLAG (type))
408 : : {
409 : 6856 : if (TREE_CODE (decl) == PARM_DECL)
410 : 393 : decl = build_fold_indirect_ref_loc (input_location, decl);
411 : 6856 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
412 : 5146 : span = gfc_conv_descriptor_span_get (decl);
413 : : else
414 : 1710 : span = gfc_get_character_len_in_bytes (type);
415 : 6856 : span = (span && !integer_zerop (span))
416 : 13712 : ? (fold_convert (gfc_array_index_type, span)) : (NULL_TREE);
417 : : }
418 : : /* Likewise for class array or pointer array references. */
419 : 7345 : else if (TREE_CODE (decl) == FIELD_DECL
420 : : || VAR_OR_FUNCTION_DECL_P (decl)
421 : : || TREE_CODE (decl) == PARM_DECL)
422 : : {
423 : 7345 : if (GFC_DECL_CLASS (decl))
424 : : {
425 : : /* When a temporary is in place for the class array, then the
426 : : original class' declaration is stored in the saved
427 : : descriptor. */
428 : 0 : if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl))
429 : 0 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
430 : : else
431 : : {
432 : : /* Allow for dummy arguments and other good things. */
433 : 0 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
434 : 0 : decl = build_fold_indirect_ref_loc (input_location, decl);
435 : :
436 : : /* Check if '_data' is an array descriptor. If it is not,
437 : : the array must be one of the components of the class
438 : : object, so return a null span. */
439 : 0 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (
440 : : gfc_class_data_get (decl))))
441 : : return NULL_TREE;
442 : : }
443 : 0 : span = gfc_class_vtab_size_get (decl);
444 : : /* For unlimited polymorphic entities then _len component needs
445 : : to be multiplied with the size. */
446 : 0 : span = gfc_resize_class_size_with_len (NULL, decl, span);
447 : : }
448 : 7345 : else if (GFC_DECL_PTR_ARRAY_P (decl))
449 : : {
450 : 7170 : if (TREE_CODE (decl) == PARM_DECL)
451 : 1965 : decl = build_fold_indirect_ref_loc (input_location, decl);
452 : 7170 : span = gfc_conv_descriptor_span_get (decl);
453 : : }
454 : : else
455 : : span = NULL_TREE;
456 : : }
457 : : else
458 : : span = NULL_TREE;
459 : :
460 : : return span;
461 : : }
462 : :
463 : :
464 : : tree
465 : 26205 : gfc_build_spanned_array_ref (tree base, tree offset, tree span)
466 : : {
467 : 26205 : tree type;
468 : 26205 : tree tmp;
469 : 26205 : type = TREE_TYPE (TREE_TYPE (base));
470 : 26205 : offset = fold_build2_loc (input_location, MULT_EXPR,
471 : : gfc_array_index_type,
472 : : offset, span);
473 : 26205 : tmp = gfc_build_addr_expr (pvoid_type_node, base);
474 : 26205 : tmp = fold_build_pointer_plus_loc (input_location, tmp, offset);
475 : 26205 : tmp = fold_convert (build_pointer_type (type), tmp);
476 : 21717 : if ((TREE_CODE (type) != INTEGER_TYPE && TREE_CODE (type) != ARRAY_TYPE)
477 : 35212 : || !TYPE_STRING_FLAG (type))
478 : 17147 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
479 : 26205 : return tmp;
480 : : }
481 : :
482 : :
483 : : /* Build an ARRAY_REF with its natural type.
484 : : NON_NEGATIVE_OFFSET indicates if it’s true that OFFSET can’t be negative,
485 : : and thus that an ARRAY_REF can safely be generated. If it’s false, we
486 : : have to play it safe and use pointer arithmetic. */
487 : :
488 : : tree
489 : 1381116 : gfc_build_array_ref (tree base, tree offset, tree decl,
490 : : bool non_negative_offset, tree vptr)
491 : : {
492 : 1381116 : tree type = TREE_TYPE (base);
493 : 1381116 : tree span = NULL_TREE;
494 : :
495 : 1381116 : if (GFC_ARRAY_TYPE_P (type) && GFC_TYPE_ARRAY_RANK (type) == 0)
496 : : {
497 : 72 : gcc_assert (GFC_TYPE_ARRAY_CORANK (type) > 0);
498 : :
499 : 72 : return fold_convert (TYPE_MAIN_VARIANT (type), base);
500 : : }
501 : :
502 : : /* Scalar coarray, there is nothing to do. */
503 : 1381044 : if (TREE_CODE (type) != ARRAY_TYPE)
504 : : {
505 : 20 : gcc_assert (decl == NULL_TREE);
506 : 20 : gcc_assert (integer_zerop (offset));
507 : : return base;
508 : : }
509 : :
510 : 1381024 : type = TREE_TYPE (type);
511 : :
512 : 1381024 : if (DECL_P (base))
513 : 192733 : TREE_ADDRESSABLE (base) = 1;
514 : :
515 : : /* Strip NON_LVALUE_EXPR nodes. */
516 : 1415222 : STRIP_TYPE_NOPS (offset);
517 : :
518 : : /* If decl or vptr are non-null, pointer arithmetic for the array reference
519 : : is likely. Generate the 'span' for the array reference. */
520 : 1381024 : if (vptr)
521 : : {
522 : 3251 : span = gfc_vptr_size_get (vptr);
523 : :
524 : : /* Check if this is an unlimited polymorphic object carrying a character
525 : : payload. In this case, the 'len' field is non-zero. */
526 : 3251 : if (decl && GFC_CLASS_TYPE_P (TREE_TYPE (decl)))
527 : 98 : span = gfc_resize_class_size_with_len (NULL, decl, span);
528 : : }
529 : 1377773 : else if (decl)
530 : 19587 : span = get_array_span (type, decl);
531 : :
532 : : /* If a non-null span has been generated reference the element with
533 : : pointer arithmetic. */
534 : 22838 : if (span != NULL_TREE)
535 : 22663 : return gfc_build_spanned_array_ref (base, offset, span);
536 : : /* Else use a straightforward array reference if possible. */
537 : 1358361 : else if (non_negative_offset)
538 : 1316111 : return build4_loc (input_location, ARRAY_REF, type, base, offset,
539 : 1316111 : NULL_TREE, NULL_TREE);
540 : : /* Otherwise use pointer arithmetic. */
541 : : else
542 : : {
543 : 42250 : gcc_assert (TREE_CODE (TREE_TYPE (base)) == ARRAY_TYPE);
544 : 42250 : tree min = NULL_TREE;
545 : 42250 : if (TYPE_DOMAIN (TREE_TYPE (base))
546 : 42250 : && !integer_zerop (TYPE_MIN_VALUE (TYPE_DOMAIN (TREE_TYPE (base)))))
547 : 319 : min = TYPE_MIN_VALUE (TYPE_DOMAIN (TREE_TYPE (base)));
548 : :
549 : 319 : tree zero_based_index
550 : 319 : = min ? fold_build2_loc (input_location, MINUS_EXPR,
551 : : gfc_array_index_type,
552 : : fold_convert (gfc_array_index_type, offset),
553 : : fold_convert (gfc_array_index_type, min))
554 : 41931 : : fold_convert (gfc_array_index_type, offset);
555 : :
556 : 42250 : tree elt_size = fold_convert (gfc_array_index_type,
557 : : TYPE_SIZE_UNIT (type));
558 : :
559 : 42250 : tree offset_bytes = fold_build2_loc (input_location, MULT_EXPR,
560 : : gfc_array_index_type,
561 : : zero_based_index, elt_size);
562 : :
563 : 42250 : tree base_addr = gfc_build_addr_expr (pvoid_type_node, base);
564 : :
565 : 42250 : tree ptr = fold_build_pointer_plus_loc (input_location, base_addr,
566 : : offset_bytes);
567 : 42250 : return build1_loc (input_location, INDIRECT_REF, type,
568 : 42250 : fold_convert (build_pointer_type (type), ptr));
569 : : }
570 : : }
571 : :
572 : :
573 : : /* Generate a call to print a runtime error possibly including multiple
574 : : arguments and a locus. */
575 : :
576 : : static tree
577 : 78567 : trans_runtime_error_vararg (tree errorfunc, locus* where, const char* msgid,
578 : : va_list ap)
579 : : {
580 : 78567 : stmtblock_t block;
581 : 78567 : tree tmp;
582 : 78567 : tree arg, arg2;
583 : 78567 : tree *argarray;
584 : 78567 : tree fntype;
585 : 78567 : char *message;
586 : 78567 : const char *p;
587 : 78567 : int nargs, i;
588 : 78567 : location_t loc;
589 : :
590 : : /* Compute the number of extra arguments from the format string. */
591 : 4181574 : for (p = msgid, nargs = 0; *p; p++)
592 : 4103007 : if (*p == '%')
593 : : {
594 : 114401 : p++;
595 : 114401 : if (*p != '%')
596 : 113672 : nargs++;
597 : : }
598 : :
599 : : /* The code to generate the error. */
600 : 78567 : gfc_start_block (&block);
601 : :
602 : 78567 : if (where)
603 : : {
604 : 60183 : location_t loc = gfc_get_location (where);
605 : 60183 : message = xasprintf ("At line %d of file %s", LOCATION_LINE (loc),
606 : 120366 : LOCATION_FILE (loc));
607 : : }
608 : : else
609 : 18384 : message = xasprintf ("In file '%s', around line %d",
610 : 36768 : gfc_source_file, LOCATION_LINE (input_location));
611 : :
612 : 78567 : arg = gfc_build_addr_expr (pchar_type_node,
613 : : gfc_build_localized_cstring_const (message));
614 : 78567 : free (message);
615 : :
616 : 78567 : message = xasprintf ("%s", _(msgid));
617 : 78567 : arg2 = gfc_build_addr_expr (pchar_type_node,
618 : : gfc_build_localized_cstring_const (message));
619 : 78567 : free (message);
620 : :
621 : : /* Build the argument array. */
622 : 78567 : argarray = XALLOCAVEC (tree, nargs + 2);
623 : 78567 : argarray[0] = arg;
624 : 78567 : argarray[1] = arg2;
625 : 192239 : for (i = 0; i < nargs; i++)
626 : 113672 : argarray[2 + i] = va_arg (ap, tree);
627 : :
628 : : /* Build the function call to runtime_(warning,error)_at; because of the
629 : : variable number of arguments, we can't use build_call_expr_loc dinput_location,
630 : : irectly. */
631 : 78567 : fntype = TREE_TYPE (errorfunc);
632 : :
633 : 78567 : loc = where ? gfc_get_location (where) : input_location;
634 : 78567 : tmp = fold_build_call_array_loc (loc, TREE_TYPE (fntype),
635 : : fold_build1_loc (loc, ADDR_EXPR,
636 : : build_pointer_type (fntype),
637 : : errorfunc),
638 : : nargs + 2, argarray);
639 : 78567 : gfc_add_expr_to_block (&block, tmp);
640 : :
641 : 78567 : return gfc_finish_block (&block);
642 : : }
643 : :
644 : :
645 : : tree
646 : 22826 : gfc_trans_runtime_error (bool error, locus* where, const char* msgid, ...)
647 : : {
648 : 22826 : va_list ap;
649 : 22826 : tree result;
650 : :
651 : 22826 : va_start (ap, msgid);
652 : 22826 : result = trans_runtime_error_vararg (error
653 : : ? gfor_fndecl_runtime_error_at
654 : : : gfor_fndecl_runtime_warning_at,
655 : : where, msgid, ap);
656 : 22826 : va_end (ap);
657 : 22826 : return result;
658 : : }
659 : :
660 : :
661 : : /* Generate a runtime error if COND is true. */
662 : :
663 : : void
664 : 164400 : gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock,
665 : : locus * where, const char * msgid, ...)
666 : : {
667 : 164400 : va_list ap;
668 : 164400 : stmtblock_t block;
669 : 164400 : tree body;
670 : 164400 : tree tmp;
671 : 164400 : tree tmpvar = NULL;
672 : :
673 : 164400 : if (integer_zerop (cond))
674 : 126983 : return;
675 : :
676 : 37417 : if (once)
677 : : {
678 : 954 : tmpvar = gfc_create_var (boolean_type_node, "print_warning");
679 : 954 : TREE_STATIC (tmpvar) = 1;
680 : 954 : DECL_INITIAL (tmpvar) = boolean_true_node;
681 : 954 : gfc_add_expr_to_block (pblock, tmpvar);
682 : : }
683 : :
684 : 37417 : gfc_start_block (&block);
685 : :
686 : : /* For error, runtime_error_at already implies PRED_NORETURN. */
687 : 37417 : if (!error && once)
688 : 954 : gfc_add_expr_to_block (&block, build_predict_expr (PRED_FORTRAN_WARN_ONCE,
689 : : NOT_TAKEN));
690 : :
691 : : /* The code to generate the error. */
692 : 37417 : va_start (ap, msgid);
693 : 37417 : gfc_add_expr_to_block (&block,
694 : : trans_runtime_error_vararg
695 : : (error ? gfor_fndecl_runtime_error_at
696 : : : gfor_fndecl_runtime_warning_at,
697 : : where, msgid, ap));
698 : 37417 : va_end (ap);
699 : :
700 : 37417 : if (once)
701 : 954 : gfc_add_modify (&block, tmpvar, boolean_false_node);
702 : :
703 : 37417 : body = gfc_finish_block (&block);
704 : :
705 : 37417 : if (integer_onep (cond))
706 : : {
707 : 892 : gfc_add_expr_to_block (pblock, body);
708 : : }
709 : : else
710 : : {
711 : 36525 : location_t loc = where ? gfc_get_location (where) : input_location;
712 : 36525 : if (once)
713 : 86 : cond = fold_build2_loc (loc, TRUTH_AND_EXPR, boolean_type_node, tmpvar,
714 : : fold_convert (boolean_type_node, cond));
715 : :
716 : 36525 : tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, cond, body,
717 : : build_empty_stmt (loc));
718 : 36525 : gfc_add_expr_to_block (pblock, tmp);
719 : : }
720 : : }
721 : :
722 : :
723 : : static tree
724 : 18324 : trans_os_error_at (locus* where, const char* msgid, ...)
725 : : {
726 : 18324 : va_list ap;
727 : 18324 : tree result;
728 : :
729 : 18324 : va_start (ap, msgid);
730 : 18324 : result = trans_runtime_error_vararg (gfor_fndecl_os_error_at,
731 : : where, msgid, ap);
732 : 18324 : va_end (ap);
733 : 18324 : return result;
734 : : }
735 : :
736 : :
737 : :
738 : : /* Call malloc to allocate size bytes of memory, with special conditions:
739 : : + if size == 0, return a malloced area of size 1,
740 : : + if malloc returns NULL, issue a runtime error. */
741 : : tree
742 : 19380 : gfc_call_malloc (stmtblock_t * block, tree type, tree size)
743 : : {
744 : 19380 : tree tmp, malloc_result, null_result, res, malloc_tree;
745 : 19380 : stmtblock_t block2;
746 : :
747 : : /* Create a variable to hold the result. */
748 : 19380 : res = gfc_create_var (prvoid_type_node, NULL);
749 : :
750 : : /* Call malloc. */
751 : 19380 : gfc_start_block (&block2);
752 : :
753 : 19380 : if (size == NULL_TREE)
754 : 1 : size = build_int_cst (size_type_node, 1);
755 : :
756 : 19380 : size = fold_convert (size_type_node, size);
757 : 19380 : size = fold_build2_loc (input_location, MAX_EXPR, size_type_node, size,
758 : 19380 : build_int_cst (size_type_node, 1));
759 : :
760 : 19380 : malloc_tree = builtin_decl_explicit (BUILT_IN_MALLOC);
761 : 19380 : gfc_add_modify (&block2, res,
762 : : fold_convert (prvoid_type_node,
763 : : build_call_expr_loc (input_location,
764 : : malloc_tree, 1, size)));
765 : :
766 : : /* Optionally check whether malloc was successful. */
767 : 19380 : if (gfc_option.rtcheck & GFC_RTCHECK_MEM)
768 : : {
769 : 105 : null_result = fold_build2_loc (input_location, EQ_EXPR,
770 : : logical_type_node, res,
771 : 105 : build_int_cst (pvoid_type_node, 0));
772 : 105 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
773 : : null_result,
774 : : trans_os_error_at (NULL,
775 : : "Error allocating %lu bytes",
776 : : fold_convert
777 : : (long_unsigned_type_node,
778 : : size)),
779 : : build_empty_stmt (input_location));
780 : 105 : gfc_add_expr_to_block (&block2, tmp);
781 : : }
782 : :
783 : 19380 : malloc_result = gfc_finish_block (&block2);
784 : 19380 : gfc_add_expr_to_block (block, malloc_result);
785 : :
786 : 19380 : if (type != NULL)
787 : 14535 : res = fold_convert (type, res);
788 : 19380 : return res;
789 : : }
790 : :
791 : :
792 : : /* Allocate memory, using an optional status argument.
793 : :
794 : : This function follows the following pseudo-code:
795 : :
796 : : void *
797 : : allocate (size_t size, integer_type stat)
798 : : {
799 : : void *newmem;
800 : :
801 : : if (stat requested)
802 : : stat = 0;
803 : :
804 : : // if cond == NULL_NULL:
805 : : newmem = malloc (MAX (size, 1));
806 : : // otherwise:
807 : : newmem = <cond> ? <alt_alloc> : malloc (MAX (size, 1))
808 : : if (newmem == NULL)
809 : : {
810 : : if (stat)
811 : : *stat = LIBERROR_NO_MEMORY;
812 : : else
813 : : runtime_error ("Allocation would exceed memory limit");
814 : : }
815 : : return newmem;
816 : : } */
817 : : void
818 : 17320 : gfc_allocate_using_malloc (stmtblock_t * block, tree pointer,
819 : : tree size, tree status, tree cond, tree alt_alloc,
820 : : tree extra_success_expr)
821 : : {
822 : 17320 : tree tmp, error_cond;
823 : 17320 : stmtblock_t on_error;
824 : 17320 : tree status_type = status ? TREE_TYPE (status) : NULL_TREE;
825 : :
826 : : /* If successful and stat= is given, set status to 0. */
827 : 265 : if (status != NULL_TREE)
828 : 265 : gfc_add_expr_to_block (block,
829 : : fold_build2_loc (input_location, MODIFY_EXPR, status_type,
830 : 265 : status, build_int_cst (status_type, 0)));
831 : :
832 : : /* The allocation itself. */
833 : 17320 : size = fold_convert (size_type_node, size);
834 : 17320 : tmp = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
835 : 17320 : size, build_int_cst (size_type_node, 1));
836 : :
837 : 17320 : tmp = build_call_expr_loc (input_location,
838 : : builtin_decl_explicit (BUILT_IN_MALLOC), 1, tmp);
839 : 17320 : if (cond == boolean_true_node)
840 : : tmp = alt_alloc;
841 : 17262 : else if (cond)
842 : 0 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond,
843 : : alt_alloc, tmp);
844 : :
845 : 17320 : gfc_add_modify (block, pointer, fold_convert (TREE_TYPE (pointer), tmp));
846 : :
847 : : /* What to do in case of error. */
848 : 17320 : gfc_start_block (&on_error);
849 : 17320 : if (status != NULL_TREE)
850 : : {
851 : 265 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, status,
852 : 265 : build_int_cst (status_type, LIBERROR_NO_MEMORY));
853 : 265 : gfc_add_expr_to_block (&on_error, tmp);
854 : : }
855 : : else
856 : : {
857 : : /* Here, os_error_at already implies PRED_NORETURN. */
858 : 17055 : tree lusize = fold_convert (long_unsigned_type_node, size);
859 : 17055 : tmp = trans_os_error_at (NULL, "Error allocating %lu bytes", lusize);
860 : 17055 : gfc_add_expr_to_block (&on_error, tmp);
861 : : }
862 : :
863 : 17320 : error_cond = fold_build2_loc (input_location, EQ_EXPR,
864 : : logical_type_node, pointer,
865 : 17320 : build_int_cst (prvoid_type_node, 0));
866 : 34582 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
867 : : gfc_unlikely (error_cond, PRED_FORTRAN_FAIL_ALLOC),
868 : : gfc_finish_block (&on_error),
869 : : extra_success_expr
870 : : ? extra_success_expr
871 : 17262 : : build_empty_stmt (input_location));
872 : :
873 : 17320 : gfc_add_expr_to_block (block, tmp);
874 : 17320 : }
875 : :
876 : :
877 : : /* Allocate memory, using an optional status argument.
878 : :
879 : : This function follows the following pseudo-code:
880 : :
881 : : void *
882 : : allocate (size_t size, void** token, int *stat, char* errmsg, int errlen)
883 : : {
884 : : void *newmem;
885 : :
886 : : newmem = _caf_register (size, regtype, token, &stat, errmsg, errlen);
887 : : return newmem;
888 : : } */
889 : : void
890 : 622 : gfc_allocate_using_caf_lib (stmtblock_t * block, tree pointer, tree size,
891 : : tree token, tree status, tree errmsg, tree errlen,
892 : : gfc_coarray_regtype alloc_type)
893 : : {
894 : 622 : tree tmp, pstat;
895 : :
896 : 622 : gcc_assert (token != NULL_TREE);
897 : :
898 : : /* The allocation itself. */
899 : 622 : if (status == NULL_TREE)
900 : 609 : pstat = null_pointer_node;
901 : : else
902 : 13 : pstat = gfc_build_addr_expr (NULL_TREE, status);
903 : :
904 : 622 : if (errmsg == NULL_TREE)
905 : : {
906 : 609 : gcc_assert(errlen == NULL_TREE);
907 : 609 : errmsg = null_pointer_node;
908 : 609 : errlen = integer_zero_node;
909 : : }
910 : :
911 : 622 : size = fold_convert (size_type_node, size);
912 : 622 : tmp = build_call_expr_loc (input_location,
913 : : gfor_fndecl_caf_register, 7,
914 : : fold_build2_loc (input_location,
915 : : MAX_EXPR, size_type_node, size, size_one_node),
916 : 622 : build_int_cst (integer_type_node, alloc_type),
917 : : token, gfc_build_addr_expr (pvoid_type_node, pointer),
918 : : pstat, errmsg, errlen);
919 : :
920 : 622 : gfc_add_expr_to_block (block, tmp);
921 : :
922 : : /* It guarantees memory consistency within the same segment */
923 : 622 : tmp = gfc_build_string_const (strlen ("memory")+1, "memory"),
924 : 622 : tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
925 : : gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
926 : : tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
927 : 622 : ASM_VOLATILE_P (tmp) = 1;
928 : 622 : gfc_add_expr_to_block (block, tmp);
929 : 622 : }
930 : :
931 : :
932 : : /* Generate code for an ALLOCATE statement when the argument is an
933 : : allocatable variable. If the variable is currently allocated, it is an
934 : : error to allocate it again.
935 : :
936 : : This function follows the following pseudo-code:
937 : :
938 : : void *
939 : : allocate_allocatable (void *mem, size_t size, integer_type stat)
940 : : {
941 : : if (mem == NULL)
942 : : return allocate (size, stat);
943 : : else
944 : : {
945 : : if (stat)
946 : : stat = LIBERROR_ALLOCATION;
947 : : else
948 : : runtime_error ("Attempting to allocate already allocated variable");
949 : : }
950 : : }
951 : :
952 : : expr must be set to the original expression being allocated for its locus
953 : : and variable name in case a runtime error has to be printed. */
954 : : void
955 : 12896 : gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size,
956 : : tree token, tree status, tree errmsg, tree errlen,
957 : : tree label_finish, gfc_expr* expr, int corank,
958 : : tree cond, tree alt_alloc, tree extra_success_expr)
959 : : {
960 : 12896 : stmtblock_t alloc_block;
961 : 12896 : tree tmp, null_mem, alloc, error;
962 : 12896 : tree type = TREE_TYPE (mem);
963 : 12896 : symbol_attribute caf_attr;
964 : 12896 : bool need_assign = false, refs_comp = false;
965 : 12896 : gfc_coarray_regtype caf_alloc_type = GFC_CAF_COARRAY_ALLOC;
966 : :
967 : 12896 : size = fold_convert (size_type_node, size);
968 : 12896 : null_mem = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
969 : : logical_type_node, mem,
970 : 12896 : build_int_cst (type, 0)),
971 : : PRED_FORTRAN_REALLOC);
972 : :
973 : : /* If mem is NULL, we call gfc_allocate_using_malloc or
974 : : gfc_allocate_using_lib. */
975 : 12896 : gfc_start_block (&alloc_block);
976 : :
977 : 12896 : if (flag_coarray == GFC_FCOARRAY_LIB)
978 : 352 : caf_attr = gfc_caf_attr (expr, true, &refs_comp);
979 : :
980 : 12896 : if (flag_coarray == GFC_FCOARRAY_LIB
981 : 352 : && (corank > 0 || caf_attr.codimension))
982 : : {
983 : 317 : tree cond2, sub_caf_tree;
984 : 317 : gfc_se se;
985 : 317 : bool compute_special_caf_types_size = false;
986 : :
987 : 317 : if (expr->ts.type == BT_DERIVED
988 : 83 : && expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
989 : 83 : && expr->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
990 : : {
991 : : compute_special_caf_types_size = true;
992 : : caf_alloc_type = GFC_CAF_LOCK_ALLOC;
993 : : }
994 : 313 : else if (expr->ts.type == BT_DERIVED
995 : 79 : && expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
996 : 79 : && expr->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
997 : : {
998 : : compute_special_caf_types_size = true;
999 : : caf_alloc_type = GFC_CAF_EVENT_ALLOC;
1000 : : }
1001 : 312 : else if (!caf_attr.coarray_comp && refs_comp)
1002 : : /* Only allocatable components in a derived type coarray can be
1003 : : allocate only. */
1004 : 317 : caf_alloc_type = GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY;
1005 : :
1006 : 317 : gfc_init_se (&se, NULL);
1007 : 317 : sub_caf_tree = gfc_get_ultimate_alloc_ptr_comps_caf_token (&se, expr);
1008 : 317 : if (sub_caf_tree == NULL_TREE)
1009 : 128 : sub_caf_tree = token;
1010 : :
1011 : : /* When mem is an array ref, then strip the .data-ref. */
1012 : 317 : if (TREE_CODE (mem) == COMPONENT_REF
1013 : 317 : && !(GFC_ARRAY_TYPE_P (TREE_TYPE (mem))))
1014 : 317 : tmp = TREE_OPERAND (mem, 0);
1015 : : else
1016 : : tmp = mem;
1017 : :
1018 : 317 : if (!(GFC_ARRAY_TYPE_P (TREE_TYPE (tmp))
1019 : 47 : && TYPE_LANG_SPECIFIC (TREE_TYPE (tmp))->corank == 0)
1020 : 364 : && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
1021 : : {
1022 : 96 : symbol_attribute attr;
1023 : :
1024 : 96 : gfc_clear_attr (&attr);
1025 : 96 : tmp = gfc_conv_scalar_to_descriptor (&se, mem, attr);
1026 : 96 : need_assign = true;
1027 : : }
1028 : 317 : gfc_add_block_to_block (&alloc_block, &se.pre);
1029 : :
1030 : : /* In the front end, we represent the lock variable as pointer. However,
1031 : : the FE only passes the pointer around and leaves the actual
1032 : : representation to the library. Hence, we have to convert back to the
1033 : : number of elements. */
1034 : 317 : if (compute_special_caf_types_size)
1035 : 5 : size = fold_build2_loc (input_location, TRUNC_DIV_EXPR, size_type_node,
1036 : 5 : size, TYPE_SIZE_UNIT (ptr_type_node));
1037 : :
1038 : 317 : gfc_allocate_using_caf_lib (&alloc_block, tmp, size, sub_caf_tree,
1039 : : status, errmsg, errlen, caf_alloc_type);
1040 : 317 : if (need_assign)
1041 : 96 : gfc_add_modify (&alloc_block, mem, fold_convert (TREE_TYPE (mem),
1042 : : gfc_conv_descriptor_data_get (tmp)));
1043 : 317 : if (status != NULL_TREE)
1044 : : {
1045 : 13 : TREE_USED (label_finish) = 1;
1046 : 13 : tmp = build1_v (GOTO_EXPR, label_finish);
1047 : 13 : cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1048 : 13 : status, build_zero_cst (TREE_TYPE (status)));
1049 : 13 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1050 : : gfc_unlikely (cond2, PRED_FORTRAN_FAIL_ALLOC),
1051 : : tmp, build_empty_stmt (input_location));
1052 : 13 : gfc_add_expr_to_block (&alloc_block, tmp);
1053 : : }
1054 : 317 : }
1055 : : else
1056 : 12579 : gfc_allocate_using_malloc (&alloc_block, mem, size, status,
1057 : : cond, alt_alloc, extra_success_expr);
1058 : :
1059 : 12896 : alloc = gfc_finish_block (&alloc_block);
1060 : :
1061 : : /* If mem is not NULL, we issue a runtime error or set the
1062 : : status variable. */
1063 : 12896 : if (expr)
1064 : : {
1065 : 12896 : tree varname;
1066 : :
1067 : 12896 : gcc_assert (expr->expr_type == EXPR_VARIABLE && expr->symtree);
1068 : 12896 : varname = gfc_build_cstring_const (expr->symtree->name);
1069 : 12896 : varname = gfc_build_addr_expr (pchar_type_node, varname);
1070 : :
1071 : 12896 : error = gfc_trans_runtime_error (true, &expr->where,
1072 : : "Attempting to allocate already"
1073 : : " allocated variable '%s'",
1074 : : varname);
1075 : : }
1076 : : else
1077 : 0 : error = gfc_trans_runtime_error (true, NULL,
1078 : : "Attempting to allocate already allocated"
1079 : : " variable");
1080 : :
1081 : 12896 : if (status != NULL_TREE)
1082 : : {
1083 : 256 : tree status_type = TREE_TYPE (status);
1084 : :
1085 : 256 : error = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
1086 : 256 : status, build_int_cst (status_type, LIBERROR_ALLOCATION));
1087 : : }
1088 : :
1089 : 12896 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, null_mem,
1090 : : error, alloc);
1091 : 12896 : gfc_add_expr_to_block (block, tmp);
1092 : 12896 : }
1093 : :
1094 : :
1095 : : /* Free a given variable. */
1096 : :
1097 : : tree
1098 : 21721 : gfc_call_free (tree var)
1099 : : {
1100 : 21721 : return build_call_expr_loc (input_location,
1101 : : builtin_decl_explicit (BUILT_IN_FREE),
1102 : 21721 : 1, fold_convert (pvoid_type_node, var));
1103 : : }
1104 : :
1105 : :
1106 : : /* Generate the data reference to the finalization procedure pointer associated
1107 : : with the expression passed as argument in EXPR. */
1108 : :
1109 : : static void
1110 : 4557 : get_final_proc_ref (gfc_se *se, gfc_expr *expr, tree class_container)
1111 : : {
1112 : 4557 : gfc_expr *final_wrapper = NULL;
1113 : :
1114 : 4557 : gcc_assert (expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS);
1115 : :
1116 : 4557 : bool using_class_container = false;
1117 : 4557 : if (expr->ts.type == BT_DERIVED)
1118 : 687 : gfc_is_finalizable (expr->ts.u.derived, &final_wrapper);
1119 : 3870 : else if (class_container)
1120 : : {
1121 : 266 : using_class_container = true;
1122 : 266 : se->expr = gfc_class_vtab_final_get (class_container);
1123 : : }
1124 : : else
1125 : : {
1126 : 3604 : final_wrapper = gfc_copy_expr (expr);
1127 : 3604 : gfc_add_vptr_component (final_wrapper);
1128 : 3604 : gfc_add_final_component (final_wrapper);
1129 : : }
1130 : :
1131 : 4557 : if (!using_class_container)
1132 : : {
1133 : 4291 : gcc_assert (final_wrapper->expr_type == EXPR_VARIABLE);
1134 : :
1135 : 4291 : gfc_conv_expr (se, final_wrapper);
1136 : : }
1137 : :
1138 : 4557 : if (POINTER_TYPE_P (TREE_TYPE (se->expr)))
1139 : 953 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
1140 : :
1141 : 4557 : if (expr->ts.type != BT_DERIVED && !using_class_container)
1142 : 3604 : gfc_free_expr (final_wrapper);
1143 : 4557 : }
1144 : :
1145 : :
1146 : : /* Generate the code to obtain the value of the element size of the expression
1147 : : passed as argument in EXPR. */
1148 : :
1149 : : static void
1150 : 4557 : get_elem_size (gfc_se *se, gfc_expr *expr, tree class_container)
1151 : : {
1152 : 4557 : gcc_assert (expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS);
1153 : :
1154 : 4557 : if (expr->ts.type == BT_DERIVED)
1155 : : {
1156 : 687 : se->expr = gfc_typenode_for_spec (&expr->ts);
1157 : 687 : se->expr = TYPE_SIZE_UNIT (se->expr);
1158 : 687 : se->expr = fold_convert (gfc_array_index_type, se->expr);
1159 : : }
1160 : 3870 : else if (class_container)
1161 : 266 : se->expr = gfc_class_vtab_size_get (class_container);
1162 : : else
1163 : : {
1164 : 3604 : gfc_expr *class_size = gfc_copy_expr (expr);
1165 : 3604 : gfc_add_vptr_component (class_size);
1166 : 3604 : gfc_add_size_component (class_size);
1167 : :
1168 : 3604 : gfc_conv_expr (se, class_size);
1169 : 3604 : gcc_assert (se->post.head == NULL_TREE);
1170 : 3604 : gfc_free_expr (class_size);
1171 : : }
1172 : 4557 : }
1173 : :
1174 : :
1175 : : /* Generate the data reference (array) descriptor corresponding to the
1176 : : expression passed as argument in VAR. */
1177 : :
1178 : : static void
1179 : 4557 : get_var_descr (gfc_se *se, gfc_expr *var, tree class_container)
1180 : : {
1181 : 4557 : gfc_se tmp_se;
1182 : :
1183 : 4557 : gcc_assert (var);
1184 : :
1185 : 4557 : gfc_init_se (&tmp_se, NULL);
1186 : :
1187 : 4557 : if (var->ts.type == BT_DERIVED)
1188 : : {
1189 : 687 : tmp_se.want_pointer = 1;
1190 : 687 : if (var->rank)
1191 : : {
1192 : 164 : tmp_se.descriptor_only = 1;
1193 : 164 : gfc_conv_expr_descriptor (&tmp_se, var);
1194 : : }
1195 : : else
1196 : 523 : gfc_conv_expr (&tmp_se, var);
1197 : : }
1198 : 3870 : else if (class_container)
1199 : 266 : tmp_se.expr = gfc_class_data_get (class_container);
1200 : : else
1201 : : {
1202 : 3604 : gfc_expr *array_expr;
1203 : :
1204 : 3604 : array_expr = gfc_copy_expr (var);
1205 : :
1206 : 3604 : tmp_se.want_pointer = 1;
1207 : 3604 : if (array_expr->rank)
1208 : : {
1209 : 1893 : gfc_add_class_array_ref (array_expr);
1210 : 1893 : tmp_se.descriptor_only = 1;
1211 : 1893 : gfc_conv_expr_descriptor (&tmp_se, array_expr);
1212 : : }
1213 : : else
1214 : : {
1215 : 1711 : gfc_add_data_component (array_expr);
1216 : 1711 : gfc_conv_expr (&tmp_se, array_expr);
1217 : 1711 : gcc_assert (tmp_se.post.head == NULL_TREE);
1218 : : }
1219 : 3604 : gfc_free_expr (array_expr);
1220 : : }
1221 : :
1222 : 4557 : if (var->rank == 0)
1223 : : {
1224 : 2390 : if (var->ts.type == BT_DERIVED
1225 : 2390 : || !gfc_is_coarray (var))
1226 : : {
1227 : : /* No copy back needed, hence set attr's allocatable/pointer
1228 : : to zero. */
1229 : 2350 : symbol_attribute attr;
1230 : 2350 : gfc_clear_attr (&attr);
1231 : 2350 : tmp_se.expr = gfc_conv_scalar_to_descriptor (&tmp_se, tmp_se.expr,
1232 : : attr);
1233 : : }
1234 : 2390 : gcc_assert (tmp_se.post.head == NULL_TREE);
1235 : : }
1236 : :
1237 : 4557 : if (!POINTER_TYPE_P (TREE_TYPE (tmp_se.expr)))
1238 : 2460 : tmp_se.expr = gfc_build_addr_expr (NULL, tmp_se.expr);
1239 : :
1240 : 4557 : gfc_add_block_to_block (&se->pre, &tmp_se.pre);
1241 : 4557 : gfc_add_block_to_block (&se->post, &tmp_se.post);
1242 : 4557 : se->expr = tmp_se.expr;
1243 : 4557 : }
1244 : :
1245 : :
1246 : : static void
1247 : 1013 : get_vptr (gfc_se *se, gfc_expr *expr, tree class_container)
1248 : : {
1249 : 1013 : if (class_container)
1250 : 42 : se->expr = gfc_class_vptr_get (class_container);
1251 : : else
1252 : : {
1253 : 971 : gfc_expr *vptr_expr = gfc_copy_expr (expr);
1254 : 971 : gfc_add_vptr_component (vptr_expr);
1255 : :
1256 : 971 : gfc_se tmp_se;
1257 : 971 : gfc_init_se (&tmp_se, NULL);
1258 : 971 : tmp_se.want_pointer = 1;
1259 : 971 : gfc_conv_expr (&tmp_se, vptr_expr);
1260 : 971 : gfc_free_expr (vptr_expr);
1261 : :
1262 : 971 : gfc_add_block_to_block (&se->pre, &tmp_se.pre);
1263 : 971 : gfc_add_block_to_block (&se->post, &tmp_se.post);
1264 : 971 : se->expr = tmp_se.expr;
1265 : : }
1266 : 1013 : }
1267 : :
1268 : :
1269 : : bool
1270 : 2703 : gfc_add_comp_finalizer_call (stmtblock_t *block, tree decl, gfc_component *comp,
1271 : : bool fini_coarray)
1272 : : {
1273 : 2703 : gfc_se se;
1274 : 2703 : stmtblock_t block2;
1275 : 2703 : tree final_fndecl, size, array, tmp, cond;
1276 : 2703 : symbol_attribute attr;
1277 : 2703 : gfc_expr *final_expr = NULL;
1278 : :
1279 : 2703 : if (comp->ts.type != BT_DERIVED && comp->ts.type != BT_CLASS)
1280 : : return false;
1281 : :
1282 : 2703 : gfc_init_block (&block2);
1283 : :
1284 : 2703 : if (comp->ts.type == BT_DERIVED)
1285 : : {
1286 : 1820 : if (comp->attr.pointer)
1287 : : return false;
1288 : :
1289 : 1820 : gfc_is_finalizable (comp->ts.u.derived, &final_expr);
1290 : 1820 : if (!final_expr)
1291 : : return false;
1292 : :
1293 : 27 : gfc_init_se (&se, NULL);
1294 : 27 : gfc_conv_expr (&se, final_expr);
1295 : 27 : final_fndecl = se.expr;
1296 : 27 : size = gfc_typenode_for_spec (&comp->ts);
1297 : 27 : size = TYPE_SIZE_UNIT (size);
1298 : 27 : size = fold_convert (gfc_array_index_type, size);
1299 : :
1300 : 27 : array = decl;
1301 : : }
1302 : : else /* comp->ts.type == BT_CLASS. */
1303 : : {
1304 : 883 : if (CLASS_DATA (comp)->attr.class_pointer)
1305 : : return false;
1306 : :
1307 : 883 : gfc_is_finalizable (CLASS_DATA (comp)->ts.u.derived, &final_expr);
1308 : 883 : final_fndecl = gfc_class_vtab_final_get (decl);
1309 : 883 : size = gfc_class_vtab_size_get (decl);
1310 : 883 : array = gfc_class_data_get (decl);
1311 : : }
1312 : :
1313 : 910 : if (comp->attr.allocatable
1314 : 883 : || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)->attr.allocatable))
1315 : : {
1316 : 910 : tmp = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array))
1317 : 910 : ? gfc_conv_descriptor_data_get (array) : array;
1318 : 910 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1319 : 910 : tmp, fold_convert (TREE_TYPE (tmp),
1320 : : null_pointer_node));
1321 : : }
1322 : : else
1323 : 0 : cond = logical_true_node;
1324 : :
1325 : 910 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array)))
1326 : : {
1327 : 483 : gfc_clear_attr (&attr);
1328 : 483 : gfc_init_se (&se, NULL);
1329 : 483 : array = gfc_conv_scalar_to_descriptor (&se, array, attr);
1330 : 483 : gfc_add_block_to_block (&block2, &se.pre);
1331 : 483 : gcc_assert (se.post.head == NULL_TREE);
1332 : : }
1333 : :
1334 : 910 : if (!POINTER_TYPE_P (TREE_TYPE (array)))
1335 : 910 : array = gfc_build_addr_expr (NULL, array);
1336 : :
1337 : 910 : if (!final_expr)
1338 : : {
1339 : 881 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1340 : : final_fndecl,
1341 : 881 : fold_convert (TREE_TYPE (final_fndecl),
1342 : : null_pointer_node));
1343 : 881 : cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
1344 : : logical_type_node, cond, tmp);
1345 : : }
1346 : :
1347 : 910 : if (POINTER_TYPE_P (TREE_TYPE (final_fndecl)))
1348 : 910 : final_fndecl = build_fold_indirect_ref_loc (input_location, final_fndecl);
1349 : :
1350 : 910 : tmp = build_call_expr_loc (input_location,
1351 : : final_fndecl, 3, array,
1352 : : size, fini_coarray ? boolean_true_node
1353 : : : boolean_false_node);
1354 : 910 : gfc_add_expr_to_block (&block2, tmp);
1355 : 910 : tmp = gfc_finish_block (&block2);
1356 : :
1357 : 910 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
1358 : : build_empty_stmt (input_location));
1359 : 910 : gfc_add_expr_to_block (block, tmp);
1360 : :
1361 : 910 : return true;
1362 : : }
1363 : :
1364 : :
1365 : : /* Add a call to the finalizer, using the passed *expr. Returns
1366 : : true when a finalizer call has been inserted. */
1367 : :
1368 : : bool
1369 : 25473 : gfc_add_finalizer_call (stmtblock_t *block, gfc_expr *expr2,
1370 : : tree class_container)
1371 : : {
1372 : 25473 : tree tmp;
1373 : 25473 : gfc_ref *ref;
1374 : 25473 : gfc_expr *expr;
1375 : :
1376 : 25473 : if (!expr2 || (expr2->ts.type != BT_DERIVED && expr2->ts.type != BT_CLASS))
1377 : : return false;
1378 : :
1379 : : /* Finalization of these temporaries is made by explicit calls in
1380 : : resolve.cc(generate_component_assignments). */
1381 : 6371 : if (expr2->expr_type == EXPR_VARIABLE
1382 : 6371 : && expr2->symtree->n.sym->name[0] == '_'
1383 : 91 : && expr2->ts.type == BT_DERIVED
1384 : 37 : && expr2->ts.u.derived->attr.defined_assign_comp)
1385 : : return false;
1386 : :
1387 : 6340 : if (expr2->ts.type == BT_DERIVED
1388 : 6340 : && !gfc_is_finalizable (expr2->ts.u.derived, NULL))
1389 : : return false;
1390 : :
1391 : : /* If we have a class array, we need go back to the class
1392 : : container. */
1393 : 4557 : expr = gfc_copy_expr (expr2);
1394 : :
1395 : 4557 : if (expr->ref && expr->ref->next && !expr->ref->next->next
1396 : 1003 : && expr->ref->next->type == REF_ARRAY
1397 : 936 : && expr->ref->type == REF_COMPONENT
1398 : 936 : && strcmp (expr->ref->u.c.component->name, "_data") == 0)
1399 : : {
1400 : 935 : gfc_free_ref_list (expr->ref);
1401 : 935 : expr->ref = NULL;
1402 : : }
1403 : : else
1404 : 5468 : for (ref = expr->ref; ref; ref = ref->next)
1405 : 1846 : if (ref->next && ref->next->next && !ref->next->next->next
1406 : 328 : && ref->next->next->type == REF_ARRAY
1407 : 309 : && ref->next->type == REF_COMPONENT
1408 : 309 : && strcmp (ref->next->u.c.component->name, "_data") == 0)
1409 : : {
1410 : 309 : gfc_free_ref_list (ref->next);
1411 : 309 : ref->next = NULL;
1412 : : }
1413 : :
1414 : 4557 : if (expr->ts.type == BT_CLASS && (!expr2->rank || !expr2->corank)
1415 : 3825 : && !expr2->ref && CLASS_DATA (expr2->symtree->n.sym)->as)
1416 : : {
1417 : 3 : expr->rank = CLASS_DATA (expr2->symtree->n.sym)->as->rank;
1418 : 3 : expr->corank = CLASS_DATA (expr2->symtree->n.sym)->as->corank;
1419 : : }
1420 : :
1421 : 4557 : stmtblock_t tmp_block;
1422 : 4557 : gfc_start_block (&tmp_block);
1423 : :
1424 : 4557 : gfc_se final_se;
1425 : 4557 : gfc_init_se (&final_se, NULL);
1426 : 4557 : get_final_proc_ref (&final_se, expr, class_container);
1427 : 4557 : gfc_add_block_to_block (block, &final_se.pre);
1428 : :
1429 : 4557 : gfc_se size_se;
1430 : 4557 : gfc_init_se (&size_se, NULL);
1431 : 4557 : get_elem_size (&size_se, expr, class_container);
1432 : 4557 : gfc_add_block_to_block (&tmp_block, &size_se.pre);
1433 : :
1434 : 4557 : gfc_se desc_se;
1435 : 4557 : gfc_init_se (&desc_se, NULL);
1436 : 4557 : get_var_descr (&desc_se, expr, class_container);
1437 : 4557 : gfc_add_block_to_block (&tmp_block, &desc_se.pre);
1438 : :
1439 : 4557 : tmp = build_call_expr_loc (input_location, final_se.expr, 3,
1440 : : desc_se.expr, size_se.expr,
1441 : : boolean_false_node);
1442 : :
1443 : 4557 : gfc_add_expr_to_block (&tmp_block, tmp);
1444 : :
1445 : 4557 : gfc_add_block_to_block (&tmp_block, &desc_se.post);
1446 : 4557 : gfc_add_block_to_block (&tmp_block, &size_se.post);
1447 : :
1448 : 4557 : tmp = gfc_finish_block (&tmp_block);
1449 : :
1450 : 4557 : if (expr->ts.type == BT_CLASS
1451 : 4557 : && !gfc_is_finalizable (expr->ts.u.derived, NULL))
1452 : : {
1453 : 3870 : tree cond;
1454 : :
1455 : 3870 : tree ptr = gfc_build_addr_expr (NULL_TREE, final_se.expr);
1456 : :
1457 : 3870 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1458 : 3870 : ptr, build_int_cst (TREE_TYPE (ptr), 0));
1459 : :
1460 : : /* For CLASS(*) not only sym->_vtab->_final can be NULL
1461 : : but already sym->_vtab itself. */
1462 : 3870 : if (UNLIMITED_POLY (expr))
1463 : : {
1464 : 1013 : tree cond2;
1465 : 1013 : gfc_se vptr_se;
1466 : :
1467 : 1013 : gfc_init_se (&vptr_se, NULL);
1468 : 1013 : get_vptr (&vptr_se, expr, class_container);
1469 : :
1470 : 1013 : cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1471 : : vptr_se.expr,
1472 : 1013 : build_int_cst (TREE_TYPE (vptr_se.expr), 0));
1473 : 1013 : cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
1474 : : logical_type_node, cond2, cond);
1475 : : }
1476 : :
1477 : 3870 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1478 : : cond, tmp, build_empty_stmt (input_location));
1479 : : }
1480 : :
1481 : 4557 : gfc_add_expr_to_block (block, tmp);
1482 : 4557 : gfc_add_block_to_block (block, &final_se.post);
1483 : 4557 : gfc_free_expr (expr);
1484 : :
1485 : 4557 : return true;
1486 : : }
1487 : :
1488 : :
1489 : : /* F2018 (7.5.6.3): "When an intrinsic assignment statement is executed
1490 : : (10.2.1.3), if the variable is not an unallocated allocatable variable,
1491 : : it is finalized after evaluation of expr and before the definition of
1492 : : the variable. If the variable is an allocated allocatable variable, or
1493 : : has an allocated allocatable subobject, that would be deallocated by
1494 : : intrinsic assignment, the finalization occurs before the deallocation */
1495 : :
1496 : : bool
1497 : 297077 : gfc_assignment_finalizer_call (gfc_se *lse, gfc_expr *expr1, bool init_flag)
1498 : : {
1499 : 297077 : symbol_attribute lhs_attr;
1500 : 297077 : tree final_expr;
1501 : 297077 : tree ptr;
1502 : 297077 : tree cond;
1503 : 297077 : gfc_se se;
1504 : 297077 : gfc_symbol *sym = expr1->symtree->n.sym;
1505 : 297077 : gfc_ref *ref = expr1->ref;
1506 : 297077 : stmtblock_t final_block;
1507 : 297077 : gfc_init_block (&final_block);
1508 : 297077 : gfc_expr *finalize_expr;
1509 : 297077 : bool class_array_ref;
1510 : :
1511 : : /* We have to exclude vtable procedures (_copy and _final especially), uses
1512 : : of gfc_trans_assignment_1 in initialization and allocation before trying
1513 : : to build a final call. */
1514 : 297077 : if (!expr1->must_finalize
1515 : 1059 : || sym->attr.artificial
1516 : 1059 : || sym->ns->proc_name->attr.artificial
1517 : 1059 : || init_flag)
1518 : : return false;
1519 : :
1520 : 672 : class_array_ref = ref && ref->type == REF_COMPONENT
1521 : 583 : && !strcmp (ref->u.c.component->name, "_data")
1522 : 491 : && ref->next && ref->next->type == REF_ARRAY
1523 : 1550 : && !ref->next->next;
1524 : :
1525 : 1059 : if (class_array_ref)
1526 : : {
1527 : 479 : finalize_expr = gfc_lval_expr_from_sym (sym);
1528 : 479 : finalize_expr->must_finalize = 1;
1529 : 479 : ref = NULL;
1530 : : }
1531 : : else
1532 : 580 : finalize_expr = gfc_copy_expr (expr1);
1533 : :
1534 : : /* F2018 7.5.6.2: Only finalizable entities are finalized. */
1535 : 226 : if (!(expr1->ts.type == BT_DERIVED
1536 : 226 : && gfc_is_finalizable (expr1->ts.u.derived, NULL))
1537 : 1059 : && expr1->ts.type != BT_CLASS)
1538 : : return false;
1539 : :
1540 : 1059 : if (!gfc_may_be_finalized (sym->ts))
1541 : : return false;
1542 : :
1543 : 1009 : gfc_init_block (&final_block);
1544 : 1009 : bool finalizable = gfc_add_finalizer_call (&final_block, finalize_expr);
1545 : 1009 : gfc_free_expr (finalize_expr);
1546 : :
1547 : 1009 : if (!finalizable)
1548 : : return false;
1549 : :
1550 : 1009 : lhs_attr = gfc_expr_attr (expr1);
1551 : :
1552 : : /* Check allocatable/pointer is allocated/associated. */
1553 : 1009 : if (lhs_attr.allocatable || lhs_attr.pointer)
1554 : : {
1555 : 861 : if (expr1->ts.type == BT_CLASS)
1556 : : {
1557 : 783 : ptr = gfc_get_class_from_gfc_expr (expr1);
1558 : 783 : gcc_assert (ptr != NULL_TREE);
1559 : 783 : ptr = gfc_class_data_get (ptr);
1560 : 783 : if (lhs_attr.dimension)
1561 : 536 : ptr = gfc_conv_descriptor_data_get (ptr);
1562 : : }
1563 : : else
1564 : : {
1565 : 78 : gfc_init_se (&se, NULL);
1566 : 78 : if (expr1->rank)
1567 : : {
1568 : 30 : gfc_conv_expr_descriptor (&se, expr1);
1569 : 30 : ptr = gfc_conv_descriptor_data_get (se.expr);
1570 : : }
1571 : : else
1572 : : {
1573 : 48 : gfc_conv_expr (&se, expr1);
1574 : 48 : ptr = gfc_build_addr_expr (NULL_TREE, se.expr);
1575 : : }
1576 : : }
1577 : :
1578 : 861 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1579 : 861 : ptr, build_zero_cst (TREE_TYPE (ptr)));
1580 : 861 : final_expr = build3_loc (input_location, COND_EXPR, void_type_node,
1581 : : cond, gfc_finish_block (&final_block),
1582 : : build_empty_stmt (input_location));
1583 : : }
1584 : : else
1585 : 148 : final_expr = gfc_finish_block (&final_block);
1586 : :
1587 : : /* Check optional present. */
1588 : 1009 : if (sym->attr.optional)
1589 : : {
1590 : 0 : cond = gfc_conv_expr_present (sym);
1591 : 0 : final_expr = build3_loc (input_location, COND_EXPR, void_type_node,
1592 : : cond, final_expr,
1593 : : build_empty_stmt (input_location));
1594 : : }
1595 : :
1596 : 1009 : gfc_add_expr_to_block (&lse->finalblock, final_expr);
1597 : :
1598 : 1009 : return true;
1599 : : }
1600 : :
1601 : :
1602 : : /* Finalize a TREE expression using the finalizer wrapper. The result is
1603 : : fixed in order to prevent repeated calls. */
1604 : :
1605 : : void
1606 : 593 : gfc_finalize_tree_expr (gfc_se *se, gfc_symbol *derived,
1607 : : symbol_attribute attr, int rank)
1608 : : {
1609 : 593 : tree vptr, final_fndecl, desc, tmp, size, is_final;
1610 : 593 : tree data_ptr, data_null, cond;
1611 : 593 : gfc_symbol *vtab;
1612 : 593 : gfc_se post_se;
1613 : 593 : bool is_class = GFC_CLASS_TYPE_P (TREE_TYPE (se->expr));
1614 : :
1615 : 593 : if (attr.pointer)
1616 : 52 : return;
1617 : :
1618 : : /* Derived type function results with components that have defined
1619 : : assignements are handled in resolve.cc(generate_component_assignments) */
1620 : 590 : if (derived && (derived->attr.is_c_interop
1621 : : || derived->attr.is_iso_c
1622 : 205 : || derived->attr.is_bind_c
1623 : 205 : || derived->attr.defined_assign_comp))
1624 : : return;
1625 : :
1626 : 584 : if (is_class)
1627 : : {
1628 : 366 : if (!VAR_P (se->expr))
1629 : : {
1630 : 0 : desc = gfc_evaluate_now (se->expr, &se->pre);
1631 : 0 : se->expr = desc;
1632 : : }
1633 : 366 : desc = gfc_class_data_get (se->expr);
1634 : 366 : vptr = gfc_class_vptr_get (se->expr);
1635 : : }
1636 : 218 : else if (derived && gfc_is_finalizable (derived, NULL))
1637 : : {
1638 : 179 : if (!derived->components && (!rank || attr.elemental))
1639 : : {
1640 : : /* Any attempt to assign zero length entities, causes the gimplifier
1641 : : all manner of problems. Instead, a variable is created to act as
1642 : : as the argument for the final call. */
1643 : 4 : desc = gfc_create_var (TREE_TYPE (se->expr), "zero");
1644 : : }
1645 : 175 : else if (se->direct_byref)
1646 : : {
1647 : 0 : desc = gfc_evaluate_now (se->expr, &se->finalblock);
1648 : 0 : if (derived->attr.alloc_comp)
1649 : : {
1650 : : /* Need to copy allocated components and not finalize. */
1651 : 0 : tmp = gfc_copy_alloc_comp_no_fini (derived, se->expr, desc, rank, 0);
1652 : 0 : gfc_add_expr_to_block (&se->finalblock, tmp);
1653 : : }
1654 : : }
1655 : : else
1656 : : {
1657 : 175 : desc = gfc_evaluate_now (se->expr, &se->pre);
1658 : 175 : se->expr = gfc_evaluate_now (desc, &se->pre);
1659 : 175 : if (derived->attr.alloc_comp)
1660 : : {
1661 : : /* Need to copy allocated components and not finalize. */
1662 : 37 : tmp = gfc_copy_alloc_comp_no_fini (derived, se->expr, desc, rank, 0);
1663 : 37 : gfc_add_expr_to_block (&se->pre, tmp);
1664 : : }
1665 : : }
1666 : :
1667 : 179 : vtab = gfc_find_derived_vtab (derived);
1668 : 179 : if (vtab->backend_decl == NULL_TREE)
1669 : 0 : vptr = gfc_get_symbol_decl (vtab);
1670 : : else
1671 : : vptr = vtab->backend_decl;
1672 : 179 : vptr = gfc_build_addr_expr (NULL, vptr);
1673 : : }
1674 : : else
1675 : 39 : return;
1676 : :
1677 : 545 : size = gfc_vptr_size_get (vptr);
1678 : 545 : final_fndecl = gfc_vptr_final_get (vptr);
1679 : 545 : is_final = fold_build2_loc (input_location, NE_EXPR,
1680 : : logical_type_node,
1681 : : final_fndecl,
1682 : 545 : fold_convert (TREE_TYPE (final_fndecl),
1683 : : null_pointer_node));
1684 : :
1685 : 545 : final_fndecl = build_fold_indirect_ref_loc (input_location,
1686 : : final_fndecl);
1687 : 545 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
1688 : : {
1689 : 305 : if (is_class || attr.elemental)
1690 : 190 : desc = gfc_conv_scalar_to_descriptor (se, desc, attr);
1691 : : else
1692 : : {
1693 : 115 : gfc_init_se (&post_se, NULL);
1694 : 115 : desc = gfc_conv_scalar_to_descriptor (&post_se, desc, attr);
1695 : 115 : gfc_add_expr_to_block (&se->pre, gfc_finish_block (&post_se.pre));
1696 : : }
1697 : : }
1698 : :
1699 : 545 : if (derived && !derived->components)
1700 : : {
1701 : : /* All the conditions below break down for zero length derived types. */
1702 : 4 : tmp = build_call_expr_loc (input_location, final_fndecl, 3,
1703 : : gfc_build_addr_expr (NULL, desc),
1704 : : size, boolean_false_node);
1705 : 4 : gfc_add_expr_to_block (&se->finalblock, tmp);
1706 : 4 : return;
1707 : : }
1708 : :
1709 : 541 : if (!VAR_P (desc))
1710 : : {
1711 : 216 : tmp = gfc_create_var (TREE_TYPE (desc), "res");
1712 : 216 : if (se->direct_byref)
1713 : 0 : gfc_add_modify (&se->finalblock, tmp, desc);
1714 : : else
1715 : 216 : gfc_add_modify (&se->pre, tmp, desc);
1716 : : desc = tmp;
1717 : : }
1718 : :
1719 : 541 : data_ptr = gfc_conv_descriptor_data_get (desc);
1720 : 541 : data_null = fold_convert (TREE_TYPE (data_ptr), null_pointer_node);
1721 : 541 : cond = fold_build2_loc (input_location, NE_EXPR,
1722 : : logical_type_node, data_ptr, data_null);
1723 : 541 : is_final = fold_build2_loc (input_location, TRUTH_AND_EXPR,
1724 : : logical_type_node, is_final, cond);
1725 : 541 : tmp = build_call_expr_loc (input_location, final_fndecl, 3,
1726 : : gfc_build_addr_expr (NULL, desc),
1727 : : size, boolean_false_node);
1728 : 541 : tmp = fold_build3_loc (input_location, COND_EXPR,
1729 : : void_type_node, is_final, tmp,
1730 : : build_empty_stmt (input_location));
1731 : :
1732 : 541 : if (is_class && se->ss && se->ss->loop)
1733 : : {
1734 : 134 : gfc_add_expr_to_block (&se->loop->post, tmp);
1735 : 134 : tmp = fold_build3_loc (input_location, COND_EXPR,
1736 : : void_type_node, cond,
1737 : : gfc_call_free (data_ptr),
1738 : : build_empty_stmt (input_location));
1739 : 134 : gfc_add_expr_to_block (&se->loop->post, tmp);
1740 : 134 : gfc_add_modify (&se->loop->post, data_ptr, data_null);
1741 : : }
1742 : : else
1743 : : {
1744 : 407 : gfc_add_expr_to_block (&se->finalblock, tmp);
1745 : :
1746 : : /* Let the scalarizer take care of freeing of temporary arrays. */
1747 : 407 : if (attr.allocatable && !(se->loop && se->loop->temp_dim))
1748 : : {
1749 : 232 : tmp = fold_build3_loc (input_location, COND_EXPR,
1750 : : void_type_node, cond,
1751 : : gfc_call_free (data_ptr),
1752 : : build_empty_stmt (input_location));
1753 : 232 : gfc_add_expr_to_block (&se->finalblock, tmp);
1754 : 232 : gfc_add_modify (&se->finalblock, data_ptr, data_null);
1755 : : }
1756 : : }
1757 : : }
1758 : :
1759 : :
1760 : : /* User-deallocate; we emit the code directly from the front-end, and the
1761 : : logic is the same as the previous library function:
1762 : :
1763 : : void
1764 : : deallocate (void *pointer, GFC_INTEGER_4 * stat)
1765 : : {
1766 : : if (!pointer)
1767 : : {
1768 : : if (stat)
1769 : : *stat = 1;
1770 : : else
1771 : : runtime_error ("Attempt to DEALLOCATE unallocated memory.");
1772 : : }
1773 : : else
1774 : : {
1775 : : free (pointer);
1776 : : if (stat)
1777 : : *stat = 0;
1778 : : }
1779 : : }
1780 : :
1781 : : In this front-end version, status doesn't have to be GFC_INTEGER_4.
1782 : : Moreover, if CAN_FAIL is true, then we will not emit a runtime error,
1783 : : even when no status variable is passed to us (this is used for
1784 : : unconditional deallocation generated by the front-end at end of
1785 : : each procedure).
1786 : :
1787 : : If a runtime-message is possible, `expr' must point to the original
1788 : : expression being deallocated for its locus and variable name.
1789 : :
1790 : : For coarrays, "pointer" must be the array descriptor and not its
1791 : : "data" component.
1792 : :
1793 : : COARRAY_DEALLOC_MODE gives the mode unregister coarrays. Available modes are
1794 : : the ones of GFC_CAF_DEREGTYPE, -1 when the mode for deregistration is to be
1795 : : analyzed and set by this routine, and -2 to indicate that a non-coarray is to
1796 : : be deallocated. */
1797 : : tree
1798 : 18946 : gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
1799 : : tree errlen, tree label_finish,
1800 : : bool can_fail, gfc_expr* expr,
1801 : : int coarray_dealloc_mode, tree class_container,
1802 : : tree add_when_allocated, tree caf_token)
1803 : : {
1804 : 18946 : stmtblock_t null, non_null;
1805 : 18946 : tree cond, tmp, error;
1806 : 18946 : tree status_type = NULL_TREE;
1807 : 18946 : tree token = NULL_TREE;
1808 : 18946 : tree descr = NULL_TREE;
1809 : 18946 : gfc_coarray_deregtype caf_dereg_type = GFC_CAF_COARRAY_DEREGISTER;
1810 : :
1811 : 18946 : if (coarray_dealloc_mode >= GFC_CAF_COARRAY_ANALYZE)
1812 : : {
1813 : 365 : if (flag_coarray == GFC_FCOARRAY_LIB)
1814 : : {
1815 : 205 : if (caf_token)
1816 : : {
1817 : 50 : token = caf_token;
1818 : 50 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer)))
1819 : 34 : pointer = gfc_conv_descriptor_data_get (pointer);
1820 : : }
1821 : : else
1822 : : {
1823 : 155 : tree caf_type, caf_decl = pointer;
1824 : 155 : pointer = gfc_conv_descriptor_data_get (caf_decl);
1825 : 155 : caf_type = TREE_TYPE (caf_decl);
1826 : 155 : STRIP_NOPS (pointer);
1827 : 155 : if (GFC_DESCRIPTOR_TYPE_P (caf_type))
1828 : 155 : token = gfc_conv_descriptor_token (caf_decl);
1829 : 0 : else if (DECL_LANG_SPECIFIC (caf_decl)
1830 : 0 : && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
1831 : 0 : token = GFC_DECL_TOKEN (caf_decl);
1832 : : else
1833 : : {
1834 : 0 : gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
1835 : : && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type)
1836 : : != NULL_TREE);
1837 : 0 : token = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
1838 : : }
1839 : : }
1840 : :
1841 : 205 : if (coarray_dealloc_mode == GFC_CAF_COARRAY_ANALYZE)
1842 : : {
1843 : 4 : bool comp_ref;
1844 : 4 : if (expr && !gfc_caf_attr (expr, false, &comp_ref).coarray_comp
1845 : 4 : && comp_ref)
1846 : 0 : caf_dereg_type = GFC_CAF_COARRAY_DEALLOCATE_ONLY;
1847 : : // else do a deregister as set by default.
1848 : : }
1849 : : else
1850 : : caf_dereg_type = (enum gfc_coarray_deregtype) coarray_dealloc_mode;
1851 : : }
1852 : 160 : else if (flag_coarray == GFC_FCOARRAY_SINGLE
1853 : 160 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer)))
1854 : 159 : pointer = gfc_conv_descriptor_data_get (pointer);
1855 : : }
1856 : 18581 : else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer)))
1857 : : {
1858 : 14799 : descr = pointer;
1859 : 14799 : pointer = gfc_conv_descriptor_data_get (pointer);
1860 : : }
1861 : :
1862 : 18946 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, pointer,
1863 : 18946 : build_int_cst (TREE_TYPE (pointer), 0));
1864 : :
1865 : : /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
1866 : : we emit a runtime error. */
1867 : 18946 : gfc_start_block (&null);
1868 : 18946 : if (!can_fail)
1869 : : {
1870 : 6715 : tree varname;
1871 : :
1872 : 6715 : gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree);
1873 : :
1874 : 6715 : varname = gfc_build_cstring_const (expr->symtree->name);
1875 : 6715 : varname = gfc_build_addr_expr (pchar_type_node, varname);
1876 : :
1877 : 6715 : error = gfc_trans_runtime_error (true, &expr->where,
1878 : : "Attempt to DEALLOCATE unallocated '%s'",
1879 : : varname);
1880 : : }
1881 : : else
1882 : 12231 : error = build_empty_stmt (input_location);
1883 : :
1884 : 18946 : if (status != NULL_TREE && !integer_zerop (status))
1885 : : {
1886 : 1436 : tree cond2;
1887 : :
1888 : 1436 : status_type = TREE_TYPE (TREE_TYPE (status));
1889 : 1436 : cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1890 : 1436 : status, build_int_cst (TREE_TYPE (status), 0));
1891 : 1436 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
1892 : : fold_build1_loc (input_location, INDIRECT_REF,
1893 : : status_type, status),
1894 : 1436 : build_int_cst (status_type, 1));
1895 : 1436 : error = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1896 : : cond2, tmp, error);
1897 : : }
1898 : :
1899 : 18946 : gfc_add_expr_to_block (&null, error);
1900 : :
1901 : : /* When POINTER is not NULL, we free it. */
1902 : 18946 : gfc_start_block (&non_null);
1903 : 18946 : if (add_when_allocated)
1904 : 5164 : gfc_add_expr_to_block (&non_null, add_when_allocated);
1905 : 18946 : gfc_add_finalizer_call (&non_null, expr, class_container);
1906 : 18946 : if (coarray_dealloc_mode == GFC_CAF_COARRAY_NOCOARRAY
1907 : 365 : || flag_coarray != GFC_FCOARRAY_LIB)
1908 : : {
1909 : 18741 : tmp = build_call_expr_loc (input_location,
1910 : : builtin_decl_explicit (BUILT_IN_FREE), 1,
1911 : : fold_convert (pvoid_type_node, pointer));
1912 : 18741 : if (flag_openmp_allocators && coarray_dealloc_mode < GFC_CAF_COARRAY_ANALYZE)
1913 : : {
1914 : 58 : tree cond, omp_tmp;
1915 : 58 : if (descr)
1916 : 43 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
1917 : : gfc_conv_descriptor_version (descr),
1918 : : integer_one_node);
1919 : : else
1920 : 15 : cond = gfc_omp_call_is_alloc (pointer);
1921 : 58 : omp_tmp = builtin_decl_explicit (BUILT_IN_GOMP_FREE);
1922 : 58 : omp_tmp = build_call_expr_loc (input_location, omp_tmp, 2, pointer,
1923 : : build_zero_cst (ptr_type_node));
1924 : 58 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond,
1925 : : omp_tmp, tmp);
1926 : : }
1927 : 18741 : gfc_add_expr_to_block (&non_null, tmp);
1928 : 18741 : gfc_add_modify (&non_null, pointer, build_int_cst (TREE_TYPE (pointer),
1929 : 18741 : 0));
1930 : 18741 : if (flag_openmp_allocators && descr)
1931 : 43 : gfc_add_modify (&non_null, gfc_conv_descriptor_version (descr),
1932 : : integer_zero_node);
1933 : :
1934 : 18741 : if (status != NULL_TREE && !integer_zerop (status))
1935 : : {
1936 : : /* We set STATUS to zero if it is present. */
1937 : 1425 : tree status_type = TREE_TYPE (TREE_TYPE (status));
1938 : 1425 : tree cond2;
1939 : :
1940 : 1425 : cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1941 : : status,
1942 : 1425 : build_int_cst (TREE_TYPE (status), 0));
1943 : 1425 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
1944 : : fold_build1_loc (input_location, INDIRECT_REF,
1945 : : status_type, status),
1946 : 1425 : build_int_cst (status_type, 0));
1947 : 1425 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1948 : : gfc_unlikely (cond2, PRED_FORTRAN_FAIL_ALLOC),
1949 : : tmp, build_empty_stmt (input_location));
1950 : 1425 : gfc_add_expr_to_block (&non_null, tmp);
1951 : : }
1952 : : }
1953 : : else
1954 : : {
1955 : 205 : tree cond2, pstat = null_pointer_node;
1956 : :
1957 : 205 : if (errmsg == NULL_TREE)
1958 : : {
1959 : 199 : gcc_assert (errlen == NULL_TREE);
1960 : 199 : errmsg = null_pointer_node;
1961 : 199 : errlen = integer_zero_node;
1962 : : }
1963 : : else
1964 : : {
1965 : 6 : gcc_assert (errlen != NULL_TREE);
1966 : 6 : if (!POINTER_TYPE_P (TREE_TYPE (errmsg)))
1967 : 0 : errmsg = gfc_build_addr_expr (NULL_TREE, errmsg);
1968 : : }
1969 : :
1970 : 205 : if (status != NULL_TREE && !integer_zerop (status))
1971 : : {
1972 : 11 : gcc_assert (status_type == integer_type_node);
1973 : : pstat = status;
1974 : : }
1975 : :
1976 : 205 : token = gfc_build_addr_expr (NULL_TREE, token);
1977 : 205 : gcc_assert (caf_dereg_type > GFC_CAF_COARRAY_ANALYZE);
1978 : 205 : tmp = build_call_expr_loc (input_location,
1979 : : gfor_fndecl_caf_deregister, 5,
1980 : 205 : token, build_int_cst (integer_type_node,
1981 : : caf_dereg_type),
1982 : : pstat, errmsg, errlen);
1983 : 205 : gfc_add_expr_to_block (&non_null, tmp);
1984 : :
1985 : : /* It guarantees memory consistency within the same segment */
1986 : 205 : tmp = gfc_build_string_const (strlen ("memory")+1, "memory"),
1987 : 205 : tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
1988 : : gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
1989 : : tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
1990 : 205 : ASM_VOLATILE_P (tmp) = 1;
1991 : 205 : gfc_add_expr_to_block (&non_null, tmp);
1992 : :
1993 : 205 : if (status != NULL_TREE)
1994 : : {
1995 : 11 : tree stat = build_fold_indirect_ref_loc (input_location, status);
1996 : 11 : tree nullify = fold_build2_loc (input_location, MODIFY_EXPR,
1997 : : void_type_node, pointer,
1998 : 11 : build_int_cst (TREE_TYPE (pointer),
1999 : 11 : 0));
2000 : :
2001 : 11 : TREE_USED (label_finish) = 1;
2002 : 11 : tmp = build1_v (GOTO_EXPR, label_finish);
2003 : 11 : cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
2004 : 11 : stat, build_zero_cst (TREE_TYPE (stat)));
2005 : 11 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
2006 : : gfc_unlikely (cond2, PRED_FORTRAN_REALLOC),
2007 : : tmp, nullify);
2008 : 11 : gfc_add_expr_to_block (&non_null, tmp);
2009 : : }
2010 : : else
2011 : 194 : gfc_add_modify (&non_null, pointer, build_int_cst (TREE_TYPE (pointer),
2012 : 194 : 0));
2013 : : }
2014 : :
2015 : 18946 : return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
2016 : : gfc_finish_block (&null),
2017 : 18946 : gfc_finish_block (&non_null));
2018 : : }
2019 : :
2020 : :
2021 : : /* Generate code for deallocation of allocatable scalars (variables or
2022 : : components). Before the object itself is freed, any allocatable
2023 : : subcomponents are being deallocated. */
2024 : :
2025 : : tree
2026 : 4908 : gfc_deallocate_scalar_with_status (tree pointer, tree status, tree label_finish,
2027 : : bool can_fail, gfc_expr* expr,
2028 : : gfc_typespec ts, tree class_container,
2029 : : bool coarray)
2030 : : {
2031 : 4908 : stmtblock_t null, non_null;
2032 : 4908 : tree cond, tmp, error;
2033 : 4908 : bool finalizable, comp_ref;
2034 : 4908 : gfc_coarray_deregtype caf_dereg_type = GFC_CAF_COARRAY_DEREGISTER;
2035 : :
2036 : 4908 : if (coarray && expr && !gfc_caf_attr (expr, false, &comp_ref).coarray_comp
2037 : 4948 : && comp_ref)
2038 : 40 : caf_dereg_type = GFC_CAF_COARRAY_DEALLOCATE_ONLY;
2039 : :
2040 : 4908 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, pointer,
2041 : 4908 : build_int_cst (TREE_TYPE (pointer), 0));
2042 : :
2043 : : /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
2044 : : we emit a runtime error. */
2045 : 4908 : gfc_start_block (&null);
2046 : 4908 : if (!can_fail)
2047 : : {
2048 : 3185 : tree varname;
2049 : :
2050 : 3185 : gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree);
2051 : :
2052 : 3185 : varname = gfc_build_cstring_const (expr->symtree->name);
2053 : 3185 : varname = gfc_build_addr_expr (pchar_type_node, varname);
2054 : :
2055 : 3185 : error = gfc_trans_runtime_error (true, &expr->where,
2056 : : "Attempt to DEALLOCATE unallocated '%s'",
2057 : : varname);
2058 : : }
2059 : : else
2060 : 1723 : error = build_empty_stmt (input_location);
2061 : :
2062 : 4908 : if (status != NULL_TREE && !integer_zerop (status))
2063 : : {
2064 : 691 : tree status_type = TREE_TYPE (TREE_TYPE (status));
2065 : 691 : tree cond2;
2066 : :
2067 : 691 : cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
2068 : 691 : status, build_int_cst (TREE_TYPE (status), 0));
2069 : 691 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
2070 : : fold_build1_loc (input_location, INDIRECT_REF,
2071 : : status_type, status),
2072 : 691 : build_int_cst (status_type, 1));
2073 : 691 : error = fold_build3_loc (input_location, COND_EXPR, void_type_node,
2074 : : cond2, tmp, error);
2075 : : }
2076 : 4908 : gfc_add_expr_to_block (&null, error);
2077 : :
2078 : : /* When POINTER is not NULL, we free it. */
2079 : 4908 : gfc_start_block (&non_null);
2080 : :
2081 : : /* Free allocatable components. */
2082 : 4908 : finalizable = gfc_add_finalizer_call (&non_null, expr, class_container);
2083 : 4908 : if (!finalizable && ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
2084 : : {
2085 : 927 : int caf_mode = coarray
2086 : 462 : ? ((caf_dereg_type == GFC_CAF_COARRAY_DEALLOCATE_ONLY
2087 : : ? GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY : 0)
2088 : : | GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
2089 : 3 : | GFC_STRUCTURE_CAF_MODE_IN_COARRAY)
2090 : : : 0;
2091 : 3 : if (coarray && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer)))
2092 : 0 : tmp = gfc_conv_descriptor_data_get (pointer);
2093 : : else
2094 : 462 : tmp = build_fold_indirect_ref_loc (input_location, pointer);
2095 : 462 : tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0, caf_mode);
2096 : 462 : gfc_add_expr_to_block (&non_null, tmp);
2097 : : }
2098 : :
2099 : 4908 : if (!coarray || flag_coarray == GFC_FCOARRAY_SINGLE)
2100 : : {
2101 : 4871 : tmp = build_call_expr_loc (input_location,
2102 : : builtin_decl_explicit (BUILT_IN_FREE), 1,
2103 : : fold_convert (pvoid_type_node, pointer));
2104 : 4871 : if (flag_openmp_allocators)
2105 : : {
2106 : 31 : tree cond, omp_tmp;
2107 : 31 : cond = gfc_omp_call_is_alloc (pointer);
2108 : 31 : omp_tmp = builtin_decl_explicit (BUILT_IN_GOMP_FREE);
2109 : 31 : omp_tmp = build_call_expr_loc (input_location, omp_tmp, 2, pointer,
2110 : : build_zero_cst (ptr_type_node));
2111 : 31 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond,
2112 : : omp_tmp, tmp);
2113 : : }
2114 : 4871 : gfc_add_expr_to_block (&non_null, tmp);
2115 : :
2116 : 4871 : if (status != NULL_TREE && !integer_zerop (status))
2117 : : {
2118 : : /* We set STATUS to zero if it is present. */
2119 : 691 : tree status_type = TREE_TYPE (TREE_TYPE (status));
2120 : 691 : tree cond2;
2121 : :
2122 : 691 : cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
2123 : : status,
2124 : 691 : build_int_cst (TREE_TYPE (status), 0));
2125 : 691 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
2126 : : fold_build1_loc (input_location, INDIRECT_REF,
2127 : : status_type, status),
2128 : 691 : build_int_cst (status_type, 0));
2129 : 691 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
2130 : : cond2, tmp, build_empty_stmt (input_location));
2131 : 691 : gfc_add_expr_to_block (&non_null, tmp);
2132 : : }
2133 : : }
2134 : : else
2135 : : {
2136 : 37 : tree token;
2137 : 37 : tree pstat = null_pointer_node;
2138 : 37 : gfc_se se;
2139 : :
2140 : 37 : gfc_init_se (&se, NULL);
2141 : 37 : token = gfc_get_ultimate_alloc_ptr_comps_caf_token (&se, expr);
2142 : 37 : gcc_assert (token != NULL_TREE);
2143 : :
2144 : 37 : if (status != NULL_TREE && !integer_zerop (status))
2145 : : {
2146 : 0 : gcc_assert (TREE_TYPE (TREE_TYPE (status)) == integer_type_node);
2147 : : pstat = status;
2148 : : }
2149 : :
2150 : 37 : tmp = build_call_expr_loc (input_location,
2151 : : gfor_fndecl_caf_deregister, 5,
2152 : 37 : token, build_int_cst (integer_type_node,
2153 : : caf_dereg_type),
2154 : : pstat, null_pointer_node, integer_zero_node);
2155 : 37 : gfc_add_expr_to_block (&non_null, tmp);
2156 : :
2157 : : /* It guarantees memory consistency within the same segment. */
2158 : 37 : tmp = gfc_build_string_const (strlen ("memory")+1, "memory");
2159 : 37 : tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
2160 : : gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
2161 : : tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
2162 : 37 : ASM_VOLATILE_P (tmp) = 1;
2163 : 37 : gfc_add_expr_to_block (&non_null, tmp);
2164 : :
2165 : 37 : if (status != NULL_TREE)
2166 : : {
2167 : 0 : tree stat = build_fold_indirect_ref_loc (input_location, status);
2168 : 0 : tree cond2;
2169 : :
2170 : 0 : TREE_USED (label_finish) = 1;
2171 : 0 : tmp = build1_v (GOTO_EXPR, label_finish);
2172 : 0 : cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
2173 : 0 : stat, build_zero_cst (TREE_TYPE (stat)));
2174 : 0 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
2175 : : gfc_unlikely (cond2, PRED_FORTRAN_REALLOC),
2176 : : tmp, build_empty_stmt (input_location));
2177 : 0 : gfc_add_expr_to_block (&non_null, tmp);
2178 : : }
2179 : : }
2180 : :
2181 : 4908 : return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
2182 : : gfc_finish_block (&null),
2183 : 4908 : gfc_finish_block (&non_null));
2184 : : }
2185 : :
2186 : : /* Reallocate MEM so it has SIZE bytes of data. This behaves like the
2187 : : following pseudo-code:
2188 : :
2189 : : void *
2190 : : internal_realloc (void *mem, size_t size)
2191 : : {
2192 : : res = realloc (mem, size);
2193 : : if (!res && size != 0)
2194 : : _gfortran_os_error ("Allocation would exceed memory limit");
2195 : :
2196 : : return res;
2197 : : } */
2198 : : tree
2199 : 1164 : gfc_call_realloc (stmtblock_t * block, tree mem, tree size)
2200 : : {
2201 : 1164 : tree res, nonzero, null_result, tmp;
2202 : 1164 : tree type = TREE_TYPE (mem);
2203 : :
2204 : : /* Only evaluate the size once. */
2205 : 1164 : size = save_expr (fold_convert (size_type_node, size));
2206 : :
2207 : : /* Create a variable to hold the result. */
2208 : 1164 : res = gfc_create_var (type, NULL);
2209 : :
2210 : : /* Call realloc and check the result. */
2211 : 1164 : tmp = build_call_expr_loc (input_location,
2212 : : builtin_decl_explicit (BUILT_IN_REALLOC), 2,
2213 : : fold_convert (pvoid_type_node, mem), size);
2214 : 1164 : gfc_add_modify (block, res, fold_convert (type, tmp));
2215 : 1164 : null_result = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
2216 : 1164 : res, build_int_cst (pvoid_type_node, 0));
2217 : 1164 : nonzero = fold_build2_loc (input_location, NE_EXPR, logical_type_node, size,
2218 : 1164 : build_int_cst (size_type_node, 0));
2219 : 1164 : null_result = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
2220 : : null_result, nonzero);
2221 : 1164 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
2222 : : null_result,
2223 : : trans_os_error_at (NULL,
2224 : : "Error reallocating to %lu bytes",
2225 : : fold_convert
2226 : : (long_unsigned_type_node, size)),
2227 : : build_empty_stmt (input_location));
2228 : 1164 : gfc_add_expr_to_block (block, tmp);
2229 : :
2230 : 1164 : return res;
2231 : : }
2232 : :
2233 : :
2234 : : /* Add an expression to another one, either at the front or the back. */
2235 : :
2236 : : static void
2237 : 17744007 : add_expr_to_chain (tree* chain, tree expr, bool front)
2238 : : {
2239 : 17744007 : if (expr == NULL_TREE || IS_EMPTY_STMT (expr))
2240 : 8454130 : return;
2241 : :
2242 : 9289877 : if (*chain)
2243 : : {
2244 : 4977432 : if (TREE_CODE (*chain) != STATEMENT_LIST)
2245 : : {
2246 : 1407049 : tree tmp;
2247 : :
2248 : 1407049 : tmp = *chain;
2249 : 1407049 : *chain = NULL_TREE;
2250 : 1407049 : append_to_statement_list (tmp, chain);
2251 : : }
2252 : :
2253 : 4977432 : if (front)
2254 : : {
2255 : 23826 : tree_stmt_iterator i;
2256 : :
2257 : 23826 : i = tsi_start (*chain);
2258 : 23826 : tsi_link_before (&i, expr, TSI_CONTINUE_LINKING);
2259 : : }
2260 : : else
2261 : 4953606 : append_to_statement_list (expr, chain);
2262 : : }
2263 : : else
2264 : 4312445 : *chain = expr;
2265 : : }
2266 : :
2267 : :
2268 : : /* Add a statement at the end of a block. */
2269 : :
2270 : : void
2271 : 16951819 : gfc_add_expr_to_block (stmtblock_t * block, tree expr)
2272 : : {
2273 : 16951819 : gcc_assert (block);
2274 : 16951819 : add_expr_to_chain (&block->head, expr, false);
2275 : 16951819 : }
2276 : :
2277 : :
2278 : : /* Add a statement at the beginning of a block. */
2279 : :
2280 : : void
2281 : 3196 : gfc_prepend_expr_to_block (stmtblock_t * block, tree expr)
2282 : : {
2283 : 3196 : gcc_assert (block);
2284 : 3196 : add_expr_to_chain (&block->head, expr, true);
2285 : 3196 : }
2286 : :
2287 : :
2288 : : /* Add a block the end of a block. */
2289 : :
2290 : : void
2291 : 8643147 : gfc_add_block_to_block (stmtblock_t * block, stmtblock_t * append)
2292 : : {
2293 : 8643147 : gcc_assert (append);
2294 : 8643147 : gcc_assert (!append->has_scope);
2295 : :
2296 : 8643147 : gfc_add_expr_to_block (block, append->head);
2297 : 8643147 : append->head = NULL_TREE;
2298 : 8643147 : }
2299 : :
2300 : :
2301 : : /* Translate an executable statement. The tree cond is used by gfc_trans_do.
2302 : : This static function is wrapped by gfc_trans_code_cond and
2303 : : gfc_trans_code. */
2304 : :
2305 : : static tree
2306 : 414420 : trans_code (gfc_code * code, tree cond)
2307 : : {
2308 : 414420 : stmtblock_t block;
2309 : 414420 : tree res;
2310 : :
2311 : 414420 : if (!code)
2312 : 1964 : return build_empty_stmt (input_location);
2313 : :
2314 : 412456 : gfc_start_block (&block);
2315 : :
2316 : : /* Translate statements one by one into GENERIC trees until we reach
2317 : : the end of this gfc_code branch. */
2318 : 1519477 : for (; code; code = code->next)
2319 : : {
2320 : 1107021 : if (code->here != 0)
2321 : : {
2322 : 3502 : res = gfc_trans_label_here (code);
2323 : 3502 : gfc_add_expr_to_block (&block, res);
2324 : : }
2325 : :
2326 : 1107021 : input_location = gfc_get_location (&code->loc);
2327 : :
2328 : 1107021 : switch (code->op)
2329 : : {
2330 : : case EXEC_NOP:
2331 : : case EXEC_END_BLOCK:
2332 : : case EXEC_END_NESTED_BLOCK:
2333 : : case EXEC_END_PROCEDURE:
2334 : : res = NULL_TREE;
2335 : : break;
2336 : :
2337 : 291335 : case EXEC_ASSIGN:
2338 : 291335 : res = gfc_trans_assign (code);
2339 : 291335 : break;
2340 : :
2341 : 116 : case EXEC_LABEL_ASSIGN:
2342 : 116 : res = gfc_trans_label_assign (code);
2343 : 116 : break;
2344 : :
2345 : 9754 : case EXEC_POINTER_ASSIGN:
2346 : 9754 : res = gfc_trans_pointer_assign (code);
2347 : 9754 : break;
2348 : :
2349 : 9942 : case EXEC_INIT_ASSIGN:
2350 : 9942 : if (code->expr1->ts.type == BT_CLASS)
2351 : 380 : res = gfc_trans_class_init_assign (code);
2352 : : else
2353 : 9562 : res = gfc_trans_init_assign (code);
2354 : : break;
2355 : :
2356 : : case EXEC_CONTINUE:
2357 : : res = NULL_TREE;
2358 : : break;
2359 : :
2360 : 21 : case EXEC_CRITICAL:
2361 : 21 : res = gfc_trans_critical (code);
2362 : 21 : break;
2363 : :
2364 : 106 : case EXEC_CYCLE:
2365 : 106 : res = gfc_trans_cycle (code);
2366 : 106 : break;
2367 : :
2368 : 679 : case EXEC_EXIT:
2369 : 679 : res = gfc_trans_exit (code);
2370 : 679 : break;
2371 : :
2372 : 1187 : case EXEC_GOTO:
2373 : 1187 : res = gfc_trans_goto (code);
2374 : 1187 : break;
2375 : :
2376 : 1341 : case EXEC_ENTRY:
2377 : 1341 : res = gfc_trans_entry (code);
2378 : 1341 : break;
2379 : :
2380 : 28 : case EXEC_PAUSE:
2381 : 28 : res = gfc_trans_pause (code);
2382 : 28 : break;
2383 : :
2384 : 206298 : case EXEC_STOP:
2385 : 206298 : case EXEC_ERROR_STOP:
2386 : 206298 : res = gfc_trans_stop (code, code->op == EXEC_ERROR_STOP);
2387 : 206298 : break;
2388 : :
2389 : 79463 : case EXEC_CALL:
2390 : : /* For MVBITS we've got the special exception that we need a
2391 : : dependency check, too. */
2392 : 79463 : {
2393 : 79463 : bool is_mvbits = false;
2394 : :
2395 : 79463 : if (code->resolved_isym)
2396 : : {
2397 : 5833 : res = gfc_conv_intrinsic_subroutine (code);
2398 : 5833 : if (res != NULL_TREE)
2399 : : break;
2400 : : }
2401 : :
2402 : 75470 : if (code->resolved_isym
2403 : 1840 : && code->resolved_isym->id == GFC_ISYM_MVBITS)
2404 : 75470 : is_mvbits = true;
2405 : :
2406 : 75470 : res = gfc_trans_call (code, is_mvbits, NULL_TREE,
2407 : : NULL_TREE, false);
2408 : : }
2409 : 75470 : break;
2410 : :
2411 : 114 : case EXEC_CALL_PPC:
2412 : 114 : res = gfc_trans_call (code, false, NULL_TREE,
2413 : : NULL_TREE, false);
2414 : 114 : break;
2415 : :
2416 : 691 : case EXEC_ASSIGN_CALL:
2417 : 691 : res = gfc_trans_call (code, true, NULL_TREE,
2418 : : NULL_TREE, false);
2419 : 691 : break;
2420 : :
2421 : 3035 : case EXEC_RETURN:
2422 : 3035 : res = gfc_trans_return (code);
2423 : 3035 : break;
2424 : :
2425 : 226032 : case EXEC_IF:
2426 : 226032 : res = gfc_trans_if (code);
2427 : 226032 : break;
2428 : :
2429 : 64 : case EXEC_ARITHMETIC_IF:
2430 : 64 : res = gfc_trans_arithmetic_if (code);
2431 : 64 : break;
2432 : :
2433 : 13227 : case EXEC_BLOCK:
2434 : 13227 : res = gfc_trans_block_construct (code);
2435 : 13227 : break;
2436 : :
2437 : 25945 : case EXEC_DO:
2438 : 25945 : res = gfc_trans_do (code, cond);
2439 : 25945 : break;
2440 : :
2441 : 116 : case EXEC_DO_CONCURRENT:
2442 : 116 : res = gfc_trans_do_concurrent (code);
2443 : 116 : break;
2444 : :
2445 : 495 : case EXEC_DO_WHILE:
2446 : 495 : res = gfc_trans_do_while (code);
2447 : 495 : break;
2448 : :
2449 : 1003 : case EXEC_SELECT:
2450 : 1003 : res = gfc_trans_select (code);
2451 : 1003 : break;
2452 : :
2453 : 2799 : case EXEC_SELECT_TYPE:
2454 : 2799 : res = gfc_trans_select_type (code);
2455 : 2799 : break;
2456 : :
2457 : 1001 : case EXEC_SELECT_RANK:
2458 : 1001 : res = gfc_trans_select_rank (code);
2459 : 1001 : break;
2460 : :
2461 : 73 : case EXEC_FLUSH:
2462 : 73 : res = gfc_trans_flush (code);
2463 : 73 : break;
2464 : :
2465 : 718 : case EXEC_SYNC_ALL:
2466 : 718 : case EXEC_SYNC_IMAGES:
2467 : 718 : case EXEC_SYNC_MEMORY:
2468 : 718 : res = gfc_trans_sync (code, code->op);
2469 : 718 : break;
2470 : :
2471 : 84 : case EXEC_LOCK:
2472 : 84 : case EXEC_UNLOCK:
2473 : 84 : res = gfc_trans_lock_unlock (code, code->op);
2474 : 84 : break;
2475 : :
2476 : 39 : case EXEC_EVENT_POST:
2477 : 39 : case EXEC_EVENT_WAIT:
2478 : 39 : res = gfc_trans_event_post_wait (code, code->op);
2479 : 39 : break;
2480 : :
2481 : 3 : case EXEC_FAIL_IMAGE:
2482 : 3 : res = gfc_trans_fail_image (code);
2483 : 3 : break;
2484 : :
2485 : 1863 : case EXEC_FORALL:
2486 : 1863 : res = gfc_trans_forall (code);
2487 : 1863 : break;
2488 : :
2489 : 25 : case EXEC_FORM_TEAM:
2490 : 25 : res = gfc_trans_form_team (code);
2491 : 25 : break;
2492 : :
2493 : 19 : case EXEC_CHANGE_TEAM:
2494 : 19 : res = gfc_trans_change_team (code);
2495 : 19 : break;
2496 : :
2497 : 19 : case EXEC_END_TEAM:
2498 : 19 : res = gfc_trans_end_team (code);
2499 : 19 : break;
2500 : :
2501 : 0 : case EXEC_SYNC_TEAM:
2502 : 0 : res = gfc_trans_sync_team (code);
2503 : 0 : break;
2504 : :
2505 : 322 : case EXEC_WHERE:
2506 : 322 : res = gfc_trans_where (code);
2507 : 322 : break;
2508 : :
2509 : 13520 : case EXEC_ALLOCATE:
2510 : 13520 : res = gfc_trans_allocate (code, NULL);
2511 : 13520 : break;
2512 : :
2513 : 7823 : case EXEC_DEALLOCATE:
2514 : 7823 : res = gfc_trans_deallocate (code);
2515 : 7823 : break;
2516 : :
2517 : 3530 : case EXEC_OPEN:
2518 : 3530 : res = gfc_trans_open (code);
2519 : 3530 : break;
2520 : :
2521 : 3005 : case EXEC_CLOSE:
2522 : 3005 : res = gfc_trans_close (code);
2523 : 3005 : break;
2524 : :
2525 : 5980 : case EXEC_READ:
2526 : 5980 : res = gfc_trans_read (code);
2527 : 5980 : break;
2528 : :
2529 : 23765 : case EXEC_WRITE:
2530 : 23765 : res = gfc_trans_write (code);
2531 : 23765 : break;
2532 : :
2533 : 84 : case EXEC_IOLENGTH:
2534 : 84 : res = gfc_trans_iolength (code);
2535 : 84 : break;
2536 : :
2537 : 389 : case EXEC_BACKSPACE:
2538 : 389 : res = gfc_trans_backspace (code);
2539 : 389 : break;
2540 : :
2541 : 56 : case EXEC_ENDFILE:
2542 : 56 : res = gfc_trans_endfile (code);
2543 : 56 : break;
2544 : :
2545 : 759 : case EXEC_INQUIRE:
2546 : 759 : res = gfc_trans_inquire (code);
2547 : 759 : break;
2548 : :
2549 : 74 : case EXEC_WAIT:
2550 : 74 : res = gfc_trans_wait (code);
2551 : 74 : break;
2552 : :
2553 : 2185 : case EXEC_REWIND:
2554 : 2185 : res = gfc_trans_rewind (code);
2555 : 2185 : break;
2556 : :
2557 : 43305 : case EXEC_TRANSFER:
2558 : 43305 : res = gfc_trans_transfer (code);
2559 : 43305 : break;
2560 : :
2561 : 29829 : case EXEC_DT_END:
2562 : 29829 : res = gfc_trans_dt_end (code);
2563 : 29829 : break;
2564 : :
2565 : 18506 : case EXEC_OMP_ALLOCATE:
2566 : 18506 : case EXEC_OMP_ALLOCATORS:
2567 : 18506 : case EXEC_OMP_ASSUME:
2568 : 18506 : case EXEC_OMP_ATOMIC:
2569 : 18506 : case EXEC_OMP_BARRIER:
2570 : 18506 : case EXEC_OMP_CANCEL:
2571 : 18506 : case EXEC_OMP_CANCELLATION_POINT:
2572 : 18506 : case EXEC_OMP_CRITICAL:
2573 : 18506 : case EXEC_OMP_DEPOBJ:
2574 : 18506 : case EXEC_OMP_DISPATCH:
2575 : 18506 : case EXEC_OMP_DISTRIBUTE:
2576 : 18506 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
2577 : 18506 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
2578 : 18506 : case EXEC_OMP_DISTRIBUTE_SIMD:
2579 : 18506 : case EXEC_OMP_DO:
2580 : 18506 : case EXEC_OMP_DO_SIMD:
2581 : 18506 : case EXEC_OMP_ERROR:
2582 : 18506 : case EXEC_OMP_FLUSH:
2583 : 18506 : case EXEC_OMP_INTEROP:
2584 : 18506 : case EXEC_OMP_LOOP:
2585 : 18506 : case EXEC_OMP_MASKED:
2586 : 18506 : case EXEC_OMP_MASKED_TASKLOOP:
2587 : 18506 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
2588 : 18506 : case EXEC_OMP_MASTER:
2589 : 18506 : case EXEC_OMP_MASTER_TASKLOOP:
2590 : 18506 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
2591 : 18506 : case EXEC_OMP_METADIRECTIVE:
2592 : 18506 : case EXEC_OMP_ORDERED:
2593 : 18506 : case EXEC_OMP_PARALLEL:
2594 : 18506 : case EXEC_OMP_PARALLEL_DO:
2595 : 18506 : case EXEC_OMP_PARALLEL_DO_SIMD:
2596 : 18506 : case EXEC_OMP_PARALLEL_LOOP:
2597 : 18506 : case EXEC_OMP_PARALLEL_MASKED:
2598 : 18506 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
2599 : 18506 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
2600 : 18506 : case EXEC_OMP_PARALLEL_MASTER:
2601 : 18506 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
2602 : 18506 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
2603 : 18506 : case EXEC_OMP_PARALLEL_SECTIONS:
2604 : 18506 : case EXEC_OMP_PARALLEL_WORKSHARE:
2605 : 18506 : case EXEC_OMP_SCOPE:
2606 : 18506 : case EXEC_OMP_SECTIONS:
2607 : 18506 : case EXEC_OMP_SIMD:
2608 : 18506 : case EXEC_OMP_SINGLE:
2609 : 18506 : case EXEC_OMP_TARGET:
2610 : 18506 : case EXEC_OMP_TARGET_DATA:
2611 : 18506 : case EXEC_OMP_TARGET_ENTER_DATA:
2612 : 18506 : case EXEC_OMP_TARGET_EXIT_DATA:
2613 : 18506 : case EXEC_OMP_TARGET_PARALLEL:
2614 : 18506 : case EXEC_OMP_TARGET_PARALLEL_DO:
2615 : 18506 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
2616 : 18506 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
2617 : 18506 : case EXEC_OMP_TARGET_SIMD:
2618 : 18506 : case EXEC_OMP_TARGET_TEAMS:
2619 : 18506 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
2620 : 18506 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
2621 : 18506 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
2622 : 18506 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
2623 : 18506 : case EXEC_OMP_TARGET_TEAMS_LOOP:
2624 : 18506 : case EXEC_OMP_TARGET_UPDATE:
2625 : 18506 : case EXEC_OMP_TASK:
2626 : 18506 : case EXEC_OMP_TASKGROUP:
2627 : 18506 : case EXEC_OMP_TASKLOOP:
2628 : 18506 : case EXEC_OMP_TASKLOOP_SIMD:
2629 : 18506 : case EXEC_OMP_TASKWAIT:
2630 : 18506 : case EXEC_OMP_TASKYIELD:
2631 : 18506 : case EXEC_OMP_TEAMS:
2632 : 18506 : case EXEC_OMP_TEAMS_DISTRIBUTE:
2633 : 18506 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
2634 : 18506 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
2635 : 18506 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
2636 : 18506 : case EXEC_OMP_TEAMS_LOOP:
2637 : 18506 : case EXEC_OMP_TILE:
2638 : 18506 : case EXEC_OMP_UNROLL:
2639 : 18506 : case EXEC_OMP_WORKSHARE:
2640 : 18506 : res = gfc_trans_omp_directive (code);
2641 : 18506 : break;
2642 : :
2643 : 11949 : case EXEC_OACC_CACHE:
2644 : 11949 : case EXEC_OACC_WAIT:
2645 : 11949 : case EXEC_OACC_UPDATE:
2646 : 11949 : case EXEC_OACC_LOOP:
2647 : 11949 : case EXEC_OACC_HOST_DATA:
2648 : 11949 : case EXEC_OACC_DATA:
2649 : 11949 : case EXEC_OACC_KERNELS:
2650 : 11949 : case EXEC_OACC_KERNELS_LOOP:
2651 : 11949 : case EXEC_OACC_PARALLEL:
2652 : 11949 : case EXEC_OACC_PARALLEL_LOOP:
2653 : 11949 : case EXEC_OACC_SERIAL:
2654 : 11949 : case EXEC_OACC_SERIAL_LOOP:
2655 : 11949 : case EXEC_OACC_ENTER_DATA:
2656 : 11949 : case EXEC_OACC_EXIT_DATA:
2657 : 11949 : case EXEC_OACC_ATOMIC:
2658 : 11949 : case EXEC_OACC_DECLARE:
2659 : 11949 : res = gfc_trans_oacc_directive (code);
2660 : 11949 : break;
2661 : :
2662 : 0 : default:
2663 : 0 : gfc_internal_error ("gfc_trans_code(): Bad statement code");
2664 : : }
2665 : :
2666 : 1107021 : input_location = gfc_get_location (&code->loc);
2667 : :
2668 : 1107021 : if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
2669 : : {
2670 : 1042154 : if (TREE_CODE (res) != STATEMENT_LIST)
2671 : 778184 : SET_EXPR_LOCATION (res, input_location);
2672 : :
2673 : : /* Add the new statement to the block. */
2674 : 1042154 : gfc_add_expr_to_block (&block, res);
2675 : : }
2676 : : }
2677 : :
2678 : : /* Return the finished block. */
2679 : 412456 : return gfc_finish_block (&block);
2680 : : }
2681 : :
2682 : :
2683 : : /* Translate an executable statement with condition, cond. The condition is
2684 : : used by gfc_trans_do to test for IO result conditions inside implied
2685 : : DO loops of READ and WRITE statements. See build_dt in trans-io.cc. */
2686 : :
2687 : : tree
2688 : 55774 : gfc_trans_code_cond (gfc_code * code, tree cond)
2689 : : {
2690 : 55774 : return trans_code (code, cond);
2691 : : }
2692 : :
2693 : : /* Translate an executable statement without condition. */
2694 : :
2695 : : tree
2696 : 358646 : gfc_trans_code (gfc_code * code)
2697 : : {
2698 : 358646 : return trans_code (code, NULL_TREE);
2699 : : }
2700 : :
2701 : :
2702 : : /* This function is called after a complete program unit has been parsed
2703 : : and resolved. */
2704 : :
2705 : : void
2706 : 34957 : gfc_generate_code (gfc_namespace * ns)
2707 : : {
2708 : 34957 : ompws_flags = 0;
2709 : 34957 : if (ns->is_block_data)
2710 : : {
2711 : 72 : gfc_generate_block_data (ns);
2712 : 72 : return;
2713 : : }
2714 : :
2715 : 34885 : gfc_generate_function_code (ns);
2716 : : }
2717 : :
2718 : :
2719 : : /* This function is called after a complete module has been parsed
2720 : : and resolved. */
2721 : :
2722 : : void
2723 : 8586 : gfc_generate_module_code (gfc_namespace * ns)
2724 : : {
2725 : 8586 : gfc_namespace *n;
2726 : 8586 : struct module_htab_entry *entry;
2727 : :
2728 : 8586 : gcc_assert (ns->proc_name->backend_decl == NULL);
2729 : 17172 : ns->proc_name->backend_decl
2730 : 8586 : = build_decl (gfc_get_location (&ns->proc_name->declared_at),
2731 : : NAMESPACE_DECL, get_identifier (ns->proc_name->name),
2732 : : void_type_node);
2733 : 8586 : entry = gfc_find_module (ns->proc_name->name);
2734 : 8586 : if (entry->namespace_decl)
2735 : : /* Buggy sourcecode, using a module before defining it? */
2736 : 0 : entry->decls->empty ();
2737 : 8586 : entry->namespace_decl = ns->proc_name->backend_decl;
2738 : :
2739 : 8586 : gfc_generate_module_vars (ns);
2740 : :
2741 : : /* We need to generate all module function prototypes first, to allow
2742 : : sibling calls. */
2743 : 32475 : for (n = ns->contained; n; n = n->sibling)
2744 : : {
2745 : 23889 : gfc_entry_list *el;
2746 : :
2747 : 23889 : if (!n->proc_name)
2748 : 0 : continue;
2749 : :
2750 : 23889 : gfc_create_function_decl (n, false);
2751 : 23889 : DECL_CONTEXT (n->proc_name->backend_decl) = ns->proc_name->backend_decl;
2752 : 23889 : gfc_module_add_decl (entry, n->proc_name->backend_decl);
2753 : 23889 : for (el = ns->entries; el; el = el->next)
2754 : : {
2755 : 0 : DECL_CONTEXT (el->sym->backend_decl) = ns->proc_name->backend_decl;
2756 : 0 : gfc_module_add_decl (entry, el->sym->backend_decl);
2757 : : }
2758 : : }
2759 : :
2760 : 32475 : for (n = ns->contained; n; n = n->sibling)
2761 : : {
2762 : 23889 : if (!n->proc_name)
2763 : 0 : continue;
2764 : :
2765 : 23889 : gfc_generate_function_code (n);
2766 : : }
2767 : 8586 : }
2768 : :
2769 : :
2770 : : /* Initialize an init/cleanup block with existing code. */
2771 : :
2772 : : void
2773 : 93858 : gfc_start_wrapped_block (gfc_wrapped_block* block, tree code)
2774 : : {
2775 : 93858 : gcc_assert (block);
2776 : :
2777 : 93858 : block->init = NULL_TREE;
2778 : 93858 : block->code = code;
2779 : 93858 : block->cleanup = NULL_TREE;
2780 : 93858 : }
2781 : :
2782 : :
2783 : : /* Add a new pair of initializers/clean-up code. */
2784 : :
2785 : : void
2786 : 347567 : gfc_add_init_cleanup (gfc_wrapped_block* block, tree init, tree cleanup,
2787 : : bool back)
2788 : : {
2789 : 347567 : gcc_assert (block);
2790 : :
2791 : : /* The new pair of init/cleanup should be "wrapped around" the existing
2792 : : block of code, thus the initialization is added to the front and the
2793 : : cleanup to the back. */
2794 : 347567 : add_expr_to_chain (&block->init, init, !back);
2795 : 347567 : add_expr_to_chain (&block->cleanup, cleanup, false);
2796 : 347567 : }
2797 : :
2798 : :
2799 : : /* Finish up a wrapped block by building a corresponding try-finally expr. */
2800 : :
2801 : : tree
2802 : 93858 : gfc_finish_wrapped_block (gfc_wrapped_block* block)
2803 : : {
2804 : 93858 : tree result;
2805 : :
2806 : 93858 : gcc_assert (block);
2807 : :
2808 : : /* Build the final expression. For this, just add init and body together,
2809 : : and put clean-up with that into a TRY_FINALLY_EXPR. */
2810 : 93858 : result = block->init;
2811 : 93858 : add_expr_to_chain (&result, block->code, false);
2812 : 93858 : if (block->cleanup)
2813 : 9821 : result = build2_loc (input_location, TRY_FINALLY_EXPR, void_type_node,
2814 : : result, block->cleanup);
2815 : :
2816 : : /* Clear the block. */
2817 : 93858 : block->init = NULL_TREE;
2818 : 93858 : block->code = NULL_TREE;
2819 : 93858 : block->cleanup = NULL_TREE;
2820 : :
2821 : 93858 : return result;
2822 : : }
2823 : :
2824 : :
2825 : : /* Helper function for marking a boolean expression tree as unlikely. */
2826 : :
2827 : : tree
2828 : 116439 : gfc_unlikely (tree cond, enum br_predictor predictor)
2829 : : {
2830 : 116439 : tree tmp;
2831 : :
2832 : 116439 : if (optimize)
2833 : : {
2834 : 99591 : cond = fold_convert (long_integer_type_node, cond);
2835 : 99591 : tmp = build_zero_cst (long_integer_type_node);
2836 : 99591 : cond = build_call_expr_loc (input_location,
2837 : : builtin_decl_explicit (BUILT_IN_EXPECT),
2838 : : 3, cond, tmp,
2839 : 99591 : build_int_cst (integer_type_node,
2840 : : predictor));
2841 : : }
2842 : 116439 : return cond;
2843 : : }
2844 : :
2845 : :
2846 : : /* Helper function for marking a boolean expression tree as likely. */
2847 : :
2848 : : tree
2849 : 2442 : gfc_likely (tree cond, enum br_predictor predictor)
2850 : : {
2851 : 2442 : tree tmp;
2852 : :
2853 : 2442 : if (optimize)
2854 : : {
2855 : 2129 : cond = fold_convert (long_integer_type_node, cond);
2856 : 2129 : tmp = build_one_cst (long_integer_type_node);
2857 : 2129 : cond = build_call_expr_loc (input_location,
2858 : : builtin_decl_explicit (BUILT_IN_EXPECT),
2859 : : 3, cond, tmp,
2860 : 2129 : build_int_cst (integer_type_node,
2861 : : predictor));
2862 : : }
2863 : 2442 : return cond;
2864 : : }
2865 : :
2866 : :
2867 : : /* Get the string length for a deferred character length component. */
2868 : :
2869 : : bool
2870 : 186568 : gfc_deferred_strlen (gfc_component *c, tree *decl)
2871 : : {
2872 : 186568 : char name[GFC_MAX_SYMBOL_LEN+9];
2873 : 186568 : gfc_component *strlen;
2874 : 186568 : if (!(c->ts.type == BT_CHARACTER
2875 : 11160 : && (c->ts.deferred || c->attr.pdt_string)))
2876 : : return false;
2877 : 4149 : sprintf (name, "_%s_length", c->name);
2878 : 13019 : for (strlen = c; strlen; strlen = strlen->next)
2879 : 13008 : if (strcmp (strlen->name, name) == 0)
2880 : : break;
2881 : 4149 : *decl = strlen ? strlen->backend_decl : NULL_TREE;
2882 : 4149 : return strlen != NULL;
2883 : : }
|
