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