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 if (size == NULL_TREE)
606 size = build_int_cst (size_type_node, 1);
607
608 size = fold_convert (size_type_node, size);
609 size = fold_build2_loc (input_location, MAX_EXPR, size_type_node, size,
610 build_int_cst (size_type_node, 1));
611
612 malloc_tree = builtin_decl_explicit (BUILT_IN_MALLOC);
613 gfc_add_modify (&block2, res,
614 fold_convert (prvoid_type_node,
615 build_call_expr_loc (input_location,
616 malloc_tree, 1, size)));
617
618 /* Optionally check whether malloc was successful. */
619 if (gfc_option.rtcheck & GFC_RTCHECK_MEM)
620 {
621 null_result = fold_build2_loc (input_location, EQ_EXPR,
622 logical_type_node, res,
623 build_int_cst (pvoid_type_node, 0));
624 msg = gfc_build_addr_expr (pchar_type_node,
625 gfc_build_localized_cstring_const ("Memory allocation failed"));
626 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
627 null_result,
628 build_call_expr_loc (input_location,
629 gfor_fndecl_os_error, 1, msg),
630 build_empty_stmt (input_location));
631 gfc_add_expr_to_block (&block2, tmp);
632 }
633
634 malloc_result = gfc_finish_block (&block2);
635 gfc_add_expr_to_block (block, malloc_result);
636
637 if (type != NULL)
638 res = fold_convert (type, res);
639 return res;
640 }
641
642
643 /* Allocate memory, using an optional status argument.
644
645 This function follows the following pseudo-code:
646
647 void *
648 allocate (size_t size, integer_type stat)
649 {
650 void *newmem;
651
652 if (stat requested)
653 stat = 0;
654
655 newmem = malloc (MAX (size, 1));
656 if (newmem == NULL)
657 {
658 if (stat)
659 *stat = LIBERROR_ALLOCATION;
660 else
661 runtime_error ("Allocation would exceed memory limit");
662 }
663 return newmem;
664 } */
665 void
gfc_allocate_using_malloc(stmtblock_t * block,tree pointer,tree size,tree status)666 gfc_allocate_using_malloc (stmtblock_t * block, tree pointer,
667 tree size, tree status)
668 {
669 tree tmp, error_cond;
670 stmtblock_t on_error;
671 tree status_type = status ? TREE_TYPE (status) : NULL_TREE;
672
673 /* If successful and stat= is given, set status to 0. */
674 if (status != NULL_TREE)
675 gfc_add_expr_to_block (block,
676 fold_build2_loc (input_location, MODIFY_EXPR, status_type,
677 status, build_int_cst (status_type, 0)));
678
679 /* The allocation itself. */
680 size = fold_convert (size_type_node, size);
681 gfc_add_modify (block, pointer,
682 fold_convert (TREE_TYPE (pointer),
683 build_call_expr_loc (input_location,
684 builtin_decl_explicit (BUILT_IN_MALLOC), 1,
685 fold_build2_loc (input_location,
686 MAX_EXPR, size_type_node, size,
687 build_int_cst (size_type_node, 1)))));
688
689 /* What to do in case of error. */
690 gfc_start_block (&on_error);
691 if (status != NULL_TREE)
692 {
693 tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, status,
694 build_int_cst (status_type, LIBERROR_ALLOCATION));
695 gfc_add_expr_to_block (&on_error, tmp);
696 }
697 else
698 {
699 /* Here, os_error already implies PRED_NORETURN. */
700 tmp = build_call_expr_loc (input_location, gfor_fndecl_os_error, 1,
701 gfc_build_addr_expr (pchar_type_node,
702 gfc_build_localized_cstring_const
703 ("Allocation would exceed memory limit")));
704 gfc_add_expr_to_block (&on_error, tmp);
705 }
706
707 error_cond = fold_build2_loc (input_location, EQ_EXPR,
708 logical_type_node, pointer,
709 build_int_cst (prvoid_type_node, 0));
710 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
711 gfc_unlikely (error_cond, PRED_FORTRAN_FAIL_ALLOC),
712 gfc_finish_block (&on_error),
713 build_empty_stmt (input_location));
714
715 gfc_add_expr_to_block (block, tmp);
716 }
717
718
719 /* Allocate memory, using an optional status argument.
720
721 This function follows the following pseudo-code:
722
723 void *
724 allocate (size_t size, void** token, int *stat, char* errmsg, int errlen)
725 {
726 void *newmem;
727
728 newmem = _caf_register (size, regtype, token, &stat, errmsg, errlen);
729 return newmem;
730 } */
731 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)732 gfc_allocate_using_caf_lib (stmtblock_t * block, tree pointer, tree size,
733 tree token, tree status, tree errmsg, tree errlen,
734 gfc_coarray_regtype alloc_type)
735 {
736 tree tmp, pstat;
737
738 gcc_assert (token != NULL_TREE);
739
740 /* The allocation itself. */
741 if (status == NULL_TREE)
742 pstat = null_pointer_node;
743 else
744 pstat = gfc_build_addr_expr (NULL_TREE, status);
745
746 if (errmsg == NULL_TREE)
747 {
748 gcc_assert(errlen == NULL_TREE);
749 errmsg = null_pointer_node;
750 errlen = build_int_cst (integer_type_node, 0);
751 }
752
753 size = fold_convert (size_type_node, size);
754 tmp = build_call_expr_loc (input_location,
755 gfor_fndecl_caf_register, 7,
756 fold_build2_loc (input_location,
757 MAX_EXPR, size_type_node, size, size_one_node),
758 build_int_cst (integer_type_node, alloc_type),
759 token, gfc_build_addr_expr (pvoid_type_node, pointer),
760 pstat, errmsg, errlen);
761
762 gfc_add_expr_to_block (block, tmp);
763
764 /* It guarantees memory consistency within the same segment */
765 tmp = gfc_build_string_const (strlen ("memory")+1, "memory"),
766 tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
767 gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
768 tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
769 ASM_VOLATILE_P (tmp) = 1;
770 gfc_add_expr_to_block (block, tmp);
771 }
772
773
774 /* Generate code for an ALLOCATE statement when the argument is an
775 allocatable variable. If the variable is currently allocated, it is an
776 error to allocate it again.
777
778 This function follows the following pseudo-code:
779
780 void *
781 allocate_allocatable (void *mem, size_t size, integer_type stat)
782 {
783 if (mem == NULL)
784 return allocate (size, stat);
785 else
786 {
787 if (stat)
788 stat = LIBERROR_ALLOCATION;
789 else
790 runtime_error ("Attempting to allocate already allocated variable");
791 }
792 }
793
794 expr must be set to the original expression being allocated for its locus
795 and variable name in case a runtime error has to be printed. */
796 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)797 gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size,
798 tree token, tree status, tree errmsg, tree errlen,
799 tree label_finish, gfc_expr* expr, int corank)
800 {
801 stmtblock_t alloc_block;
802 tree tmp, null_mem, alloc, error;
803 tree type = TREE_TYPE (mem);
804 symbol_attribute caf_attr;
805 bool need_assign = false, refs_comp = false;
806 gfc_coarray_regtype caf_alloc_type = GFC_CAF_COARRAY_ALLOC;
807
808 size = fold_convert (size_type_node, size);
809 null_mem = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
810 logical_type_node, mem,
811 build_int_cst (type, 0)),
812 PRED_FORTRAN_REALLOC);
813
814 /* If mem is NULL, we call gfc_allocate_using_malloc or
815 gfc_allocate_using_lib. */
816 gfc_start_block (&alloc_block);
817
818 if (flag_coarray == GFC_FCOARRAY_LIB)
819 caf_attr = gfc_caf_attr (expr, true, &refs_comp);
820
821 if (flag_coarray == GFC_FCOARRAY_LIB
822 && (corank > 0 || caf_attr.codimension))
823 {
824 tree cond, sub_caf_tree;
825 gfc_se se;
826 bool compute_special_caf_types_size = false;
827
828 if (expr->ts.type == BT_DERIVED
829 && expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
830 && expr->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
831 {
832 compute_special_caf_types_size = true;
833 caf_alloc_type = GFC_CAF_LOCK_ALLOC;
834 }
835 else if (expr->ts.type == BT_DERIVED
836 && expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
837 && expr->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
838 {
839 compute_special_caf_types_size = true;
840 caf_alloc_type = GFC_CAF_EVENT_ALLOC;
841 }
842 else if (!caf_attr.coarray_comp && refs_comp)
843 /* Only allocatable components in a derived type coarray can be
844 allocate only. */
845 caf_alloc_type = GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY;
846
847 gfc_init_se (&se, NULL);
848 sub_caf_tree = gfc_get_ultimate_alloc_ptr_comps_caf_token (&se, expr);
849 if (sub_caf_tree == NULL_TREE)
850 sub_caf_tree = token;
851
852 /* When mem is an array ref, then strip the .data-ref. */
853 if (TREE_CODE (mem) == COMPONENT_REF
854 && !(GFC_ARRAY_TYPE_P (TREE_TYPE (mem))))
855 tmp = TREE_OPERAND (mem, 0);
856 else
857 tmp = mem;
858
859 if (!(GFC_ARRAY_TYPE_P (TREE_TYPE (tmp))
860 && TYPE_LANG_SPECIFIC (TREE_TYPE (tmp))->corank == 0)
861 && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
862 {
863 symbol_attribute attr;
864
865 gfc_clear_attr (&attr);
866 tmp = gfc_conv_scalar_to_descriptor (&se, mem, attr);
867 need_assign = true;
868 }
869 gfc_add_block_to_block (&alloc_block, &se.pre);
870
871 /* In the front end, we represent the lock variable as pointer. However,
872 the FE only passes the pointer around and leaves the actual
873 representation to the library. Hence, we have to convert back to the
874 number of elements. */
875 if (compute_special_caf_types_size)
876 size = fold_build2_loc (input_location, TRUNC_DIV_EXPR, size_type_node,
877 size, TYPE_SIZE_UNIT (ptr_type_node));
878
879 gfc_allocate_using_caf_lib (&alloc_block, tmp, size, sub_caf_tree,
880 status, errmsg, errlen, caf_alloc_type);
881 if (need_assign)
882 gfc_add_modify (&alloc_block, mem, fold_convert (TREE_TYPE (mem),
883 gfc_conv_descriptor_data_get (tmp)));
884 if (status != NULL_TREE)
885 {
886 TREE_USED (label_finish) = 1;
887 tmp = build1_v (GOTO_EXPR, label_finish);
888 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
889 status, build_zero_cst (TREE_TYPE (status)));
890 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
891 gfc_unlikely (cond, PRED_FORTRAN_FAIL_ALLOC),
892 tmp, build_empty_stmt (input_location));
893 gfc_add_expr_to_block (&alloc_block, tmp);
894 }
895 }
896 else
897 gfc_allocate_using_malloc (&alloc_block, mem, size, status);
898
899 alloc = gfc_finish_block (&alloc_block);
900
901 /* If mem is not NULL, we issue a runtime error or set the
902 status variable. */
903 if (expr)
904 {
905 tree varname;
906
907 gcc_assert (expr->expr_type == EXPR_VARIABLE && expr->symtree);
908 varname = gfc_build_cstring_const (expr->symtree->name);
909 varname = gfc_build_addr_expr (pchar_type_node, varname);
910
911 error = gfc_trans_runtime_error (true, &expr->where,
912 "Attempting to allocate already"
913 " allocated variable '%s'",
914 varname);
915 }
916 else
917 error = gfc_trans_runtime_error (true, NULL,
918 "Attempting to allocate already allocated"
919 " variable");
920
921 if (status != NULL_TREE)
922 {
923 tree status_type = TREE_TYPE (status);
924
925 error = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
926 status, build_int_cst (status_type, LIBERROR_ALLOCATION));
927 }
928
929 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, null_mem,
930 error, alloc);
931 gfc_add_expr_to_block (block, tmp);
932 }
933
934
935 /* Free a given variable. */
936
937 tree
gfc_call_free(tree var)938 gfc_call_free (tree var)
939 {
940 return build_call_expr_loc (input_location,
941 builtin_decl_explicit (BUILT_IN_FREE),
942 1, fold_convert (pvoid_type_node, var));
943 }
944
945
946 /* Build a call to a FINAL procedure, which finalizes "var". */
947
948 static tree
gfc_build_final_call(gfc_typespec ts,gfc_expr * final_wrapper,gfc_expr * var,bool fini_coarray,gfc_expr * class_size)949 gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var,
950 bool fini_coarray, gfc_expr *class_size)
951 {
952 stmtblock_t block;
953 gfc_se se;
954 tree final_fndecl, array, size, tmp;
955 symbol_attribute attr;
956
957 gcc_assert (final_wrapper->expr_type == EXPR_VARIABLE);
958 gcc_assert (var);
959
960 gfc_start_block (&block);
961 gfc_init_se (&se, NULL);
962 gfc_conv_expr (&se, final_wrapper);
963 final_fndecl = se.expr;
964 if (POINTER_TYPE_P (TREE_TYPE (final_fndecl)))
965 final_fndecl = build_fold_indirect_ref_loc (input_location, final_fndecl);
966
967 if (ts.type == BT_DERIVED)
968 {
969 tree elem_size;
970
971 gcc_assert (!class_size);
972 elem_size = gfc_typenode_for_spec (&ts);
973 elem_size = TYPE_SIZE_UNIT (elem_size);
974 size = fold_convert (gfc_array_index_type, elem_size);
975
976 gfc_init_se (&se, NULL);
977 se.want_pointer = 1;
978 if (var->rank)
979 {
980 se.descriptor_only = 1;
981 gfc_conv_expr_descriptor (&se, var);
982 array = se.expr;
983 }
984 else
985 {
986 gfc_conv_expr (&se, var);
987 gcc_assert (se.pre.head == NULL_TREE && se.post.head == NULL_TREE);
988 array = se.expr;
989
990 /* No copy back needed, hence set attr's allocatable/pointer
991 to zero. */
992 gfc_clear_attr (&attr);
993 gfc_init_se (&se, NULL);
994 array = gfc_conv_scalar_to_descriptor (&se, array, attr);
995 gcc_assert (se.post.head == NULL_TREE);
996 }
997 }
998 else
999 {
1000 gfc_expr *array_expr;
1001 gcc_assert (class_size);
1002 gfc_init_se (&se, NULL);
1003 gfc_conv_expr (&se, class_size);
1004 gfc_add_block_to_block (&block, &se.pre);
1005 gcc_assert (se.post.head == NULL_TREE);
1006 size = se.expr;
1007
1008 array_expr = gfc_copy_expr (var);
1009 gfc_init_se (&se, NULL);
1010 se.want_pointer = 1;
1011 if (array_expr->rank)
1012 {
1013 gfc_add_class_array_ref (array_expr);
1014 se.descriptor_only = 1;
1015 gfc_conv_expr_descriptor (&se, array_expr);
1016 array = se.expr;
1017 }
1018 else
1019 {
1020 gfc_add_data_component (array_expr);
1021 gfc_conv_expr (&se, array_expr);
1022 gfc_add_block_to_block (&block, &se.pre);
1023 gcc_assert (se.post.head == NULL_TREE);
1024 array = se.expr;
1025 if (TREE_CODE (array) == ADDR_EXPR
1026 && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (array, 0))))
1027 tmp = TREE_OPERAND (array, 0);
1028
1029 if (!gfc_is_coarray (array_expr))
1030 {
1031 /* No copy back needed, hence set attr's allocatable/pointer
1032 to zero. */
1033 gfc_clear_attr (&attr);
1034 gfc_init_se (&se, NULL);
1035 array = gfc_conv_scalar_to_descriptor (&se, array, attr);
1036 }
1037 gcc_assert (se.post.head == NULL_TREE);
1038 }
1039 gfc_free_expr (array_expr);
1040 }
1041
1042 if (!POINTER_TYPE_P (TREE_TYPE (array)))
1043 array = gfc_build_addr_expr (NULL, array);
1044
1045 gfc_add_block_to_block (&block, &se.pre);
1046 tmp = build_call_expr_loc (input_location,
1047 final_fndecl, 3, array,
1048 size, fini_coarray ? boolean_true_node
1049 : boolean_false_node);
1050 gfc_add_block_to_block (&block, &se.post);
1051 gfc_add_expr_to_block (&block, tmp);
1052 return gfc_finish_block (&block);
1053 }
1054
1055
1056 bool
gfc_add_comp_finalizer_call(stmtblock_t * block,tree decl,gfc_component * comp,bool fini_coarray)1057 gfc_add_comp_finalizer_call (stmtblock_t *block, tree decl, gfc_component *comp,
1058 bool fini_coarray)
1059 {
1060 gfc_se se;
1061 stmtblock_t block2;
1062 tree final_fndecl, size, array, tmp, cond;
1063 symbol_attribute attr;
1064 gfc_expr *final_expr = NULL;
1065
1066 if (comp->ts.type != BT_DERIVED && comp->ts.type != BT_CLASS)
1067 return false;
1068
1069 gfc_init_block (&block2);
1070
1071 if (comp->ts.type == BT_DERIVED)
1072 {
1073 if (comp->attr.pointer)
1074 return false;
1075
1076 gfc_is_finalizable (comp->ts.u.derived, &final_expr);
1077 if (!final_expr)
1078 return false;
1079
1080 gfc_init_se (&se, NULL);
1081 gfc_conv_expr (&se, final_expr);
1082 final_fndecl = se.expr;
1083 size = gfc_typenode_for_spec (&comp->ts);
1084 size = TYPE_SIZE_UNIT (size);
1085 size = fold_convert (gfc_array_index_type, size);
1086
1087 array = decl;
1088 }
1089 else /* comp->ts.type == BT_CLASS. */
1090 {
1091 if (CLASS_DATA (comp)->attr.class_pointer)
1092 return false;
1093
1094 gfc_is_finalizable (CLASS_DATA (comp)->ts.u.derived, &final_expr);
1095 final_fndecl = gfc_class_vtab_final_get (decl);
1096 size = gfc_class_vtab_size_get (decl);
1097 array = gfc_class_data_get (decl);
1098 }
1099
1100 if (comp->attr.allocatable
1101 || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)->attr.allocatable))
1102 {
1103 tmp = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array))
1104 ? gfc_conv_descriptor_data_get (array) : array;
1105 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1106 tmp, fold_convert (TREE_TYPE (tmp),
1107 null_pointer_node));
1108 }
1109 else
1110 cond = logical_true_node;
1111
1112 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array)))
1113 {
1114 gfc_clear_attr (&attr);
1115 gfc_init_se (&se, NULL);
1116 array = gfc_conv_scalar_to_descriptor (&se, array, attr);
1117 gfc_add_block_to_block (&block2, &se.pre);
1118 gcc_assert (se.post.head == NULL_TREE);
1119 }
1120
1121 if (!POINTER_TYPE_P (TREE_TYPE (array)))
1122 array = gfc_build_addr_expr (NULL, array);
1123
1124 if (!final_expr)
1125 {
1126 tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1127 final_fndecl,
1128 fold_convert (TREE_TYPE (final_fndecl),
1129 null_pointer_node));
1130 cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
1131 logical_type_node, cond, tmp);
1132 }
1133
1134 if (POINTER_TYPE_P (TREE_TYPE (final_fndecl)))
1135 final_fndecl = build_fold_indirect_ref_loc (input_location, final_fndecl);
1136
1137 tmp = build_call_expr_loc (input_location,
1138 final_fndecl, 3, array,
1139 size, fini_coarray ? boolean_true_node
1140 : boolean_false_node);
1141 gfc_add_expr_to_block (&block2, tmp);
1142 tmp = gfc_finish_block (&block2);
1143
1144 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
1145 build_empty_stmt (input_location));
1146 gfc_add_expr_to_block (block, tmp);
1147
1148 return true;
1149 }
1150
1151
1152 /* Add a call to the finalizer, using the passed *expr. Returns
1153 true when a finalizer call has been inserted. */
1154
1155 bool
gfc_add_finalizer_call(stmtblock_t * block,gfc_expr * expr2)1156 gfc_add_finalizer_call (stmtblock_t *block, gfc_expr *expr2)
1157 {
1158 tree tmp;
1159 gfc_ref *ref;
1160 gfc_expr *expr;
1161 gfc_expr *final_expr = NULL;
1162 gfc_expr *elem_size = NULL;
1163 bool has_finalizer = false;
1164
1165 if (!expr2 || (expr2->ts.type != BT_DERIVED && expr2->ts.type != BT_CLASS))
1166 return false;
1167
1168 if (expr2->ts.type == BT_DERIVED)
1169 {
1170 gfc_is_finalizable (expr2->ts.u.derived, &final_expr);
1171 if (!final_expr)
1172 return false;
1173 }
1174
1175 /* If we have a class array, we need go back to the class
1176 container. */
1177 expr = gfc_copy_expr (expr2);
1178
1179 if (expr->ref && expr->ref->next && !expr->ref->next->next
1180 && expr->ref->next->type == REF_ARRAY
1181 && expr->ref->type == REF_COMPONENT
1182 && strcmp (expr->ref->u.c.component->name, "_data") == 0)
1183 {
1184 gfc_free_ref_list (expr->ref);
1185 expr->ref = NULL;
1186 }
1187 else
1188 for (ref = expr->ref; ref; ref = ref->next)
1189 if (ref->next && ref->next->next && !ref->next->next->next
1190 && ref->next->next->type == REF_ARRAY
1191 && ref->next->type == REF_COMPONENT
1192 && strcmp (ref->next->u.c.component->name, "_data") == 0)
1193 {
1194 gfc_free_ref_list (ref->next);
1195 ref->next = NULL;
1196 }
1197
1198 if (expr->ts.type == BT_CLASS)
1199 {
1200 has_finalizer = gfc_is_finalizable (expr->ts.u.derived, NULL);
1201
1202 if (!expr2->rank && !expr2->ref && CLASS_DATA (expr2->symtree->n.sym)->as)
1203 expr->rank = CLASS_DATA (expr2->symtree->n.sym)->as->rank;
1204
1205 final_expr = gfc_copy_expr (expr);
1206 gfc_add_vptr_component (final_expr);
1207 gfc_add_final_component (final_expr);
1208
1209 elem_size = gfc_copy_expr (expr);
1210 gfc_add_vptr_component (elem_size);
1211 gfc_add_size_component (elem_size);
1212 }
1213
1214 gcc_assert (final_expr->expr_type == EXPR_VARIABLE);
1215
1216 tmp = gfc_build_final_call (expr->ts, final_expr, expr,
1217 false, elem_size);
1218
1219 if (expr->ts.type == BT_CLASS && !has_finalizer)
1220 {
1221 tree cond;
1222 gfc_se se;
1223
1224 gfc_init_se (&se, NULL);
1225 se.want_pointer = 1;
1226 gfc_conv_expr (&se, final_expr);
1227 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1228 se.expr, build_int_cst (TREE_TYPE (se.expr), 0));
1229
1230 /* For CLASS(*) not only sym->_vtab->_final can be NULL
1231 but already sym->_vtab itself. */
1232 if (UNLIMITED_POLY (expr))
1233 {
1234 tree cond2;
1235 gfc_expr *vptr_expr;
1236
1237 vptr_expr = gfc_copy_expr (expr);
1238 gfc_add_vptr_component (vptr_expr);
1239
1240 gfc_init_se (&se, NULL);
1241 se.want_pointer = 1;
1242 gfc_conv_expr (&se, vptr_expr);
1243 gfc_free_expr (vptr_expr);
1244
1245 cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1246 se.expr,
1247 build_int_cst (TREE_TYPE (se.expr), 0));
1248 cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
1249 logical_type_node, cond2, cond);
1250 }
1251
1252 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1253 cond, tmp, build_empty_stmt (input_location));
1254 }
1255
1256 gfc_add_expr_to_block (block, tmp);
1257
1258 return true;
1259 }
1260
1261
1262 /* User-deallocate; we emit the code directly from the front-end, and the
1263 logic is the same as the previous library function:
1264
1265 void
1266 deallocate (void *pointer, GFC_INTEGER_4 * stat)
1267 {
1268 if (!pointer)
1269 {
1270 if (stat)
1271 *stat = 1;
1272 else
1273 runtime_error ("Attempt to DEALLOCATE unallocated memory.");
1274 }
1275 else
1276 {
1277 free (pointer);
1278 if (stat)
1279 *stat = 0;
1280 }
1281 }
1282
1283 In this front-end version, status doesn't have to be GFC_INTEGER_4.
1284 Moreover, if CAN_FAIL is true, then we will not emit a runtime error,
1285 even when no status variable is passed to us (this is used for
1286 unconditional deallocation generated by the front-end at end of
1287 each procedure).
1288
1289 If a runtime-message is possible, `expr' must point to the original
1290 expression being deallocated for its locus and variable name.
1291
1292 For coarrays, "pointer" must be the array descriptor and not its
1293 "data" component.
1294
1295 COARRAY_DEALLOC_MODE gives the mode unregister coarrays. Available modes are
1296 the ones of GFC_CAF_DEREGTYPE, -1 when the mode for deregistration is to be
1297 analyzed and set by this routine, and -2 to indicate that a non-coarray is to
1298 be deallocated. */
1299 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)1300 gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
1301 tree errlen, tree label_finish,
1302 bool can_fail, gfc_expr* expr,
1303 int coarray_dealloc_mode, tree add_when_allocated,
1304 tree caf_token)
1305 {
1306 stmtblock_t null, non_null;
1307 tree cond, tmp, error;
1308 tree status_type = NULL_TREE;
1309 tree token = NULL_TREE;
1310 gfc_coarray_deregtype caf_dereg_type = GFC_CAF_COARRAY_DEREGISTER;
1311
1312 if (coarray_dealloc_mode >= GFC_CAF_COARRAY_ANALYZE)
1313 {
1314 if (flag_coarray == GFC_FCOARRAY_LIB)
1315 {
1316 if (caf_token)
1317 token = caf_token;
1318 else
1319 {
1320 tree caf_type, caf_decl = pointer;
1321 pointer = gfc_conv_descriptor_data_get (caf_decl);
1322 caf_type = TREE_TYPE (caf_decl);
1323 STRIP_NOPS (pointer);
1324 if (GFC_DESCRIPTOR_TYPE_P (caf_type))
1325 token = gfc_conv_descriptor_token (caf_decl);
1326 else if (DECL_LANG_SPECIFIC (caf_decl)
1327 && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
1328 token = GFC_DECL_TOKEN (caf_decl);
1329 else
1330 {
1331 gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
1332 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type)
1333 != NULL_TREE);
1334 token = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
1335 }
1336 }
1337
1338 if (coarray_dealloc_mode == GFC_CAF_COARRAY_ANALYZE)
1339 {
1340 bool comp_ref;
1341 if (expr && !gfc_caf_attr (expr, false, &comp_ref).coarray_comp
1342 && comp_ref)
1343 caf_dereg_type = GFC_CAF_COARRAY_DEALLOCATE_ONLY;
1344 // else do a deregister as set by default.
1345 }
1346 else
1347 caf_dereg_type = (enum gfc_coarray_deregtype) coarray_dealloc_mode;
1348 }
1349 else if (flag_coarray == GFC_FCOARRAY_SINGLE)
1350 pointer = gfc_conv_descriptor_data_get (pointer);
1351 }
1352 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer)))
1353 pointer = gfc_conv_descriptor_data_get (pointer);
1354
1355 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, pointer,
1356 build_int_cst (TREE_TYPE (pointer), 0));
1357
1358 /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
1359 we emit a runtime error. */
1360 gfc_start_block (&null);
1361 if (!can_fail)
1362 {
1363 tree varname;
1364
1365 gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree);
1366
1367 varname = gfc_build_cstring_const (expr->symtree->name);
1368 varname = gfc_build_addr_expr (pchar_type_node, varname);
1369
1370 error = gfc_trans_runtime_error (true, &expr->where,
1371 "Attempt to DEALLOCATE unallocated '%s'",
1372 varname);
1373 }
1374 else
1375 error = build_empty_stmt (input_location);
1376
1377 if (status != NULL_TREE && !integer_zerop (status))
1378 {
1379 tree cond2;
1380
1381 status_type = TREE_TYPE (TREE_TYPE (status));
1382 cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1383 status, build_int_cst (TREE_TYPE (status), 0));
1384 tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
1385 fold_build1_loc (input_location, INDIRECT_REF,
1386 status_type, status),
1387 build_int_cst (status_type, 1));
1388 error = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1389 cond2, tmp, error);
1390 }
1391
1392 gfc_add_expr_to_block (&null, error);
1393
1394 /* When POINTER is not NULL, we free it. */
1395 gfc_start_block (&non_null);
1396 if (add_when_allocated)
1397 gfc_add_expr_to_block (&non_null, add_when_allocated);
1398 gfc_add_finalizer_call (&non_null, expr);
1399 if (coarray_dealloc_mode == GFC_CAF_COARRAY_NOCOARRAY
1400 || flag_coarray != GFC_FCOARRAY_LIB)
1401 {
1402 tmp = build_call_expr_loc (input_location,
1403 builtin_decl_explicit (BUILT_IN_FREE), 1,
1404 fold_convert (pvoid_type_node, pointer));
1405 gfc_add_expr_to_block (&non_null, tmp);
1406 gfc_add_modify (&non_null, pointer, build_int_cst (TREE_TYPE (pointer),
1407 0));
1408
1409 if (status != NULL_TREE && !integer_zerop (status))
1410 {
1411 /* We set STATUS to zero if it is present. */
1412 tree status_type = TREE_TYPE (TREE_TYPE (status));
1413 tree cond2;
1414
1415 cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1416 status,
1417 build_int_cst (TREE_TYPE (status), 0));
1418 tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
1419 fold_build1_loc (input_location, INDIRECT_REF,
1420 status_type, status),
1421 build_int_cst (status_type, 0));
1422 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1423 gfc_unlikely (cond2, PRED_FORTRAN_FAIL_ALLOC),
1424 tmp, build_empty_stmt (input_location));
1425 gfc_add_expr_to_block (&non_null, tmp);
1426 }
1427 }
1428 else
1429 {
1430 tree cond2, pstat = null_pointer_node;
1431
1432 if (errmsg == NULL_TREE)
1433 {
1434 gcc_assert (errlen == NULL_TREE);
1435 errmsg = null_pointer_node;
1436 errlen = build_zero_cst (integer_type_node);
1437 }
1438 else
1439 {
1440 gcc_assert (errlen != NULL_TREE);
1441 if (!POINTER_TYPE_P (TREE_TYPE (errmsg)))
1442 errmsg = gfc_build_addr_expr (NULL_TREE, errmsg);
1443 }
1444
1445 if (status != NULL_TREE && !integer_zerop (status))
1446 {
1447 gcc_assert (status_type == integer_type_node);
1448 pstat = status;
1449 }
1450
1451 token = gfc_build_addr_expr (NULL_TREE, token);
1452 gcc_assert (caf_dereg_type > GFC_CAF_COARRAY_ANALYZE);
1453 tmp = build_call_expr_loc (input_location,
1454 gfor_fndecl_caf_deregister, 5,
1455 token, build_int_cst (integer_type_node,
1456 caf_dereg_type),
1457 pstat, errmsg, errlen);
1458 gfc_add_expr_to_block (&non_null, tmp);
1459
1460 /* It guarantees memory consistency within the same segment */
1461 tmp = gfc_build_string_const (strlen ("memory")+1, "memory"),
1462 tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
1463 gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
1464 tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
1465 ASM_VOLATILE_P (tmp) = 1;
1466 gfc_add_expr_to_block (&non_null, tmp);
1467
1468 if (status != NULL_TREE)
1469 {
1470 tree stat = build_fold_indirect_ref_loc (input_location, status);
1471 tree nullify = fold_build2_loc (input_location, MODIFY_EXPR,
1472 void_type_node, pointer,
1473 build_int_cst (TREE_TYPE (pointer),
1474 0));
1475
1476 TREE_USED (label_finish) = 1;
1477 tmp = build1_v (GOTO_EXPR, label_finish);
1478 cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1479 stat, build_zero_cst (TREE_TYPE (stat)));
1480 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1481 gfc_unlikely (cond2, PRED_FORTRAN_REALLOC),
1482 tmp, nullify);
1483 gfc_add_expr_to_block (&non_null, tmp);
1484 }
1485 else
1486 gfc_add_modify (&non_null, pointer, build_int_cst (TREE_TYPE (pointer),
1487 0));
1488 }
1489
1490 return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
1491 gfc_finish_block (&null),
1492 gfc_finish_block (&non_null));
1493 }
1494
1495
1496 /* Generate code for deallocation of allocatable scalars (variables or
1497 components). Before the object itself is freed, any allocatable
1498 subcomponents are being deallocated. */
1499
1500 tree
gfc_deallocate_scalar_with_status(tree pointer,tree status,tree label_finish,bool can_fail,gfc_expr * expr,gfc_typespec ts,bool coarray)1501 gfc_deallocate_scalar_with_status (tree pointer, tree status, tree label_finish,
1502 bool can_fail, gfc_expr* expr,
1503 gfc_typespec ts, bool coarray)
1504 {
1505 stmtblock_t null, non_null;
1506 tree cond, tmp, error;
1507 bool finalizable, comp_ref;
1508 gfc_coarray_deregtype caf_dereg_type = GFC_CAF_COARRAY_DEREGISTER;
1509
1510 if (coarray && expr && !gfc_caf_attr (expr, false, &comp_ref).coarray_comp
1511 && comp_ref)
1512 caf_dereg_type = GFC_CAF_COARRAY_DEALLOCATE_ONLY;
1513
1514 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, pointer,
1515 build_int_cst (TREE_TYPE (pointer), 0));
1516
1517 /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
1518 we emit a runtime error. */
1519 gfc_start_block (&null);
1520 if (!can_fail)
1521 {
1522 tree varname;
1523
1524 gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree);
1525
1526 varname = gfc_build_cstring_const (expr->symtree->name);
1527 varname = gfc_build_addr_expr (pchar_type_node, varname);
1528
1529 error = gfc_trans_runtime_error (true, &expr->where,
1530 "Attempt to DEALLOCATE unallocated '%s'",
1531 varname);
1532 }
1533 else
1534 error = build_empty_stmt (input_location);
1535
1536 if (status != NULL_TREE && !integer_zerop (status))
1537 {
1538 tree status_type = TREE_TYPE (TREE_TYPE (status));
1539 tree cond2;
1540
1541 cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1542 status, build_int_cst (TREE_TYPE (status), 0));
1543 tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
1544 fold_build1_loc (input_location, INDIRECT_REF,
1545 status_type, status),
1546 build_int_cst (status_type, 1));
1547 error = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1548 cond2, tmp, error);
1549 }
1550 gfc_add_expr_to_block (&null, error);
1551
1552 /* When POINTER is not NULL, we free it. */
1553 gfc_start_block (&non_null);
1554
1555 /* Free allocatable components. */
1556 finalizable = gfc_add_finalizer_call (&non_null, expr);
1557 if (!finalizable && ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
1558 {
1559 int caf_mode = coarray
1560 ? ((caf_dereg_type == GFC_CAF_COARRAY_DEALLOCATE_ONLY
1561 ? GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY : 0)
1562 | GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
1563 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY)
1564 : 0;
1565 if (coarray && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer)))
1566 tmp = gfc_conv_descriptor_data_get (pointer);
1567 else
1568 tmp = build_fold_indirect_ref_loc (input_location, pointer);
1569 tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0, caf_mode);
1570 gfc_add_expr_to_block (&non_null, tmp);
1571 }
1572
1573 if (!coarray || flag_coarray == GFC_FCOARRAY_SINGLE)
1574 {
1575 tmp = build_call_expr_loc (input_location,
1576 builtin_decl_explicit (BUILT_IN_FREE), 1,
1577 fold_convert (pvoid_type_node, pointer));
1578 gfc_add_expr_to_block (&non_null, tmp);
1579
1580 if (status != NULL_TREE && !integer_zerop (status))
1581 {
1582 /* We set STATUS to zero if it is present. */
1583 tree status_type = TREE_TYPE (TREE_TYPE (status));
1584 tree cond2;
1585
1586 cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1587 status,
1588 build_int_cst (TREE_TYPE (status), 0));
1589 tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
1590 fold_build1_loc (input_location, INDIRECT_REF,
1591 status_type, status),
1592 build_int_cst (status_type, 0));
1593 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1594 cond2, tmp, build_empty_stmt (input_location));
1595 gfc_add_expr_to_block (&non_null, tmp);
1596 }
1597 }
1598 else
1599 {
1600 tree token;
1601 tree pstat = null_pointer_node;
1602 gfc_se se;
1603
1604 gfc_init_se (&se, NULL);
1605 token = gfc_get_ultimate_alloc_ptr_comps_caf_token (&se, expr);
1606 gcc_assert (token != NULL_TREE);
1607
1608 if (status != NULL_TREE && !integer_zerop (status))
1609 {
1610 gcc_assert (TREE_TYPE (TREE_TYPE (status)) == integer_type_node);
1611 pstat = status;
1612 }
1613
1614 tmp = build_call_expr_loc (input_location,
1615 gfor_fndecl_caf_deregister, 5,
1616 token, build_int_cst (integer_type_node,
1617 caf_dereg_type),
1618 pstat, null_pointer_node, integer_zero_node);
1619 gfc_add_expr_to_block (&non_null, tmp);
1620
1621 /* It guarantees memory consistency within the same segment. */
1622 tmp = gfc_build_string_const (strlen ("memory")+1, "memory");
1623 tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
1624 gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
1625 tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
1626 ASM_VOLATILE_P (tmp) = 1;
1627 gfc_add_expr_to_block (&non_null, tmp);
1628
1629 if (status != NULL_TREE)
1630 {
1631 tree stat = build_fold_indirect_ref_loc (input_location, status);
1632 tree cond2;
1633
1634 TREE_USED (label_finish) = 1;
1635 tmp = build1_v (GOTO_EXPR, label_finish);
1636 cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1637 stat, build_zero_cst (TREE_TYPE (stat)));
1638 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1639 gfc_unlikely (cond2, PRED_FORTRAN_REALLOC),
1640 tmp, build_empty_stmt (input_location));
1641 gfc_add_expr_to_block (&non_null, tmp);
1642 }
1643 }
1644
1645 return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
1646 gfc_finish_block (&null),
1647 gfc_finish_block (&non_null));
1648 }
1649
1650 /* Reallocate MEM so it has SIZE bytes of data. This behaves like the
1651 following pseudo-code:
1652
1653 void *
1654 internal_realloc (void *mem, size_t size)
1655 {
1656 res = realloc (mem, size);
1657 if (!res && size != 0)
1658 _gfortran_os_error ("Allocation would exceed memory limit");
1659
1660 return res;
1661 } */
1662 tree
gfc_call_realloc(stmtblock_t * block,tree mem,tree size)1663 gfc_call_realloc (stmtblock_t * block, tree mem, tree size)
1664 {
1665 tree msg, res, nonzero, null_result, tmp;
1666 tree type = TREE_TYPE (mem);
1667
1668 /* Only evaluate the size once. */
1669 size = save_expr (fold_convert (size_type_node, size));
1670
1671 /* Create a variable to hold the result. */
1672 res = gfc_create_var (type, NULL);
1673
1674 /* Call realloc and check the result. */
1675 tmp = build_call_expr_loc (input_location,
1676 builtin_decl_explicit (BUILT_IN_REALLOC), 2,
1677 fold_convert (pvoid_type_node, mem), size);
1678 gfc_add_modify (block, res, fold_convert (type, tmp));
1679 null_result = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
1680 res, build_int_cst (pvoid_type_node, 0));
1681 nonzero = fold_build2_loc (input_location, NE_EXPR, logical_type_node, size,
1682 build_int_cst (size_type_node, 0));
1683 null_result = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
1684 null_result, nonzero);
1685 msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
1686 ("Allocation would exceed memory limit"));
1687 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1688 null_result,
1689 build_call_expr_loc (input_location,
1690 gfor_fndecl_os_error, 1, msg),
1691 build_empty_stmt (input_location));
1692 gfc_add_expr_to_block (block, tmp);
1693
1694 return res;
1695 }
1696
1697
1698 /* Add an expression to another one, either at the front or the back. */
1699
1700 static void
add_expr_to_chain(tree * chain,tree expr,bool front)1701 add_expr_to_chain (tree* chain, tree expr, bool front)
1702 {
1703 if (expr == NULL_TREE || IS_EMPTY_STMT (expr))
1704 return;
1705
1706 if (*chain)
1707 {
1708 if (TREE_CODE (*chain) != STATEMENT_LIST)
1709 {
1710 tree tmp;
1711
1712 tmp = *chain;
1713 *chain = NULL_TREE;
1714 append_to_statement_list (tmp, chain);
1715 }
1716
1717 if (front)
1718 {
1719 tree_stmt_iterator i;
1720
1721 i = tsi_start (*chain);
1722 tsi_link_before (&i, expr, TSI_CONTINUE_LINKING);
1723 }
1724 else
1725 append_to_statement_list (expr, chain);
1726 }
1727 else
1728 *chain = expr;
1729 }
1730
1731
1732 /* Add a statement at the end of a block. */
1733
1734 void
gfc_add_expr_to_block(stmtblock_t * block,tree expr)1735 gfc_add_expr_to_block (stmtblock_t * block, tree expr)
1736 {
1737 gcc_assert (block);
1738 add_expr_to_chain (&block->head, expr, false);
1739 }
1740
1741
1742 /* Add a statement at the beginning of a block. */
1743
1744 void
gfc_prepend_expr_to_block(stmtblock_t * block,tree expr)1745 gfc_prepend_expr_to_block (stmtblock_t * block, tree expr)
1746 {
1747 gcc_assert (block);
1748 add_expr_to_chain (&block->head, expr, true);
1749 }
1750
1751
1752 /* Add a block the end of a block. */
1753
1754 void
gfc_add_block_to_block(stmtblock_t * block,stmtblock_t * append)1755 gfc_add_block_to_block (stmtblock_t * block, stmtblock_t * append)
1756 {
1757 gcc_assert (append);
1758 gcc_assert (!append->has_scope);
1759
1760 gfc_add_expr_to_block (block, append->head);
1761 append->head = NULL_TREE;
1762 }
1763
1764
1765 /* Save the current locus. The structure may not be complete, and should
1766 only be used with gfc_restore_backend_locus. */
1767
1768 void
gfc_save_backend_locus(locus * loc)1769 gfc_save_backend_locus (locus * loc)
1770 {
1771 loc->lb = XCNEW (gfc_linebuf);
1772 loc->lb->location = input_location;
1773 loc->lb->file = gfc_current_backend_file;
1774 }
1775
1776
1777 /* Set the current locus. */
1778
1779 void
gfc_set_backend_locus(locus * loc)1780 gfc_set_backend_locus (locus * loc)
1781 {
1782 gfc_current_backend_file = loc->lb->file;
1783 input_location = loc->lb->location;
1784 }
1785
1786
1787 /* Restore the saved locus. Only used in conjunction with
1788 gfc_save_backend_locus, to free the memory when we are done. */
1789
1790 void
gfc_restore_backend_locus(locus * loc)1791 gfc_restore_backend_locus (locus * loc)
1792 {
1793 gfc_set_backend_locus (loc);
1794 free (loc->lb);
1795 }
1796
1797
1798 /* Translate an executable statement. The tree cond is used by gfc_trans_do.
1799 This static function is wrapped by gfc_trans_code_cond and
1800 gfc_trans_code. */
1801
1802 static tree
trans_code(gfc_code * code,tree cond)1803 trans_code (gfc_code * code, tree cond)
1804 {
1805 stmtblock_t block;
1806 tree res;
1807
1808 if (!code)
1809 return build_empty_stmt (input_location);
1810
1811 gfc_start_block (&block);
1812
1813 /* Translate statements one by one into GENERIC trees until we reach
1814 the end of this gfc_code branch. */
1815 for (; code; code = code->next)
1816 {
1817 if (code->here != 0)
1818 {
1819 res = gfc_trans_label_here (code);
1820 gfc_add_expr_to_block (&block, res);
1821 }
1822
1823 gfc_current_locus = code->loc;
1824 gfc_set_backend_locus (&code->loc);
1825
1826 switch (code->op)
1827 {
1828 case EXEC_NOP:
1829 case EXEC_END_BLOCK:
1830 case EXEC_END_NESTED_BLOCK:
1831 case EXEC_END_PROCEDURE:
1832 res = NULL_TREE;
1833 break;
1834
1835 case EXEC_ASSIGN:
1836 res = gfc_trans_assign (code);
1837 break;
1838
1839 case EXEC_LABEL_ASSIGN:
1840 res = gfc_trans_label_assign (code);
1841 break;
1842
1843 case EXEC_POINTER_ASSIGN:
1844 res = gfc_trans_pointer_assign (code);
1845 break;
1846
1847 case EXEC_INIT_ASSIGN:
1848 if (code->expr1->ts.type == BT_CLASS)
1849 res = gfc_trans_class_init_assign (code);
1850 else
1851 res = gfc_trans_init_assign (code);
1852 break;
1853
1854 case EXEC_CONTINUE:
1855 res = NULL_TREE;
1856 break;
1857
1858 case EXEC_CRITICAL:
1859 res = gfc_trans_critical (code);
1860 break;
1861
1862 case EXEC_CYCLE:
1863 res = gfc_trans_cycle (code);
1864 break;
1865
1866 case EXEC_EXIT:
1867 res = gfc_trans_exit (code);
1868 break;
1869
1870 case EXEC_GOTO:
1871 res = gfc_trans_goto (code);
1872 break;
1873
1874 case EXEC_ENTRY:
1875 res = gfc_trans_entry (code);
1876 break;
1877
1878 case EXEC_PAUSE:
1879 res = gfc_trans_pause (code);
1880 break;
1881
1882 case EXEC_STOP:
1883 case EXEC_ERROR_STOP:
1884 res = gfc_trans_stop (code, code->op == EXEC_ERROR_STOP);
1885 break;
1886
1887 case EXEC_CALL:
1888 /* For MVBITS we've got the special exception that we need a
1889 dependency check, too. */
1890 {
1891 bool is_mvbits = false;
1892
1893 if (code->resolved_isym)
1894 {
1895 res = gfc_conv_intrinsic_subroutine (code);
1896 if (res != NULL_TREE)
1897 break;
1898 }
1899
1900 if (code->resolved_isym
1901 && code->resolved_isym->id == GFC_ISYM_MVBITS)
1902 is_mvbits = true;
1903
1904 res = gfc_trans_call (code, is_mvbits, NULL_TREE,
1905 NULL_TREE, false);
1906 }
1907 break;
1908
1909 case EXEC_CALL_PPC:
1910 res = gfc_trans_call (code, false, NULL_TREE,
1911 NULL_TREE, false);
1912 break;
1913
1914 case EXEC_ASSIGN_CALL:
1915 res = gfc_trans_call (code, true, NULL_TREE,
1916 NULL_TREE, false);
1917 break;
1918
1919 case EXEC_RETURN:
1920 res = gfc_trans_return (code);
1921 break;
1922
1923 case EXEC_IF:
1924 res = gfc_trans_if (code);
1925 break;
1926
1927 case EXEC_ARITHMETIC_IF:
1928 res = gfc_trans_arithmetic_if (code);
1929 break;
1930
1931 case EXEC_BLOCK:
1932 res = gfc_trans_block_construct (code);
1933 break;
1934
1935 case EXEC_DO:
1936 res = gfc_trans_do (code, cond);
1937 break;
1938
1939 case EXEC_DO_CONCURRENT:
1940 res = gfc_trans_do_concurrent (code);
1941 break;
1942
1943 case EXEC_DO_WHILE:
1944 res = gfc_trans_do_while (code);
1945 break;
1946
1947 case EXEC_SELECT:
1948 res = gfc_trans_select (code);
1949 break;
1950
1951 case EXEC_SELECT_TYPE:
1952 res = gfc_trans_select_type (code);
1953 break;
1954
1955 case EXEC_FLUSH:
1956 res = gfc_trans_flush (code);
1957 break;
1958
1959 case EXEC_SYNC_ALL:
1960 case EXEC_SYNC_IMAGES:
1961 case EXEC_SYNC_MEMORY:
1962 res = gfc_trans_sync (code, code->op);
1963 break;
1964
1965 case EXEC_LOCK:
1966 case EXEC_UNLOCK:
1967 res = gfc_trans_lock_unlock (code, code->op);
1968 break;
1969
1970 case EXEC_EVENT_POST:
1971 case EXEC_EVENT_WAIT:
1972 res = gfc_trans_event_post_wait (code, code->op);
1973 break;
1974
1975 case EXEC_FAIL_IMAGE:
1976 res = gfc_trans_fail_image (code);
1977 break;
1978
1979 case EXEC_FORALL:
1980 res = gfc_trans_forall (code);
1981 break;
1982
1983 case EXEC_FORM_TEAM:
1984 res = gfc_trans_form_team (code);
1985 break;
1986
1987 case EXEC_CHANGE_TEAM:
1988 res = gfc_trans_change_team (code);
1989 break;
1990
1991 case EXEC_END_TEAM:
1992 res = gfc_trans_end_team (code);
1993 break;
1994
1995 case EXEC_SYNC_TEAM:
1996 res = gfc_trans_sync_team (code);
1997 break;
1998
1999 case EXEC_WHERE:
2000 res = gfc_trans_where (code);
2001 break;
2002
2003 case EXEC_ALLOCATE:
2004 res = gfc_trans_allocate (code);
2005 break;
2006
2007 case EXEC_DEALLOCATE:
2008 res = gfc_trans_deallocate (code);
2009 break;
2010
2011 case EXEC_OPEN:
2012 res = gfc_trans_open (code);
2013 break;
2014
2015 case EXEC_CLOSE:
2016 res = gfc_trans_close (code);
2017 break;
2018
2019 case EXEC_READ:
2020 res = gfc_trans_read (code);
2021 break;
2022
2023 case EXEC_WRITE:
2024 res = gfc_trans_write (code);
2025 break;
2026
2027 case EXEC_IOLENGTH:
2028 res = gfc_trans_iolength (code);
2029 break;
2030
2031 case EXEC_BACKSPACE:
2032 res = gfc_trans_backspace (code);
2033 break;
2034
2035 case EXEC_ENDFILE:
2036 res = gfc_trans_endfile (code);
2037 break;
2038
2039 case EXEC_INQUIRE:
2040 res = gfc_trans_inquire (code);
2041 break;
2042
2043 case EXEC_WAIT:
2044 res = gfc_trans_wait (code);
2045 break;
2046
2047 case EXEC_REWIND:
2048 res = gfc_trans_rewind (code);
2049 break;
2050
2051 case EXEC_TRANSFER:
2052 res = gfc_trans_transfer (code);
2053 break;
2054
2055 case EXEC_DT_END:
2056 res = gfc_trans_dt_end (code);
2057 break;
2058
2059 case EXEC_OMP_ATOMIC:
2060 case EXEC_OMP_BARRIER:
2061 case EXEC_OMP_CANCEL:
2062 case EXEC_OMP_CANCELLATION_POINT:
2063 case EXEC_OMP_CRITICAL:
2064 case EXEC_OMP_DISTRIBUTE:
2065 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
2066 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
2067 case EXEC_OMP_DISTRIBUTE_SIMD:
2068 case EXEC_OMP_DO:
2069 case EXEC_OMP_DO_SIMD:
2070 case EXEC_OMP_FLUSH:
2071 case EXEC_OMP_MASTER:
2072 case EXEC_OMP_ORDERED:
2073 case EXEC_OMP_PARALLEL:
2074 case EXEC_OMP_PARALLEL_DO:
2075 case EXEC_OMP_PARALLEL_DO_SIMD:
2076 case EXEC_OMP_PARALLEL_SECTIONS:
2077 case EXEC_OMP_PARALLEL_WORKSHARE:
2078 case EXEC_OMP_SECTIONS:
2079 case EXEC_OMP_SIMD:
2080 case EXEC_OMP_SINGLE:
2081 case EXEC_OMP_TARGET:
2082 case EXEC_OMP_TARGET_DATA:
2083 case EXEC_OMP_TARGET_ENTER_DATA:
2084 case EXEC_OMP_TARGET_EXIT_DATA:
2085 case EXEC_OMP_TARGET_PARALLEL:
2086 case EXEC_OMP_TARGET_PARALLEL_DO:
2087 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
2088 case EXEC_OMP_TARGET_SIMD:
2089 case EXEC_OMP_TARGET_TEAMS:
2090 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
2091 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
2092 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
2093 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
2094 case EXEC_OMP_TARGET_UPDATE:
2095 case EXEC_OMP_TASK:
2096 case EXEC_OMP_TASKGROUP:
2097 case EXEC_OMP_TASKLOOP:
2098 case EXEC_OMP_TASKLOOP_SIMD:
2099 case EXEC_OMP_TASKWAIT:
2100 case EXEC_OMP_TASKYIELD:
2101 case EXEC_OMP_TEAMS:
2102 case EXEC_OMP_TEAMS_DISTRIBUTE:
2103 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
2104 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
2105 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
2106 case EXEC_OMP_WORKSHARE:
2107 res = gfc_trans_omp_directive (code);
2108 break;
2109
2110 case EXEC_OACC_CACHE:
2111 case EXEC_OACC_WAIT:
2112 case EXEC_OACC_UPDATE:
2113 case EXEC_OACC_LOOP:
2114 case EXEC_OACC_HOST_DATA:
2115 case EXEC_OACC_DATA:
2116 case EXEC_OACC_KERNELS:
2117 case EXEC_OACC_KERNELS_LOOP:
2118 case EXEC_OACC_PARALLEL:
2119 case EXEC_OACC_PARALLEL_LOOP:
2120 case EXEC_OACC_ENTER_DATA:
2121 case EXEC_OACC_EXIT_DATA:
2122 case EXEC_OACC_ATOMIC:
2123 case EXEC_OACC_DECLARE:
2124 res = gfc_trans_oacc_directive (code);
2125 break;
2126
2127 default:
2128 gfc_internal_error ("gfc_trans_code(): Bad statement code");
2129 }
2130
2131 gfc_set_backend_locus (&code->loc);
2132
2133 if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
2134 {
2135 if (TREE_CODE (res) != STATEMENT_LIST)
2136 SET_EXPR_LOCATION (res, input_location);
2137
2138 /* Add the new statement to the block. */
2139 gfc_add_expr_to_block (&block, res);
2140 }
2141 }
2142
2143 /* Return the finished block. */
2144 return gfc_finish_block (&block);
2145 }
2146
2147
2148 /* Translate an executable statement with condition, cond. The condition is
2149 used by gfc_trans_do to test for IO result conditions inside implied
2150 DO loops of READ and WRITE statements. See build_dt in trans-io.c. */
2151
2152 tree
gfc_trans_code_cond(gfc_code * code,tree cond)2153 gfc_trans_code_cond (gfc_code * code, tree cond)
2154 {
2155 return trans_code (code, cond);
2156 }
2157
2158 /* Translate an executable statement without condition. */
2159
2160 tree
gfc_trans_code(gfc_code * code)2161 gfc_trans_code (gfc_code * code)
2162 {
2163 return trans_code (code, NULL_TREE);
2164 }
2165
2166
2167 /* This function is called after a complete program unit has been parsed
2168 and resolved. */
2169
2170 void
gfc_generate_code(gfc_namespace * ns)2171 gfc_generate_code (gfc_namespace * ns)
2172 {
2173 ompws_flags = 0;
2174 if (ns->is_block_data)
2175 {
2176 gfc_generate_block_data (ns);
2177 return;
2178 }
2179
2180 gfc_generate_function_code (ns);
2181 }
2182
2183
2184 /* This function is called after a complete module has been parsed
2185 and resolved. */
2186
2187 void
gfc_generate_module_code(gfc_namespace * ns)2188 gfc_generate_module_code (gfc_namespace * ns)
2189 {
2190 gfc_namespace *n;
2191 struct module_htab_entry *entry;
2192
2193 gcc_assert (ns->proc_name->backend_decl == NULL);
2194 ns->proc_name->backend_decl
2195 = build_decl (ns->proc_name->declared_at.lb->location,
2196 NAMESPACE_DECL, get_identifier (ns->proc_name->name),
2197 void_type_node);
2198 entry = gfc_find_module (ns->proc_name->name);
2199 if (entry->namespace_decl)
2200 /* Buggy sourcecode, using a module before defining it? */
2201 entry->decls->empty ();
2202 entry->namespace_decl = ns->proc_name->backend_decl;
2203
2204 gfc_generate_module_vars (ns);
2205
2206 /* We need to generate all module function prototypes first, to allow
2207 sibling calls. */
2208 for (n = ns->contained; n; n = n->sibling)
2209 {
2210 gfc_entry_list *el;
2211
2212 if (!n->proc_name)
2213 continue;
2214
2215 gfc_create_function_decl (n, false);
2216 DECL_CONTEXT (n->proc_name->backend_decl) = ns->proc_name->backend_decl;
2217 gfc_module_add_decl (entry, n->proc_name->backend_decl);
2218 for (el = ns->entries; el; el = el->next)
2219 {
2220 DECL_CONTEXT (el->sym->backend_decl) = ns->proc_name->backend_decl;
2221 gfc_module_add_decl (entry, el->sym->backend_decl);
2222 }
2223 }
2224
2225 for (n = ns->contained; n; n = n->sibling)
2226 {
2227 if (!n->proc_name)
2228 continue;
2229
2230 gfc_generate_function_code (n);
2231 }
2232 }
2233
2234
2235 /* Initialize an init/cleanup block with existing code. */
2236
2237 void
gfc_start_wrapped_block(gfc_wrapped_block * block,tree code)2238 gfc_start_wrapped_block (gfc_wrapped_block* block, tree code)
2239 {
2240 gcc_assert (block);
2241
2242 block->init = NULL_TREE;
2243 block->code = code;
2244 block->cleanup = NULL_TREE;
2245 }
2246
2247
2248 /* Add a new pair of initializers/clean-up code. */
2249
2250 void
gfc_add_init_cleanup(gfc_wrapped_block * block,tree init,tree cleanup)2251 gfc_add_init_cleanup (gfc_wrapped_block* block, tree init, tree cleanup)
2252 {
2253 gcc_assert (block);
2254
2255 /* The new pair of init/cleanup should be "wrapped around" the existing
2256 block of code, thus the initialization is added to the front and the
2257 cleanup to the back. */
2258 add_expr_to_chain (&block->init, init, true);
2259 add_expr_to_chain (&block->cleanup, cleanup, false);
2260 }
2261
2262
2263 /* Finish up a wrapped block by building a corresponding try-finally expr. */
2264
2265 tree
gfc_finish_wrapped_block(gfc_wrapped_block * block)2266 gfc_finish_wrapped_block (gfc_wrapped_block* block)
2267 {
2268 tree result;
2269
2270 gcc_assert (block);
2271
2272 /* Build the final expression. For this, just add init and body together,
2273 and put clean-up with that into a TRY_FINALLY_EXPR. */
2274 result = block->init;
2275 add_expr_to_chain (&result, block->code, false);
2276 if (block->cleanup)
2277 result = build2_loc (input_location, TRY_FINALLY_EXPR, void_type_node,
2278 result, block->cleanup);
2279
2280 /* Clear the block. */
2281 block->init = NULL_TREE;
2282 block->code = NULL_TREE;
2283 block->cleanup = NULL_TREE;
2284
2285 return result;
2286 }
2287
2288
2289 /* Helper function for marking a boolean expression tree as unlikely. */
2290
2291 tree
gfc_unlikely(tree cond,enum br_predictor predictor)2292 gfc_unlikely (tree cond, enum br_predictor predictor)
2293 {
2294 tree tmp;
2295
2296 if (optimize)
2297 {
2298 cond = fold_convert (long_integer_type_node, cond);
2299 tmp = build_zero_cst (long_integer_type_node);
2300 cond = build_call_expr_loc (input_location,
2301 builtin_decl_explicit (BUILT_IN_EXPECT),
2302 3, cond, tmp,
2303 build_int_cst (integer_type_node,
2304 predictor));
2305 }
2306 return cond;
2307 }
2308
2309
2310 /* Helper function for marking a boolean expression tree as likely. */
2311
2312 tree
gfc_likely(tree cond,enum br_predictor predictor)2313 gfc_likely (tree cond, enum br_predictor predictor)
2314 {
2315 tree tmp;
2316
2317 if (optimize)
2318 {
2319 cond = fold_convert (long_integer_type_node, cond);
2320 tmp = build_one_cst (long_integer_type_node);
2321 cond = build_call_expr_loc (input_location,
2322 builtin_decl_explicit (BUILT_IN_EXPECT),
2323 3, cond, tmp,
2324 build_int_cst (integer_type_node,
2325 predictor));
2326 }
2327 return cond;
2328 }
2329
2330
2331 /* Get the string length for a deferred character length component. */
2332
2333 bool
gfc_deferred_strlen(gfc_component * c,tree * decl)2334 gfc_deferred_strlen (gfc_component *c, tree *decl)
2335 {
2336 char name[GFC_MAX_SYMBOL_LEN+9];
2337 gfc_component *strlen;
2338 if (!(c->ts.type == BT_CHARACTER
2339 && (c->ts.deferred || c->attr.pdt_string)))
2340 return false;
2341 sprintf (name, "_%s_length", c->name);
2342 for (strlen = c; strlen; strlen = strlen->next)
2343 if (strcmp (strlen->name, name) == 0)
2344 break;
2345 *decl = strlen ? strlen->backend_decl : NULL_TREE;
2346 return strlen != NULL;
2347 }
2348