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