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