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