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