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