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