?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
* fi.po: Update.
[official-gcc.git] / gcc / fortran / trans.c
blobdcbf7c346d39005d8b0bfd48dd803e64893e2ce1
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 && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
1307 token = gfc_conv_descriptor_token (caf_decl);
1308 else if (DECL_LANG_SPECIFIC (caf_decl)
1309 && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
1310 token = GFC_DECL_TOKEN (caf_decl);
1311 else
1312 {
1313 gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
1314 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type)
1315 != NULL_TREE);
1316 token = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
1317 }
1318 }
1319
1320 if (coarray_dealloc_mode == GFC_CAF_COARRAY_ANALYZE)
1321 {
1322 bool comp_ref;
1323 if (expr && !gfc_caf_attr (expr, false, &comp_ref).coarray_comp
1324 && comp_ref)
1325 caf_dereg_type = GFC_CAF_COARRAY_DEALLOCATE_ONLY;
1326 // else do a deregister as set by default.
1327 }
1328 else
1329 caf_dereg_type = (enum gfc_coarray_deregtype) coarray_dealloc_mode;
1330 }
1331 else if (flag_coarray == GFC_FCOARRAY_SINGLE)
1332 pointer = gfc_conv_descriptor_data_get (pointer);
1333 }
1334 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer)))
1335 pointer = gfc_conv_descriptor_data_get (pointer);
1336
1337 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer,
1338 build_int_cst (TREE_TYPE (pointer), 0));
1339
1340 /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
1341 we emit a runtime error. */
1342 gfc_start_block (&null);
1343 if (!can_fail)
1344 {
1345 tree varname;
1346
1347 gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree);
1348
1349 varname = gfc_build_cstring_const (expr->symtree->name);
1350 varname = gfc_build_addr_expr (pchar_type_node, varname);
1351
1352 error = gfc_trans_runtime_error (true, &expr->where,
1353 "Attempt to DEALLOCATE unallocated '%s'",
1354 varname);
1355 }
1356 else
1357 error = build_empty_stmt (input_location);
1358
1359 if (status != NULL_TREE && !integer_zerop (status))
1360 {
1361 tree cond2;
1362
1363 status_type = TREE_TYPE (TREE_TYPE (status));
1364 cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
1365 status, build_int_cst (TREE_TYPE (status), 0));
1366 tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
1367 fold_build1_loc (input_location, INDIRECT_REF,
1368 status_type, status),
1369 build_int_cst (status_type, 1));
1370 error = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1371 cond2, tmp, error);
1372 }
1373
1374 gfc_add_expr_to_block (&null, error);
1375
1376 /* When POINTER is not NULL, we free it. */
1377 gfc_start_block (&non_null);
1378 if (add_when_allocated)
1379 gfc_add_expr_to_block (&non_null, add_when_allocated);
1380 gfc_add_finalizer_call (&non_null, expr);
1381 if (coarray_dealloc_mode == GFC_CAF_COARRAY_NOCOARRAY
1382 || flag_coarray != GFC_FCOARRAY_LIB)
1383 {
1384 tmp = build_call_expr_loc (input_location,
1385 builtin_decl_explicit (BUILT_IN_FREE), 1,
1386 fold_convert (pvoid_type_node, pointer));
1387 gfc_add_expr_to_block (&non_null, tmp);
1388 gfc_add_modify (&non_null, pointer, build_int_cst (TREE_TYPE (pointer),
1389 0));
1390
1391 if (status != NULL_TREE && !integer_zerop (status))
1392 {
1393 /* We set STATUS to zero if it is present. */
1394 tree status_type = TREE_TYPE (TREE_TYPE (status));
1395 tree cond2;
1396
1397 cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
1398 status,
1399 build_int_cst (TREE_TYPE (status), 0));
1400 tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
1401 fold_build1_loc (input_location, INDIRECT_REF,
1402 status_type, status),
1403 build_int_cst (status_type, 0));
1404 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1405 gfc_unlikely (cond2, PRED_FORTRAN_FAIL_ALLOC),
1406 tmp, build_empty_stmt (input_location));
1407 gfc_add_expr_to_block (&non_null, tmp);
1408 }
1409 }
1410 else
1411 {
1412 tree cond2, pstat = null_pointer_node;
1413
1414 if (errmsg == NULL_TREE)
1415 {
1416 gcc_assert (errlen == NULL_TREE);
1417 errmsg = null_pointer_node;
1418 errlen = build_zero_cst (integer_type_node);
1419 }
1420 else
1421 {
1422 gcc_assert (errlen != NULL_TREE);
1423 if (!POINTER_TYPE_P (TREE_TYPE (errmsg)))
1424 errmsg = gfc_build_addr_expr (NULL_TREE, errmsg);
1425 }
1426
1427 if (status != NULL_TREE && !integer_zerop (status))
1428 {
1429 gcc_assert (status_type == integer_type_node);
1430 pstat = status;
1431 }
1432
1433 token = gfc_build_addr_expr (NULL_TREE, token);
1434 gcc_assert (caf_dereg_type > GFC_CAF_COARRAY_ANALYZE);
1435 tmp = build_call_expr_loc (input_location,
1436 gfor_fndecl_caf_deregister, 5,
1437 token, build_int_cst (integer_type_node,
1438 caf_dereg_type),
1439 pstat, errmsg, errlen);
1440 gfc_add_expr_to_block (&non_null, tmp);
1441
1442 /* It guarantees memory consistency within the same segment */
1443 tmp = gfc_build_string_const (strlen ("memory")+1, "memory"),
1444 tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
1445 gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
1446 tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
1447 ASM_VOLATILE_P (tmp) = 1;
1448 gfc_add_expr_to_block (&non_null, tmp);
1449
1450 if (status != NULL_TREE)
1451 {
1452 tree stat = build_fold_indirect_ref_loc (input_location, status);
1453 tree nullify = fold_build2_loc (input_location, MODIFY_EXPR,
1454 void_type_node, pointer,
1455 build_int_cst (TREE_TYPE (pointer),
1456 0));
1457
1458 TREE_USED (label_finish) = 1;
1459 tmp = build1_v (GOTO_EXPR, label_finish);
1460 cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
1461 stat, build_zero_cst (TREE_TYPE (stat)));
1462 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1463 gfc_unlikely (cond2, PRED_FORTRAN_REALLOC),
1464 tmp, nullify);
1465 gfc_add_expr_to_block (&non_null, tmp);
1466 }
1467 else
1468 gfc_add_modify (&non_null, pointer, build_int_cst (TREE_TYPE (pointer),
1469 0));
1470 }
1471
1472 return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
1473 gfc_finish_block (&null),
1474 gfc_finish_block (&non_null));
1475 }
1476
1477
1478 /* Generate code for deallocation of allocatable scalars (variables or
1479 components). Before the object itself is freed, any allocatable
1480 subcomponents are being deallocated. */
1481
1482 tree
1483 gfc_deallocate_scalar_with_status (tree pointer, tree status, tree label_finish,
1484 bool can_fail, gfc_expr* expr,
1485 gfc_typespec ts, bool coarray)
1486 {
1487 stmtblock_t null, non_null;
1488 tree cond, tmp, error;
1489 bool finalizable, comp_ref;
1490 gfc_coarray_deregtype caf_dereg_type = GFC_CAF_COARRAY_DEREGISTER;
1491
1492 if (coarray && expr && !gfc_caf_attr (expr, false, &comp_ref).coarray_comp
1493 && comp_ref)
1494 caf_dereg_type = GFC_CAF_COARRAY_DEALLOCATE_ONLY;
1495
1496 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer,
1497 build_int_cst (TREE_TYPE (pointer), 0));
1498
1499 /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
1500 we emit a runtime error. */
1501 gfc_start_block (&null);
1502 if (!can_fail)
1503 {
1504 tree varname;
1505
1506 gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree);
1507
1508 varname = gfc_build_cstring_const (expr->symtree->name);
1509 varname = gfc_build_addr_expr (pchar_type_node, varname);
1510
1511 error = gfc_trans_runtime_error (true, &expr->where,
1512 "Attempt to DEALLOCATE unallocated '%s'",
1513 varname);
1514 }
1515 else
1516 error = build_empty_stmt (input_location);
1517
1518 if (status != NULL_TREE && !integer_zerop (status))
1519 {
1520 tree status_type = TREE_TYPE (TREE_TYPE (status));
1521 tree cond2;
1522
1523 cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
1524 status, build_int_cst (TREE_TYPE (status), 0));
1525 tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
1526 fold_build1_loc (input_location, INDIRECT_REF,
1527 status_type, status),
1528 build_int_cst (status_type, 1));
1529 error = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1530 cond2, tmp, error);
1531 }
1532 gfc_add_expr_to_block (&null, error);
1533
1534 /* When POINTER is not NULL, we free it. */
1535 gfc_start_block (&non_null);
1536
1537 /* Free allocatable components. */
1538 finalizable = gfc_add_finalizer_call (&non_null, expr);
1539 if (!finalizable && ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
1540 {
1541 int caf_mode = coarray
1542 ? ((caf_dereg_type == GFC_CAF_COARRAY_DEALLOCATE_ONLY
1543 ? GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY : 0)
1544 | GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
1545 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY)
1546 : 0;
1547 if (coarray && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer)))
1548 tmp = gfc_conv_descriptor_data_get (pointer);
1549 else
1550 tmp = build_fold_indirect_ref_loc (input_location, pointer);
1551 tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0, caf_mode);
1552 gfc_add_expr_to_block (&non_null, tmp);
1553 }
1554
1555 if (!coarray)
1556 {
1557 tmp = build_call_expr_loc (input_location,
1558 builtin_decl_explicit (BUILT_IN_FREE), 1,
1559 fold_convert (pvoid_type_node, pointer));
1560 gfc_add_expr_to_block (&non_null, tmp);
1561
1562 if (status != NULL_TREE && !integer_zerop (status))
1563 {
1564 /* We set STATUS to zero if it is present. */
1565 tree status_type = TREE_TYPE (TREE_TYPE (status));
1566 tree cond2;
1567
1568 cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
1569 status,
1570 build_int_cst (TREE_TYPE (status), 0));
1571 tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
1572 fold_build1_loc (input_location, INDIRECT_REF,
1573 status_type, status),
1574 build_int_cst (status_type, 0));
1575 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1576 cond2, tmp, build_empty_stmt (input_location));
1577 gfc_add_expr_to_block (&non_null, tmp);
1578 }
1579 }
1580 else
1581 {
1582 tree token;
1583 tree pstat = null_pointer_node;
1584 gfc_se se;
1585
1586 gfc_init_se (&se, NULL);
1587 token = gfc_get_ultimate_alloc_ptr_comps_caf_token (&se, expr);
1588 gcc_assert (token != NULL_TREE);
1589
1590 if (status != NULL_TREE && !integer_zerop (status))
1591 {
1592 gcc_assert (TREE_TYPE (TREE_TYPE (status)) == integer_type_node);
1593 pstat = status;
1594 }
1595
1596 tmp = build_call_expr_loc (input_location,
1597 gfor_fndecl_caf_deregister, 5,
1598 token, build_int_cst (integer_type_node,
1599 caf_dereg_type),
1600 pstat, null_pointer_node, integer_zero_node);
1601 gfc_add_expr_to_block (&non_null, tmp);
1602
1603 /* It guarantees memory consistency within the same segment. */
1604 tmp = gfc_build_string_const (strlen ("memory")+1, "memory");
1605 tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
1606 gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
1607 tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
1608 ASM_VOLATILE_P (tmp) = 1;
1609 gfc_add_expr_to_block (&non_null, tmp);
1610
1611 if (status != NULL_TREE)
1612 {
1613 tree stat = build_fold_indirect_ref_loc (input_location, status);
1614 tree cond2;
1615
1616 TREE_USED (label_finish) = 1;
1617 tmp = build1_v (GOTO_EXPR, label_finish);
1618 cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
1619 stat, build_zero_cst (TREE_TYPE (stat)));
1620 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1621 gfc_unlikely (cond2, PRED_FORTRAN_REALLOC),
1622 tmp, build_empty_stmt (input_location));
1623 gfc_add_expr_to_block (&non_null, tmp);
1624 }
1625 }
1626
1627 return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
1628 gfc_finish_block (&null),
1629 gfc_finish_block (&non_null));
1630 }
1631
1632 /* Reallocate MEM so it has SIZE bytes of data. This behaves like the
1633 following pseudo-code:
1634
1635 void *
1636 internal_realloc (void *mem, size_t size)
1637 {
1638 res = realloc (mem, size);
1639 if (!res && size != 0)
1640 _gfortran_os_error ("Allocation would exceed memory limit");
1641
1642 return res;
1643 } */
1644 tree
1645 gfc_call_realloc (stmtblock_t * block, tree mem, tree size)
1646 {
1647 tree msg, res, nonzero, null_result, tmp;
1648 tree type = TREE_TYPE (mem);
1649
1650 /* Only evaluate the size once. */
1651 size = save_expr (fold_convert (size_type_node, size));
1652
1653 /* Create a variable to hold the result. */
1654 res = gfc_create_var (type, NULL);
1655
1656 /* Call realloc and check the result. */
1657 tmp = build_call_expr_loc (input_location,
1658 builtin_decl_explicit (BUILT_IN_REALLOC), 2,
1659 fold_convert (pvoid_type_node, mem), size);
1660 gfc_add_modify (block, res, fold_convert (type, tmp));
1661 null_result = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
1662 res, build_int_cst (pvoid_type_node, 0));
1663 nonzero = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, size,
1664 build_int_cst (size_type_node, 0));
1665 null_result = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
1666 null_result, nonzero);
1667 msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
1668 ("Allocation would exceed memory limit"));
1669 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1670 null_result,
1671 build_call_expr_loc (input_location,
1672 gfor_fndecl_os_error, 1, msg),
1673 build_empty_stmt (input_location));
1674 gfc_add_expr_to_block (block, tmp);
1675
1676 return res;
1677 }
1678
1679
1680 /* Add an expression to another one, either at the front or the back. */
1681
1682 static void
1683 add_expr_to_chain (tree* chain, tree expr, bool front)
1684 {
1685 if (expr == NULL_TREE || IS_EMPTY_STMT (expr))
1686 return;
1687
1688 if (*chain)
1689 {
1690 if (TREE_CODE (*chain) != STATEMENT_LIST)
1691 {
1692 tree tmp;
1693
1694 tmp = *chain;
1695 *chain = NULL_TREE;
1696 append_to_statement_list (tmp, chain);
1697 }
1698
1699 if (front)
1700 {
1701 tree_stmt_iterator i;
1702
1703 i = tsi_start (*chain);
1704 tsi_link_before (&i, expr, TSI_CONTINUE_LINKING);
1705 }
1706 else
1707 append_to_statement_list (expr, chain);
1708 }
1709 else
1710 *chain = expr;
1711 }
1712
1713
1714 /* Add a statement at the end of a block. */
1715
1716 void
1717 gfc_add_expr_to_block (stmtblock_t * block, tree expr)
1718 {
1719 gcc_assert (block);
1720 add_expr_to_chain (&block->head, expr, false);
1721 }
1722
1723
1724 /* Add a statement at the beginning of a block. */
1725
1726 void
1727 gfc_prepend_expr_to_block (stmtblock_t * block, tree expr)
1728 {
1729 gcc_assert (block);
1730 add_expr_to_chain (&block->head, expr, true);
1731 }
1732
1733
1734 /* Add a block the end of a block. */
1735
1736 void
1737 gfc_add_block_to_block (stmtblock_t * block, stmtblock_t * append)
1738 {
1739 gcc_assert (append);
1740 gcc_assert (!append->has_scope);
1741
1742 gfc_add_expr_to_block (block, append->head);
1743 append->head = NULL_TREE;
1744 }
1745
1746
1747 /* Save the current locus. The structure may not be complete, and should
1748 only be used with gfc_restore_backend_locus. */
1749
1750 void
1751 gfc_save_backend_locus (locus * loc)
1752 {
1753 loc->lb = XCNEW (gfc_linebuf);
1754 loc->lb->location = input_location;
1755 loc->lb->file = gfc_current_backend_file;
1756 }
1757
1758
1759 /* Set the current locus. */
1760
1761 void
1762 gfc_set_backend_locus (locus * loc)
1763 {
1764 gfc_current_backend_file = loc->lb->file;
1765 input_location = loc->lb->location;
1766 }
1767
1768
1769 /* Restore the saved locus. Only used in conjunction with
1770 gfc_save_backend_locus, to free the memory when we are done. */
1771
1772 void
1773 gfc_restore_backend_locus (locus * loc)
1774 {
1775 gfc_set_backend_locus (loc);
1776 free (loc->lb);
1777 }
1778
1779
1780 /* Translate an executable statement. The tree cond is used by gfc_trans_do.
1781 This static function is wrapped by gfc_trans_code_cond and
1782 gfc_trans_code. */
1783
1784 static tree
1785 trans_code (gfc_code * code, tree cond)
1786 {
1787 stmtblock_t block;
1788 tree res;
1789
1790 if (!code)
1791 return build_empty_stmt (input_location);
1792
1793 gfc_start_block (&block);
1794
1795 /* Translate statements one by one into GENERIC trees until we reach
1796 the end of this gfc_code branch. */
1797 for (; code; code = code->next)
1798 {
1799 if (code->here != 0)
1800 {
1801 res = gfc_trans_label_here (code);
1802 gfc_add_expr_to_block (&block, res);
1803 }
1804
1805 gfc_current_locus = code->loc;
1806 gfc_set_backend_locus (&code->loc);
1807
1808 switch (code->op)
1809 {
1810 case EXEC_NOP:
1811 case EXEC_END_BLOCK:
1812 case EXEC_END_NESTED_BLOCK:
1813 case EXEC_END_PROCEDURE:
1814 res = NULL_TREE;
1815 break;
1816
1817 case EXEC_ASSIGN:
1818 res = gfc_trans_assign (code);
1819 break;
1820
1821 case EXEC_LABEL_ASSIGN:
1822 res = gfc_trans_label_assign (code);
1823 break;
1824
1825 case EXEC_POINTER_ASSIGN:
1826 res = gfc_trans_pointer_assign (code);
1827 break;
1828
1829 case EXEC_INIT_ASSIGN:
1830 if (code->expr1->ts.type == BT_CLASS)
1831 res = gfc_trans_class_init_assign (code);
1832 else
1833 res = gfc_trans_init_assign (code);
1834 break;
1835
1836 case EXEC_CONTINUE:
1837 res = NULL_TREE;
1838 break;
1839
1840 case EXEC_CRITICAL:
1841 res = gfc_trans_critical (code);
1842 break;
1843
1844 case EXEC_CYCLE:
1845 res = gfc_trans_cycle (code);
1846 break;
1847
1848 case EXEC_EXIT:
1849 res = gfc_trans_exit (code);
1850 break;
1851
1852 case EXEC_GOTO:
1853 res = gfc_trans_goto (code);
1854 break;
1855
1856 case EXEC_ENTRY:
1857 res = gfc_trans_entry (code);
1858 break;
1859
1860 case EXEC_PAUSE:
1861 res = gfc_trans_pause (code);
1862 break;
1863
1864 case EXEC_STOP:
1865 case EXEC_ERROR_STOP:
1866 res = gfc_trans_stop (code, code->op == EXEC_ERROR_STOP);
1867 break;
1868
1869 case EXEC_CALL:
1870 /* For MVBITS we've got the special exception that we need a
1871 dependency check, too. */
1872 {
1873 bool is_mvbits = false;
1874
1875 if (code->resolved_isym)
1876 {
1877 res = gfc_conv_intrinsic_subroutine (code);
1878 if (res != NULL_TREE)
1879 break;
1880 }
1881
1882 if (code->resolved_isym
1883 && code->resolved_isym->id == GFC_ISYM_MVBITS)
1884 is_mvbits = true;
1885
1886 res = gfc_trans_call (code, is_mvbits, NULL_TREE,
1887 NULL_TREE, false);
1888 }
1889 break;
1890
1891 case EXEC_CALL_PPC:
1892 res = gfc_trans_call (code, false, NULL_TREE,
1893 NULL_TREE, false);
1894 break;
1895
1896 case EXEC_ASSIGN_CALL:
1897 res = gfc_trans_call (code, true, NULL_TREE,
1898 NULL_TREE, false);
1899 break;
1900
1901 case EXEC_RETURN:
1902 res = gfc_trans_return (code);
1903 break;
1904
1905 case EXEC_IF:
1906 res = gfc_trans_if (code);
1907 break;
1908
1909 case EXEC_ARITHMETIC_IF:
1910 res = gfc_trans_arithmetic_if (code);
1911 break;
1912
1913 case EXEC_BLOCK:
1914 res = gfc_trans_block_construct (code);
1915 break;
1916
1917 case EXEC_DO:
1918 res = gfc_trans_do (code, cond);
1919 break;
1920
1921 case EXEC_DO_CONCURRENT:
1922 res = gfc_trans_do_concurrent (code);
1923 break;
1924
1925 case EXEC_DO_WHILE:
1926 res = gfc_trans_do_while (code);
1927 break;
1928
1929 case EXEC_SELECT:
1930 res = gfc_trans_select (code);
1931 break;
1932
1933 case EXEC_SELECT_TYPE:
1934 res = gfc_trans_select_type (code);
1935 break;
1936
1937 case EXEC_FLUSH:
1938 res = gfc_trans_flush (code);
1939 break;
1940
1941 case EXEC_SYNC_ALL:
1942 case EXEC_SYNC_IMAGES:
1943 case EXEC_SYNC_MEMORY:
1944 res = gfc_trans_sync (code, code->op);
1945 break;
1946
1947 case EXEC_LOCK:
1948 case EXEC_UNLOCK:
1949 res = gfc_trans_lock_unlock (code, code->op);
1950 break;
1951
1952 case EXEC_EVENT_POST:
1953 case EXEC_EVENT_WAIT:
1954 res = gfc_trans_event_post_wait (code, code->op);
1955 break;
1956
1957 case EXEC_FORALL:
1958 res = gfc_trans_forall (code);
1959 break;
1960
1961 case EXEC_WHERE:
1962 res = gfc_trans_where (code);
1963 break;
1964
1965 case EXEC_ALLOCATE:
1966 res = gfc_trans_allocate (code);
1967 break;
1968
1969 case EXEC_DEALLOCATE:
1970 res = gfc_trans_deallocate (code);
1971 break;
1972
1973 case EXEC_OPEN:
1974 res = gfc_trans_open (code);
1975 break;
1976
1977 case EXEC_CLOSE:
1978 res = gfc_trans_close (code);
1979 break;
1980
1981 case EXEC_READ:
1982 res = gfc_trans_read (code);
1983 break;
1984
1985 case EXEC_WRITE:
1986 res = gfc_trans_write (code);
1987 break;
1988
1989 case EXEC_IOLENGTH:
1990 res = gfc_trans_iolength (code);
1991 break;
1992
1993 case EXEC_BACKSPACE:
1994 res = gfc_trans_backspace (code);
1995 break;
1996
1997 case EXEC_ENDFILE:
1998 res = gfc_trans_endfile (code);
1999 break;
2000
2001 case EXEC_INQUIRE:
2002 res = gfc_trans_inquire (code);
2003 break;
2004
2005 case EXEC_WAIT:
2006 res = gfc_trans_wait (code);
2007 break;
2008
2009 case EXEC_REWIND:
2010 res = gfc_trans_rewind (code);
2011 break;
2012
2013 case EXEC_TRANSFER:
2014 res = gfc_trans_transfer (code);
2015 break;
2016
2017 case EXEC_DT_END:
2018 res = gfc_trans_dt_end (code);
2019 break;
2020
2021 case EXEC_OMP_ATOMIC:
2022 case EXEC_OMP_BARRIER:
2023 case EXEC_OMP_CANCEL:
2024 case EXEC_OMP_CANCELLATION_POINT:
2025 case EXEC_OMP_CRITICAL:
2026 case EXEC_OMP_DISTRIBUTE:
2027 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
2028 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
2029 case EXEC_OMP_DISTRIBUTE_SIMD:
2030 case EXEC_OMP_DO:
2031 case EXEC_OMP_DO_SIMD:
2032 case EXEC_OMP_FLUSH:
2033 case EXEC_OMP_MASTER:
2034 case EXEC_OMP_ORDERED:
2035 case EXEC_OMP_PARALLEL:
2036 case EXEC_OMP_PARALLEL_DO:
2037 case EXEC_OMP_PARALLEL_DO_SIMD:
2038 case EXEC_OMP_PARALLEL_SECTIONS:
2039 case EXEC_OMP_PARALLEL_WORKSHARE:
2040 case EXEC_OMP_SECTIONS:
2041 case EXEC_OMP_SIMD:
2042 case EXEC_OMP_SINGLE:
2043 case EXEC_OMP_TARGET:
2044 case EXEC_OMP_TARGET_DATA:
2045 case EXEC_OMP_TARGET_ENTER_DATA:
2046 case EXEC_OMP_TARGET_EXIT_DATA:
2047 case EXEC_OMP_TARGET_PARALLEL:
2048 case EXEC_OMP_TARGET_PARALLEL_DO:
2049 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
2050 case EXEC_OMP_TARGET_SIMD:
2051 case EXEC_OMP_TARGET_TEAMS:
2052 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
2053 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
2054 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
2055 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
2056 case EXEC_OMP_TARGET_UPDATE:
2057 case EXEC_OMP_TASK:
2058 case EXEC_OMP_TASKGROUP:
2059 case EXEC_OMP_TASKLOOP:
2060 case EXEC_OMP_TASKLOOP_SIMD:
2061 case EXEC_OMP_TASKWAIT:
2062 case EXEC_OMP_TASKYIELD:
2063 case EXEC_OMP_TEAMS:
2064 case EXEC_OMP_TEAMS_DISTRIBUTE:
2065 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
2066 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
2067 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
2068 case EXEC_OMP_WORKSHARE:
2069 res = gfc_trans_omp_directive (code);
2070 break;
2071
2072 case EXEC_OACC_CACHE:
2073 case EXEC_OACC_WAIT:
2074 case EXEC_OACC_UPDATE:
2075 case EXEC_OACC_LOOP:
2076 case EXEC_OACC_HOST_DATA:
2077 case EXEC_OACC_DATA:
2078 case EXEC_OACC_KERNELS:
2079 case EXEC_OACC_KERNELS_LOOP:
2080 case EXEC_OACC_PARALLEL:
2081 case EXEC_OACC_PARALLEL_LOOP:
2082 case EXEC_OACC_ENTER_DATA:
2083 case EXEC_OACC_EXIT_DATA:
2084 case EXEC_OACC_ATOMIC:
2085 case EXEC_OACC_DECLARE:
2086 res = gfc_trans_oacc_directive (code);
2087 break;
2088
2089 default:
2090 gfc_internal_error ("gfc_trans_code(): Bad statement code");
2091 }
2092
2093 gfc_set_backend_locus (&code->loc);
2094
2095 if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
2096 {
2097 if (TREE_CODE (res) != STATEMENT_LIST)
2098 SET_EXPR_LOCATION (res, input_location);
2099
2100 /* Add the new statement to the block. */
2101 gfc_add_expr_to_block (&block, res);
2102 }
2103 }
2104
2105 /* Return the finished block. */
2106 return gfc_finish_block (&block);
2107 }
2108
2109
2110 /* Translate an executable statement with condition, cond. The condition is
2111 used by gfc_trans_do to test for IO result conditions inside implied
2112 DO loops of READ and WRITE statements. See build_dt in trans-io.c. */
2113
2114 tree
2115 gfc_trans_code_cond (gfc_code * code, tree cond)
2116 {
2117 return trans_code (code, cond);
2118 }
2119
2120 /* Translate an executable statement without condition. */
2121
2122 tree
2123 gfc_trans_code (gfc_code * code)
2124 {
2125 return trans_code (code, NULL_TREE);
2126 }
2127
2128
2129 /* This function is called after a complete program unit has been parsed
2130 and resolved. */
2131
2132 void
2133 gfc_generate_code (gfc_namespace * ns)
2134 {
2135 ompws_flags = 0;
2136 if (ns->is_block_data)
2137 {
2138 gfc_generate_block_data (ns);
2139 return;
2140 }
2141
2142 gfc_generate_function_code (ns);
2143 }
2144
2145
2146 /* This function is called after a complete module has been parsed
2147 and resolved. */
2148
2149 void
2150 gfc_generate_module_code (gfc_namespace * ns)
2151 {
2152 gfc_namespace *n;
2153 struct module_htab_entry *entry;
2154
2155 gcc_assert (ns->proc_name->backend_decl == NULL);
2156 ns->proc_name->backend_decl
2157 = build_decl (ns->proc_name->declared_at.lb->location,
2158 NAMESPACE_DECL, get_identifier (ns->proc_name->name),
2159 void_type_node);
2160 entry = gfc_find_module (ns->proc_name->name);
2161 if (entry->namespace_decl)
2162 /* Buggy sourcecode, using a module before defining it? */
2163 entry->decls->empty ();
2164 entry->namespace_decl = ns->proc_name->backend_decl;
2165
2166 gfc_generate_module_vars (ns);
2167
2168 /* We need to generate all module function prototypes first, to allow
2169 sibling calls. */
2170 for (n = ns->contained; n; n = n->sibling)
2171 {
2172 gfc_entry_list *el;
2173
2174 if (!n->proc_name)
2175 continue;
2176
2177 gfc_create_function_decl (n, false);
2178 DECL_CONTEXT (n->proc_name->backend_decl) = ns->proc_name->backend_decl;
2179 gfc_module_add_decl (entry, n->proc_name->backend_decl);
2180 for (el = ns->entries; el; el = el->next)
2181 {
2182 DECL_CONTEXT (el->sym->backend_decl) = ns->proc_name->backend_decl;
2183 gfc_module_add_decl (entry, el->sym->backend_decl);
2184 }
2185 }
2186
2187 for (n = ns->contained; n; n = n->sibling)
2188 {
2189 if (!n->proc_name)
2190 continue;
2191
2192 gfc_generate_function_code (n);
2193 }
2194 }
2195
2196
2197 /* Initialize an init/cleanup block with existing code. */
2198
2199 void
2200 gfc_start_wrapped_block (gfc_wrapped_block* block, tree code)
2201 {
2202 gcc_assert (block);
2203
2204 block->init = NULL_TREE;
2205 block->code = code;
2206 block->cleanup = NULL_TREE;
2207 }
2208
2209
2210 /* Add a new pair of initializers/clean-up code. */
2211
2212 void
2213 gfc_add_init_cleanup (gfc_wrapped_block* block, tree init, tree cleanup)
2214 {
2215 gcc_assert (block);
2216
2217 /* The new pair of init/cleanup should be "wrapped around" the existing
2218 block of code, thus the initialization is added to the front and the
2219 cleanup to the back. */
2220 add_expr_to_chain (&block->init, init, true);
2221 add_expr_to_chain (&block->cleanup, cleanup, false);
2222 }
2223
2224
2225 /* Finish up a wrapped block by building a corresponding try-finally expr. */
2226
2227 tree
2228 gfc_finish_wrapped_block (gfc_wrapped_block* block)
2229 {
2230 tree result;
2231
2232 gcc_assert (block);
2233
2234 /* Build the final expression. For this, just add init and body together,
2235 and put clean-up with that into a TRY_FINALLY_EXPR. */
2236 result = block->init;
2237 add_expr_to_chain (&result, block->code, false);
2238 if (block->cleanup)
2239 result = build2_loc (input_location, TRY_FINALLY_EXPR, void_type_node,
2240 result, block->cleanup);
2241
2242 /* Clear the block. */
2243 block->init = NULL_TREE;
2244 block->code = NULL_TREE;
2245 block->cleanup = NULL_TREE;
2246
2247 return result;
2248 }
2249
2250
2251 /* Helper function for marking a boolean expression tree as unlikely. */
2252
2253 tree
2254 gfc_unlikely (tree cond, enum br_predictor predictor)
2255 {
2256 tree tmp;
2257
2258 if (optimize)
2259 {
2260 cond = fold_convert (long_integer_type_node, cond);
2261 tmp = build_zero_cst (long_integer_type_node);
2262 cond = build_call_expr_loc (input_location,
2263 builtin_decl_explicit (BUILT_IN_EXPECT),
2264 3, cond, tmp,
2265 build_int_cst (integer_type_node,
2266 predictor));
2267 }
2268 cond = fold_convert (boolean_type_node, cond);
2269 return cond;
2270 }
2271
2272
2273 /* Helper function for marking a boolean expression tree as likely. */
2274
2275 tree
2276 gfc_likely (tree cond, enum br_predictor predictor)
2277 {
2278 tree tmp;
2279
2280 if (optimize)
2281 {
2282 cond = fold_convert (long_integer_type_node, cond);
2283 tmp = build_one_cst (long_integer_type_node);
2284 cond = build_call_expr_loc (input_location,
2285 builtin_decl_explicit (BUILT_IN_EXPECT),
2286 3, cond, tmp,
2287 build_int_cst (integer_type_node,
2288 predictor));
2289 }
2290 cond = fold_convert (boolean_type_node, cond);
2291 return cond;
2292 }
2293
2294
2295 /* Get the string length for a deferred character length component. */
2296
2297 bool
2298 gfc_deferred_strlen (gfc_component *c, tree *decl)
2299 {
2300 char name[GFC_MAX_SYMBOL_LEN+9];
2301 gfc_component *strlen;
2302 if (!(c->ts.type == BT_CHARACTER && c->ts.deferred))
2303 return false;
2304 sprintf (name, "_%s_length", c->name);
2305 for (strlen = c; strlen; strlen = strlen->next)
2306 if (strcmp (strlen->name, name) == 0)
2307 break;
2308 *decl = strlen ? strlen->backend_decl : NULL_TREE;
2309 return strlen != NULL;
2310 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org