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