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