2018-05-27 Steven G. Kargl <kargl@gcc.gnu.org>
[official-gcc.git] / gcc / fortran / trans.c
blobaa10fbb405a12319512f3f3070dd3a6ffb7de7a8
1 /* Code translation -- generate GCC trees from gfc_code.
2 Copyright (C) 2002-2018 Free Software Foundation, Inc.
3 Contributed by Paul Brook
5 This file is part of GCC.
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.
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.
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/>. */
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"
37 /* Naming convention for backend interface code:
39 gfc_trans_* translate gfc_code into STMT trees.
41 gfc_conv_* expression conversion
43 gfc_get_* get a backend tree representation of a decl or type */
45 static gfc_file *gfc_current_backend_file;
47 const char gfc_msg_fault[] = N_("Array reference out of bounds");
48 const char gfc_msg_wrong_return[] = N_("Incorrect function return value");
51 /* Advance along TREE_CHAIN n times. */
53 tree
54 gfc_advance_chain (tree t, int n)
56 for (; n > 0; n--)
58 gcc_assert (t != NULL_TREE);
59 t = DECL_CHAIN (t);
61 return t;
65 /* Strip off a legitimate source ending from the input
66 string NAME of length LEN. */
68 static inline void
69 remove_suffix (char *name, int len)
71 int i;
73 for (i = 2; i < 8 && len > i; i++)
75 if (name[len - i] == '.')
77 name[len - i] = '\0';
78 break;
84 /* Creates a variable declaration with a given TYPE. */
86 tree
87 gfc_create_var_np (tree type, const char *prefix)
89 tree t;
91 t = create_tmp_var_raw (type, prefix);
93 /* No warnings for anonymous variables. */
94 if (prefix == NULL)
95 TREE_NO_WARNING (t) = 1;
97 return t;
101 /* Like above, but also adds it to the current scope. */
103 tree
104 gfc_create_var (tree type, const char *prefix)
106 tree tmp;
108 tmp = gfc_create_var_np (type, prefix);
110 pushdecl (tmp);
112 return tmp;
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. */
120 tree
121 gfc_evaluate_now_loc (location_t loc, tree expr, stmtblock_t * pblock)
123 tree var;
125 if (CONSTANT_CLASS_P (expr))
126 return expr;
128 var = gfc_create_var (TREE_TYPE (expr), NULL);
129 gfc_add_modify_loc (loc, pblock, var, expr);
131 return var;
135 tree
136 gfc_evaluate_now (tree expr, stmtblock_t * pblock)
138 return gfc_evaluate_now_loc (input_location, expr, pblock);
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. */
146 void
147 gfc_add_modify_loc (location_t loc, stmtblock_t * pblock, tree lhs, tree rhs)
149 tree tmp;
151 tree t1, t2;
152 t1 = TREE_TYPE (rhs);
153 t2 = TREE_TYPE (lhs);
154 /* Make sure that the types of the rhs and the lhs are compatible
155 for scalar assignments. We should probably have something
156 similar for aggregates, but right now removing that check just
157 breaks everything. */
158 gcc_checking_assert (TYPE_MAIN_VARIANT (t1) == TYPE_MAIN_VARIANT (t2)
159 || AGGREGATE_TYPE_P (TREE_TYPE (lhs)));
161 tmp = fold_build2_loc (loc, MODIFY_EXPR, void_type_node, lhs,
162 rhs);
163 gfc_add_expr_to_block (pblock, tmp);
167 void
168 gfc_add_modify (stmtblock_t * pblock, tree lhs, tree rhs)
170 gfc_add_modify_loc (input_location, pblock, lhs, rhs);
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. */
178 void
179 gfc_start_block (stmtblock_t * block)
181 /* Start a new binding level. */
182 pushlevel ();
183 block->has_scope = 1;
185 /* The block is empty. */
186 block->head = NULL_TREE;
190 /* Initialize a block without creating a new scope. */
192 void
193 gfc_init_block (stmtblock_t * block)
195 block->head = NULL_TREE;
196 block->has_scope = 0;
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. */
204 void
205 gfc_merge_block_scope (stmtblock_t * block)
207 tree decl;
208 tree next;
210 gcc_assert (block->has_scope);
211 block->has_scope = 0;
213 /* Remember the decls in this scope. */
214 decl = getdecls ();
215 poplevel (0, 0);
217 /* Add them to the parent scope. */
218 while (decl != NULL_TREE)
220 next = DECL_CHAIN (decl);
221 DECL_CHAIN (decl) = NULL_TREE;
223 pushdecl (decl);
224 decl = next;
229 /* Finish a scope containing a block of statements. */
231 tree
232 gfc_finish_block (stmtblock_t * stmtblock)
234 tree decl;
235 tree expr;
236 tree block;
238 expr = stmtblock->head;
239 if (!expr)
240 expr = build_empty_stmt (input_location);
242 stmtblock->head = NULL_TREE;
244 if (stmtblock->has_scope)
246 decl = getdecls ();
248 if (decl)
250 block = poplevel (1, 0);
251 expr = build3_v (BIND_EXPR, decl, expr, block);
253 else
254 poplevel (0, 0);
257 return expr;
261 /* Build an ADDR_EXPR and cast the result to TYPE. If TYPE is NULL, the
262 natural type is used. */
264 tree
265 gfc_build_addr_expr (tree type, tree t)
267 tree base_type = TREE_TYPE (t);
268 tree natural_type;
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)))
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;
283 else
284 natural_type = build_pointer_type (base_type);
286 if (TREE_CODE (t) == INDIRECT_REF)
288 if (!type)
289 type = natural_type;
290 t = TREE_OPERAND (t, 0);
291 natural_type = TREE_TYPE (t);
293 else
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);
301 if (type && natural_type != type)
302 t = convert (type, t);
304 return t;
308 static tree
309 get_array_span (tree type, tree decl)
311 tree span;
313 /* Return the span for deferred character length array references. */
314 if (type && TREE_CODE (type) == ARRAY_TYPE
315 && TYPE_MAX_VALUE (TYPE_DOMAIN (type)) != NULL_TREE
316 && (VAR_P (TYPE_MAX_VALUE (TYPE_DOMAIN (type)))
317 || TREE_CODE (TYPE_MAX_VALUE (TYPE_DOMAIN (type))) == INDIRECT_REF)
318 && (TREE_CODE (TYPE_MAX_VALUE (TYPE_DOMAIN (type))) == INDIRECT_REF
319 || TREE_CODE (decl) == FUNCTION_DECL
320 || DECL_CONTEXT (TYPE_MAX_VALUE (TYPE_DOMAIN (type)))
321 == DECL_CONTEXT (decl)))
323 span = fold_convert (gfc_array_index_type,
324 TYPE_MAX_VALUE (TYPE_DOMAIN (type)));
325 span = fold_build2 (MULT_EXPR, gfc_array_index_type,
326 fold_convert (gfc_array_index_type,
327 TYPE_SIZE_UNIT (TREE_TYPE (type))),
328 span);
330 /* Likewise for class array or pointer array references. */
331 else if (TREE_CODE (decl) == FIELD_DECL
332 || VAR_OR_FUNCTION_DECL_P (decl)
333 || TREE_CODE (decl) == PARM_DECL)
335 if (GFC_DECL_CLASS (decl))
337 /* When a temporary is in place for the class array, then the
338 original class' declaration is stored in the saved
339 descriptor. */
340 if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl))
341 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
342 else
344 /* Allow for dummy arguments and other good things. */
345 if (POINTER_TYPE_P (TREE_TYPE (decl)))
346 decl = build_fold_indirect_ref_loc (input_location, decl);
348 /* Check if '_data' is an array descriptor. If it is not,
349 the array must be one of the components of the class
350 object, so return a null span. */
351 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (
352 gfc_class_data_get (decl))))
353 return NULL_TREE;
355 span = gfc_class_vtab_size_get (decl);
357 else if (GFC_DECL_PTR_ARRAY_P (decl))
359 if (TREE_CODE (decl) == PARM_DECL)
360 decl = build_fold_indirect_ref_loc (input_location, decl);
361 span = gfc_conv_descriptor_span_get (decl);
363 else
364 span = NULL_TREE;
366 else
367 span = NULL_TREE;
369 return span;
373 /* Build an ARRAY_REF with its natural type. */
375 tree
376 gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr)
378 tree type = TREE_TYPE (base);
379 tree tmp;
380 tree span = NULL_TREE;
382 if (GFC_ARRAY_TYPE_P (type) && GFC_TYPE_ARRAY_RANK (type) == 0)
384 gcc_assert (GFC_TYPE_ARRAY_CORANK (type) > 0);
386 return fold_convert (TYPE_MAIN_VARIANT (type), base);
389 /* Scalar coarray, there is nothing to do. */
390 if (TREE_CODE (type) != ARRAY_TYPE)
392 gcc_assert (decl == NULL_TREE);
393 gcc_assert (integer_zerop (offset));
394 return base;
397 type = TREE_TYPE (type);
399 if (DECL_P (base))
400 TREE_ADDRESSABLE (base) = 1;
402 /* Strip NON_LVALUE_EXPR nodes. */
403 STRIP_TYPE_NOPS (offset);
405 /* If decl or vptr are non-null, pointer arithmetic for the array reference
406 is likely. Generate the 'span' for the array reference. */
407 if (vptr)
408 span = gfc_vptr_size_get (vptr);
409 else if (decl)
410 span = get_array_span (type, decl);
412 /* If a non-null span has been generated reference the element with
413 pointer arithmetic. */
414 if (span != NULL_TREE)
416 offset = fold_build2_loc (input_location, MULT_EXPR,
417 gfc_array_index_type,
418 offset, span);
419 tmp = gfc_build_addr_expr (pvoid_type_node, base);
420 tmp = fold_build_pointer_plus_loc (input_location, tmp, offset);
421 tmp = fold_convert (build_pointer_type (type), tmp);
422 if (!TYPE_STRING_FLAG (type))
423 tmp = build_fold_indirect_ref_loc (input_location, tmp);
424 return tmp;
426 /* Otherwise use a straightforward array reference. */
427 else
428 return build4_loc (input_location, ARRAY_REF, type, base, offset,
429 NULL_TREE, NULL_TREE);
433 /* Generate a call to print a runtime error possibly including multiple
434 arguments and a locus. */
436 static tree
437 trans_runtime_error_vararg (bool error, locus* where, const char* msgid,
438 va_list ap)
440 stmtblock_t block;
441 tree tmp;
442 tree arg, arg2;
443 tree *argarray;
444 tree fntype;
445 char *message;
446 const char *p;
447 int line, nargs, i;
448 location_t loc;
450 /* Compute the number of extra arguments from the format string. */
451 for (p = msgid, nargs = 0; *p; p++)
452 if (*p == '%')
454 p++;
455 if (*p != '%')
456 nargs++;
459 /* The code to generate the error. */
460 gfc_start_block (&block);
462 if (where)
464 line = LOCATION_LINE (where->lb->location);
465 message = xasprintf ("At line %d of file %s", line,
466 where->lb->file->filename);
468 else
469 message = xasprintf ("In file '%s', around line %d",
470 gfc_source_file, LOCATION_LINE (input_location) + 1);
472 arg = gfc_build_addr_expr (pchar_type_node,
473 gfc_build_localized_cstring_const (message));
474 free (message);
476 message = xasprintf ("%s", _(msgid));
477 arg2 = gfc_build_addr_expr (pchar_type_node,
478 gfc_build_localized_cstring_const (message));
479 free (message);
481 /* Build the argument array. */
482 argarray = XALLOCAVEC (tree, nargs + 2);
483 argarray[0] = arg;
484 argarray[1] = arg2;
485 for (i = 0; i < nargs; i++)
486 argarray[2 + i] = va_arg (ap, tree);
488 /* Build the function call to runtime_(warning,error)_at; because of the
489 variable number of arguments, we can't use build_call_expr_loc dinput_location,
490 irectly. */
491 if (error)
492 fntype = TREE_TYPE (gfor_fndecl_runtime_error_at);
493 else
494 fntype = TREE_TYPE (gfor_fndecl_runtime_warning_at);
496 loc = where ? where->lb->location : input_location;
497 tmp = fold_build_call_array_loc (loc, TREE_TYPE (fntype),
498 fold_build1_loc (loc, ADDR_EXPR,
499 build_pointer_type (fntype),
500 error
501 ? gfor_fndecl_runtime_error_at
502 : gfor_fndecl_runtime_warning_at),
503 nargs + 2, argarray);
504 gfc_add_expr_to_block (&block, tmp);
506 return gfc_finish_block (&block);
510 tree
511 gfc_trans_runtime_error (bool error, locus* where, const char* msgid, ...)
513 va_list ap;
514 tree result;
516 va_start (ap, msgid);
517 result = trans_runtime_error_vararg (error, where, msgid, ap);
518 va_end (ap);
519 return result;
523 /* Generate a runtime error if COND is true. */
525 void
526 gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock,
527 locus * where, const char * msgid, ...)
529 va_list ap;
530 stmtblock_t block;
531 tree body;
532 tree tmp;
533 tree tmpvar = NULL;
535 if (integer_zerop (cond))
536 return;
538 if (once)
540 tmpvar = gfc_create_var (logical_type_node, "print_warning");
541 TREE_STATIC (tmpvar) = 1;
542 DECL_INITIAL (tmpvar) = logical_true_node;
543 gfc_add_expr_to_block (pblock, tmpvar);
546 gfc_start_block (&block);
548 /* For error, runtime_error_at already implies PRED_NORETURN. */
549 if (!error && once)
550 gfc_add_expr_to_block (&block, build_predict_expr (PRED_FORTRAN_WARN_ONCE,
551 NOT_TAKEN));
553 /* The code to generate the error. */
554 va_start (ap, msgid);
555 gfc_add_expr_to_block (&block,
556 trans_runtime_error_vararg (error, where,
557 msgid, ap));
558 va_end (ap);
560 if (once)
561 gfc_add_modify (&block, tmpvar, logical_false_node);
563 body = gfc_finish_block (&block);
565 if (integer_onep (cond))
567 gfc_add_expr_to_block (pblock, body);
569 else
571 if (once)
572 cond = fold_build2_loc (where->lb->location, TRUTH_AND_EXPR,
573 long_integer_type_node, tmpvar, cond);
574 else
575 cond = fold_convert (long_integer_type_node, cond);
577 tmp = fold_build3_loc (where->lb->location, COND_EXPR, void_type_node,
578 cond, body,
579 build_empty_stmt (where->lb->location));
580 gfc_add_expr_to_block (pblock, tmp);
585 /* Call malloc to allocate size bytes of memory, with special conditions:
586 + if size == 0, return a malloced area of size 1,
587 + if malloc returns NULL, issue a runtime error. */
588 tree
589 gfc_call_malloc (stmtblock_t * block, tree type, tree size)
591 tree tmp, msg, malloc_result, null_result, res, malloc_tree;
592 stmtblock_t block2;
594 /* Create a variable to hold the result. */
595 res = gfc_create_var (prvoid_type_node, NULL);
597 /* Call malloc. */
598 gfc_start_block (&block2);
600 size = fold_convert (size_type_node, size);
601 size = fold_build2_loc (input_location, MAX_EXPR, size_type_node, size,
602 build_int_cst (size_type_node, 1));
604 malloc_tree = builtin_decl_explicit (BUILT_IN_MALLOC);
605 gfc_add_modify (&block2, res,
606 fold_convert (prvoid_type_node,
607 build_call_expr_loc (input_location,
608 malloc_tree, 1, size)));
610 /* Optionally check whether malloc was successful. */
611 if (gfc_option.rtcheck & GFC_RTCHECK_MEM)
613 null_result = fold_build2_loc (input_location, EQ_EXPR,
614 logical_type_node, res,
615 build_int_cst (pvoid_type_node, 0));
616 msg = gfc_build_addr_expr (pchar_type_node,
617 gfc_build_localized_cstring_const ("Memory allocation failed"));
618 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
619 null_result,
620 build_call_expr_loc (input_location,
621 gfor_fndecl_os_error, 1, msg),
622 build_empty_stmt (input_location));
623 gfc_add_expr_to_block (&block2, tmp);
626 malloc_result = gfc_finish_block (&block2);
627 gfc_add_expr_to_block (block, malloc_result);
629 if (type != NULL)
630 res = fold_convert (type, res);
631 return res;
635 /* Allocate memory, using an optional status argument.
637 This function follows the following pseudo-code:
639 void *
640 allocate (size_t size, integer_type stat)
642 void *newmem;
644 if (stat requested)
645 stat = 0;
647 newmem = malloc (MAX (size, 1));
648 if (newmem == NULL)
650 if (stat)
651 *stat = LIBERROR_ALLOCATION;
652 else
653 runtime_error ("Allocation would exceed memory limit");
655 return newmem;
656 } */
657 void
658 gfc_allocate_using_malloc (stmtblock_t * block, tree pointer,
659 tree size, tree status)
661 tree tmp, error_cond;
662 stmtblock_t on_error;
663 tree status_type = status ? TREE_TYPE (status) : NULL_TREE;
665 /* If successful and stat= is given, set status to 0. */
666 if (status != NULL_TREE)
667 gfc_add_expr_to_block (block,
668 fold_build2_loc (input_location, MODIFY_EXPR, status_type,
669 status, build_int_cst (status_type, 0)));
671 /* The allocation itself. */
672 size = fold_convert (size_type_node, size);
673 gfc_add_modify (block, pointer,
674 fold_convert (TREE_TYPE (pointer),
675 build_call_expr_loc (input_location,
676 builtin_decl_explicit (BUILT_IN_MALLOC), 1,
677 fold_build2_loc (input_location,
678 MAX_EXPR, size_type_node, size,
679 build_int_cst (size_type_node, 1)))));
681 /* What to do in case of error. */
682 gfc_start_block (&on_error);
683 if (status != NULL_TREE)
685 tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, status,
686 build_int_cst (status_type, LIBERROR_ALLOCATION));
687 gfc_add_expr_to_block (&on_error, tmp);
689 else
691 /* Here, os_error already implies PRED_NORETURN. */
692 tmp = build_call_expr_loc (input_location, gfor_fndecl_os_error, 1,
693 gfc_build_addr_expr (pchar_type_node,
694 gfc_build_localized_cstring_const
695 ("Allocation would exceed memory limit")));
696 gfc_add_expr_to_block (&on_error, tmp);
699 error_cond = fold_build2_loc (input_location, EQ_EXPR,
700 logical_type_node, pointer,
701 build_int_cst (prvoid_type_node, 0));
702 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
703 gfc_unlikely (error_cond, PRED_FORTRAN_FAIL_ALLOC),
704 gfc_finish_block (&on_error),
705 build_empty_stmt (input_location));
707 gfc_add_expr_to_block (block, tmp);
711 /* Allocate memory, using an optional status argument.
713 This function follows the following pseudo-code:
715 void *
716 allocate (size_t size, void** token, int *stat, char* errmsg, int errlen)
718 void *newmem;
720 newmem = _caf_register (size, regtype, token, &stat, errmsg, errlen);
721 return newmem;
722 } */
723 void
724 gfc_allocate_using_caf_lib (stmtblock_t * block, tree pointer, tree size,
725 tree token, tree status, tree errmsg, tree errlen,
726 gfc_coarray_regtype alloc_type)
728 tree tmp, pstat;
730 gcc_assert (token != NULL_TREE);
732 /* The allocation itself. */
733 if (status == NULL_TREE)
734 pstat = null_pointer_node;
735 else
736 pstat = gfc_build_addr_expr (NULL_TREE, status);
738 if (errmsg == NULL_TREE)
740 gcc_assert(errlen == NULL_TREE);
741 errmsg = null_pointer_node;
742 errlen = build_int_cst (integer_type_node, 0);
745 size = fold_convert (size_type_node, size);
746 tmp = build_call_expr_loc (input_location,
747 gfor_fndecl_caf_register, 7,
748 fold_build2_loc (input_location,
749 MAX_EXPR, size_type_node, size, size_one_node),
750 build_int_cst (integer_type_node, alloc_type),
751 token, gfc_build_addr_expr (pvoid_type_node, pointer),
752 pstat, errmsg, errlen);
754 gfc_add_expr_to_block (block, tmp);
756 /* It guarantees memory consistency within the same segment */
757 tmp = gfc_build_string_const (strlen ("memory")+1, "memory"),
758 tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
759 gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
760 tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
761 ASM_VOLATILE_P (tmp) = 1;
762 gfc_add_expr_to_block (block, tmp);
766 /* Generate code for an ALLOCATE statement when the argument is an
767 allocatable variable. If the variable is currently allocated, it is an
768 error to allocate it again.
770 This function follows the following pseudo-code:
772 void *
773 allocate_allocatable (void *mem, size_t size, integer_type stat)
775 if (mem == NULL)
776 return allocate (size, stat);
777 else
779 if (stat)
780 stat = LIBERROR_ALLOCATION;
781 else
782 runtime_error ("Attempting to allocate already allocated variable");
786 expr must be set to the original expression being allocated for its locus
787 and variable name in case a runtime error has to be printed. */
788 void
789 gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size,
790 tree token, tree status, tree errmsg, tree errlen,
791 tree label_finish, gfc_expr* expr, int corank)
793 stmtblock_t alloc_block;
794 tree tmp, null_mem, alloc, error;
795 tree type = TREE_TYPE (mem);
796 symbol_attribute caf_attr;
797 bool need_assign = false, refs_comp = false;
798 gfc_coarray_regtype caf_alloc_type = GFC_CAF_COARRAY_ALLOC;
800 size = fold_convert (size_type_node, size);
801 null_mem = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
802 logical_type_node, mem,
803 build_int_cst (type, 0)),
804 PRED_FORTRAN_REALLOC);
806 /* If mem is NULL, we call gfc_allocate_using_malloc or
807 gfc_allocate_using_lib. */
808 gfc_start_block (&alloc_block);
810 if (flag_coarray == GFC_FCOARRAY_LIB)
811 caf_attr = gfc_caf_attr (expr, true, &refs_comp);
813 if (flag_coarray == GFC_FCOARRAY_LIB
814 && (corank > 0 || caf_attr.codimension))
816 tree cond, sub_caf_tree;
817 gfc_se se;
818 bool compute_special_caf_types_size = false;
820 if (expr->ts.type == BT_DERIVED
821 && expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
822 && expr->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
824 compute_special_caf_types_size = true;
825 caf_alloc_type = GFC_CAF_LOCK_ALLOC;
827 else if (expr->ts.type == BT_DERIVED
828 && expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
829 && expr->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
831 compute_special_caf_types_size = true;
832 caf_alloc_type = GFC_CAF_EVENT_ALLOC;
834 else if (!caf_attr.coarray_comp && refs_comp)
835 /* Only allocatable components in a derived type coarray can be
836 allocate only. */
837 caf_alloc_type = GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY;
839 gfc_init_se (&se, NULL);
840 sub_caf_tree = gfc_get_ultimate_alloc_ptr_comps_caf_token (&se, expr);
841 if (sub_caf_tree == NULL_TREE)
842 sub_caf_tree = token;
844 /* When mem is an array ref, then strip the .data-ref. */
845 if (TREE_CODE (mem) == COMPONENT_REF
846 && !(GFC_ARRAY_TYPE_P (TREE_TYPE (mem))))
847 tmp = TREE_OPERAND (mem, 0);
848 else
849 tmp = mem;
851 if (!(GFC_ARRAY_TYPE_P (TREE_TYPE (tmp))
852 && TYPE_LANG_SPECIFIC (TREE_TYPE (tmp))->corank == 0)
853 && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
855 symbol_attribute attr;
857 gfc_clear_attr (&attr);
858 tmp = gfc_conv_scalar_to_descriptor (&se, mem, attr);
859 need_assign = true;
861 gfc_add_block_to_block (&alloc_block, &se.pre);
863 /* In the front end, we represent the lock variable as pointer. However,
864 the FE only passes the pointer around and leaves the actual
865 representation to the library. Hence, we have to convert back to the
866 number of elements. */
867 if (compute_special_caf_types_size)
868 size = fold_build2_loc (input_location, TRUNC_DIV_EXPR, size_type_node,
869 size, TYPE_SIZE_UNIT (ptr_type_node));
871 gfc_allocate_using_caf_lib (&alloc_block, tmp, size, sub_caf_tree,
872 status, errmsg, errlen, caf_alloc_type);
873 if (need_assign)
874 gfc_add_modify (&alloc_block, mem, fold_convert (TREE_TYPE (mem),
875 gfc_conv_descriptor_data_get (tmp)));
876 if (status != NULL_TREE)
878 TREE_USED (label_finish) = 1;
879 tmp = build1_v (GOTO_EXPR, label_finish);
880 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
881 status, build_zero_cst (TREE_TYPE (status)));
882 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
883 gfc_unlikely (cond, PRED_FORTRAN_FAIL_ALLOC),
884 tmp, build_empty_stmt (input_location));
885 gfc_add_expr_to_block (&alloc_block, tmp);
888 else
889 gfc_allocate_using_malloc (&alloc_block, mem, size, status);
891 alloc = gfc_finish_block (&alloc_block);
893 /* If mem is not NULL, we issue a runtime error or set the
894 status variable. */
895 if (expr)
897 tree varname;
899 gcc_assert (expr->expr_type == EXPR_VARIABLE && expr->symtree);
900 varname = gfc_build_cstring_const (expr->symtree->name);
901 varname = gfc_build_addr_expr (pchar_type_node, varname);
903 error = gfc_trans_runtime_error (true, &expr->where,
904 "Attempting to allocate already"
905 " allocated variable '%s'",
906 varname);
908 else
909 error = gfc_trans_runtime_error (true, NULL,
910 "Attempting to allocate already allocated"
911 " variable");
913 if (status != NULL_TREE)
915 tree status_type = TREE_TYPE (status);
917 error = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
918 status, build_int_cst (status_type, LIBERROR_ALLOCATION));
921 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, null_mem,
922 error, alloc);
923 gfc_add_expr_to_block (block, tmp);
927 /* Free a given variable. */
929 tree
930 gfc_call_free (tree var)
932 return build_call_expr_loc (input_location,
933 builtin_decl_explicit (BUILT_IN_FREE),
934 1, fold_convert (pvoid_type_node, var));
938 /* Build a call to a FINAL procedure, which finalizes "var". */
940 static tree
941 gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var,
942 bool fini_coarray, gfc_expr *class_size)
944 stmtblock_t block;
945 gfc_se se;
946 tree final_fndecl, array, size, tmp;
947 symbol_attribute attr;
949 gcc_assert (final_wrapper->expr_type == EXPR_VARIABLE);
950 gcc_assert (var);
952 gfc_start_block (&block);
953 gfc_init_se (&se, NULL);
954 gfc_conv_expr (&se, final_wrapper);
955 final_fndecl = se.expr;
956 if (POINTER_TYPE_P (TREE_TYPE (final_fndecl)))
957 final_fndecl = build_fold_indirect_ref_loc (input_location, final_fndecl);
959 if (ts.type == BT_DERIVED)
961 tree elem_size;
963 gcc_assert (!class_size);
964 elem_size = gfc_typenode_for_spec (&ts);
965 elem_size = TYPE_SIZE_UNIT (elem_size);
966 size = fold_convert (gfc_array_index_type, elem_size);
968 gfc_init_se (&se, NULL);
969 se.want_pointer = 1;
970 if (var->rank)
972 se.descriptor_only = 1;
973 gfc_conv_expr_descriptor (&se, var);
974 array = se.expr;
976 else
978 gfc_conv_expr (&se, var);
979 gcc_assert (se.pre.head == NULL_TREE && se.post.head == NULL_TREE);
980 array = se.expr;
982 /* No copy back needed, hence set attr's allocatable/pointer
983 to zero. */
984 gfc_clear_attr (&attr);
985 gfc_init_se (&se, NULL);
986 array = gfc_conv_scalar_to_descriptor (&se, array, attr);
987 gcc_assert (se.post.head == NULL_TREE);
990 else
992 gfc_expr *array_expr;
993 gcc_assert (class_size);
994 gfc_init_se (&se, NULL);
995 gfc_conv_expr (&se, class_size);
996 gfc_add_block_to_block (&block, &se.pre);
997 gcc_assert (se.post.head == NULL_TREE);
998 size = se.expr;
1000 array_expr = gfc_copy_expr (var);
1001 gfc_init_se (&se, NULL);
1002 se.want_pointer = 1;
1003 if (array_expr->rank)
1005 gfc_add_class_array_ref (array_expr);
1006 se.descriptor_only = 1;
1007 gfc_conv_expr_descriptor (&se, array_expr);
1008 array = se.expr;
1010 else
1012 gfc_add_data_component (array_expr);
1013 gfc_conv_expr (&se, array_expr);
1014 gfc_add_block_to_block (&block, &se.pre);
1015 gcc_assert (se.post.head == NULL_TREE);
1016 array = se.expr;
1017 if (TREE_CODE (array) == ADDR_EXPR
1018 && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (array, 0))))
1019 tmp = TREE_OPERAND (array, 0);
1021 if (!gfc_is_coarray (array_expr))
1023 /* No copy back needed, hence set attr's allocatable/pointer
1024 to zero. */
1025 gfc_clear_attr (&attr);
1026 gfc_init_se (&se, NULL);
1027 array = gfc_conv_scalar_to_descriptor (&se, array, attr);
1029 gcc_assert (se.post.head == NULL_TREE);
1031 gfc_free_expr (array_expr);
1034 if (!POINTER_TYPE_P (TREE_TYPE (array)))
1035 array = gfc_build_addr_expr (NULL, array);
1037 gfc_add_block_to_block (&block, &se.pre);
1038 tmp = build_call_expr_loc (input_location,
1039 final_fndecl, 3, array,
1040 size, fini_coarray ? boolean_true_node
1041 : boolean_false_node);
1042 gfc_add_block_to_block (&block, &se.post);
1043 gfc_add_expr_to_block (&block, tmp);
1044 return gfc_finish_block (&block);
1048 bool
1049 gfc_add_comp_finalizer_call (stmtblock_t *block, tree decl, gfc_component *comp,
1050 bool fini_coarray)
1052 gfc_se se;
1053 stmtblock_t block2;
1054 tree final_fndecl, size, array, tmp, cond;
1055 symbol_attribute attr;
1056 gfc_expr *final_expr = NULL;
1058 if (comp->ts.type != BT_DERIVED && comp->ts.type != BT_CLASS)
1059 return false;
1061 gfc_init_block (&block2);
1063 if (comp->ts.type == BT_DERIVED)
1065 if (comp->attr.pointer)
1066 return false;
1068 gfc_is_finalizable (comp->ts.u.derived, &final_expr);
1069 if (!final_expr)
1070 return false;
1072 gfc_init_se (&se, NULL);
1073 gfc_conv_expr (&se, final_expr);
1074 final_fndecl = se.expr;
1075 size = gfc_typenode_for_spec (&comp->ts);
1076 size = TYPE_SIZE_UNIT (size);
1077 size = fold_convert (gfc_array_index_type, size);
1079 array = decl;
1081 else /* comp->ts.type == BT_CLASS. */
1083 if (CLASS_DATA (comp)->attr.class_pointer)
1084 return false;
1086 gfc_is_finalizable (CLASS_DATA (comp)->ts.u.derived, &final_expr);
1087 final_fndecl = gfc_class_vtab_final_get (decl);
1088 size = gfc_class_vtab_size_get (decl);
1089 array = gfc_class_data_get (decl);
1092 if (comp->attr.allocatable
1093 || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)->attr.allocatable))
1095 tmp = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array))
1096 ? gfc_conv_descriptor_data_get (array) : array;
1097 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1098 tmp, fold_convert (TREE_TYPE (tmp),
1099 null_pointer_node));
1101 else
1102 cond = logical_true_node;
1104 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array)))
1106 gfc_clear_attr (&attr);
1107 gfc_init_se (&se, NULL);
1108 array = gfc_conv_scalar_to_descriptor (&se, array, attr);
1109 gfc_add_block_to_block (&block2, &se.pre);
1110 gcc_assert (se.post.head == NULL_TREE);
1113 if (!POINTER_TYPE_P (TREE_TYPE (array)))
1114 array = gfc_build_addr_expr (NULL, array);
1116 if (!final_expr)
1118 tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1119 final_fndecl,
1120 fold_convert (TREE_TYPE (final_fndecl),
1121 null_pointer_node));
1122 cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
1123 logical_type_node, cond, tmp);
1126 if (POINTER_TYPE_P (TREE_TYPE (final_fndecl)))
1127 final_fndecl = build_fold_indirect_ref_loc (input_location, final_fndecl);
1129 tmp = build_call_expr_loc (input_location,
1130 final_fndecl, 3, array,
1131 size, fini_coarray ? boolean_true_node
1132 : boolean_false_node);
1133 gfc_add_expr_to_block (&block2, tmp);
1134 tmp = gfc_finish_block (&block2);
1136 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
1137 build_empty_stmt (input_location));
1138 gfc_add_expr_to_block (block, tmp);
1140 return true;
1144 /* Add a call to the finalizer, using the passed *expr. Returns
1145 true when a finalizer call has been inserted. */
1147 bool
1148 gfc_add_finalizer_call (stmtblock_t *block, gfc_expr *expr2)
1150 tree tmp;
1151 gfc_ref *ref;
1152 gfc_expr *expr;
1153 gfc_expr *final_expr = NULL;
1154 gfc_expr *elem_size = NULL;
1155 bool has_finalizer = false;
1157 if (!expr2 || (expr2->ts.type != BT_DERIVED && expr2->ts.type != BT_CLASS))
1158 return false;
1160 if (expr2->ts.type == BT_DERIVED)
1162 gfc_is_finalizable (expr2->ts.u.derived, &final_expr);
1163 if (!final_expr)
1164 return false;
1167 /* If we have a class array, we need go back to the class
1168 container. */
1169 expr = gfc_copy_expr (expr2);
1171 if (expr->ref && expr->ref->next && !expr->ref->next->next
1172 && expr->ref->next->type == REF_ARRAY
1173 && expr->ref->type == REF_COMPONENT
1174 && strcmp (expr->ref->u.c.component->name, "_data") == 0)
1176 gfc_free_ref_list (expr->ref);
1177 expr->ref = NULL;
1179 else
1180 for (ref = expr->ref; ref; ref = ref->next)
1181 if (ref->next && ref->next->next && !ref->next->next->next
1182 && ref->next->next->type == REF_ARRAY
1183 && ref->next->type == REF_COMPONENT
1184 && strcmp (ref->next->u.c.component->name, "_data") == 0)
1186 gfc_free_ref_list (ref->next);
1187 ref->next = NULL;
1190 if (expr->ts.type == BT_CLASS)
1192 has_finalizer = gfc_is_finalizable (expr->ts.u.derived, NULL);
1194 if (!expr2->rank && !expr2->ref && CLASS_DATA (expr2->symtree->n.sym)->as)
1195 expr->rank = CLASS_DATA (expr2->symtree->n.sym)->as->rank;
1197 final_expr = gfc_copy_expr (expr);
1198 gfc_add_vptr_component (final_expr);
1199 gfc_add_final_component (final_expr);
1201 elem_size = gfc_copy_expr (expr);
1202 gfc_add_vptr_component (elem_size);
1203 gfc_add_size_component (elem_size);
1206 gcc_assert (final_expr->expr_type == EXPR_VARIABLE);
1208 tmp = gfc_build_final_call (expr->ts, final_expr, expr,
1209 false, elem_size);
1211 if (expr->ts.type == BT_CLASS && !has_finalizer)
1213 tree cond;
1214 gfc_se se;
1216 gfc_init_se (&se, NULL);
1217 se.want_pointer = 1;
1218 gfc_conv_expr (&se, final_expr);
1219 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1220 se.expr, build_int_cst (TREE_TYPE (se.expr), 0));
1222 /* For CLASS(*) not only sym->_vtab->_final can be NULL
1223 but already sym->_vtab itself. */
1224 if (UNLIMITED_POLY (expr))
1226 tree cond2;
1227 gfc_expr *vptr_expr;
1229 vptr_expr = gfc_copy_expr (expr);
1230 gfc_add_vptr_component (vptr_expr);
1232 gfc_init_se (&se, NULL);
1233 se.want_pointer = 1;
1234 gfc_conv_expr (&se, vptr_expr);
1235 gfc_free_expr (vptr_expr);
1237 cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1238 se.expr,
1239 build_int_cst (TREE_TYPE (se.expr), 0));
1240 cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
1241 logical_type_node, cond2, cond);
1244 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1245 cond, tmp, build_empty_stmt (input_location));
1248 gfc_add_expr_to_block (block, tmp);
1250 return true;
1254 /* User-deallocate; we emit the code directly from the front-end, and the
1255 logic is the same as the previous library function:
1257 void
1258 deallocate (void *pointer, GFC_INTEGER_4 * stat)
1260 if (!pointer)
1262 if (stat)
1263 *stat = 1;
1264 else
1265 runtime_error ("Attempt to DEALLOCATE unallocated memory.");
1267 else
1269 free (pointer);
1270 if (stat)
1271 *stat = 0;
1275 In this front-end version, status doesn't have to be GFC_INTEGER_4.
1276 Moreover, if CAN_FAIL is true, then we will not emit a runtime error,
1277 even when no status variable is passed to us (this is used for
1278 unconditional deallocation generated by the front-end at end of
1279 each procedure).
1281 If a runtime-message is possible, `expr' must point to the original
1282 expression being deallocated for its locus and variable name.
1284 For coarrays, "pointer" must be the array descriptor and not its
1285 "data" component.
1287 COARRAY_DEALLOC_MODE gives the mode unregister coarrays. Available modes are
1288 the ones of GFC_CAF_DEREGTYPE, -1 when the mode for deregistration is to be
1289 analyzed and set by this routine, and -2 to indicate that a non-coarray is to
1290 be deallocated. */
1291 tree
1292 gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
1293 tree errlen, tree label_finish,
1294 bool can_fail, gfc_expr* expr,
1295 int coarray_dealloc_mode, tree add_when_allocated,
1296 tree caf_token)
1298 stmtblock_t null, non_null;
1299 tree cond, tmp, error;
1300 tree status_type = NULL_TREE;
1301 tree token = NULL_TREE;
1302 gfc_coarray_deregtype caf_dereg_type = GFC_CAF_COARRAY_DEREGISTER;
1304 if (coarray_dealloc_mode >= GFC_CAF_COARRAY_ANALYZE)
1306 if (flag_coarray == GFC_FCOARRAY_LIB)
1308 if (caf_token)
1309 token = caf_token;
1310 else
1312 tree caf_type, caf_decl = pointer;
1313 pointer = gfc_conv_descriptor_data_get (caf_decl);
1314 caf_type = TREE_TYPE (caf_decl);
1315 STRIP_NOPS (pointer);
1316 if (GFC_DESCRIPTOR_TYPE_P (caf_type))
1317 token = gfc_conv_descriptor_token (caf_decl);
1318 else if (DECL_LANG_SPECIFIC (caf_decl)
1319 && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
1320 token = GFC_DECL_TOKEN (caf_decl);
1321 else
1323 gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
1324 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type)
1325 != NULL_TREE);
1326 token = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
1330 if (coarray_dealloc_mode == GFC_CAF_COARRAY_ANALYZE)
1332 bool comp_ref;
1333 if (expr && !gfc_caf_attr (expr, false, &comp_ref).coarray_comp
1334 && comp_ref)
1335 caf_dereg_type = GFC_CAF_COARRAY_DEALLOCATE_ONLY;
1336 // else do a deregister as set by default.
1338 else
1339 caf_dereg_type = (enum gfc_coarray_deregtype) coarray_dealloc_mode;
1341 else if (flag_coarray == GFC_FCOARRAY_SINGLE)
1342 pointer = gfc_conv_descriptor_data_get (pointer);
1344 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer)))
1345 pointer = gfc_conv_descriptor_data_get (pointer);
1347 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, pointer,
1348 build_int_cst (TREE_TYPE (pointer), 0));
1350 /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
1351 we emit a runtime error. */
1352 gfc_start_block (&null);
1353 if (!can_fail)
1355 tree varname;
1357 gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree);
1359 varname = gfc_build_cstring_const (expr->symtree->name);
1360 varname = gfc_build_addr_expr (pchar_type_node, varname);
1362 error = gfc_trans_runtime_error (true, &expr->where,
1363 "Attempt to DEALLOCATE unallocated '%s'",
1364 varname);
1366 else
1367 error = build_empty_stmt (input_location);
1369 if (status != NULL_TREE && !integer_zerop (status))
1371 tree cond2;
1373 status_type = TREE_TYPE (TREE_TYPE (status));
1374 cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1375 status, build_int_cst (TREE_TYPE (status), 0));
1376 tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
1377 fold_build1_loc (input_location, INDIRECT_REF,
1378 status_type, status),
1379 build_int_cst (status_type, 1));
1380 error = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1381 cond2, tmp, error);
1384 gfc_add_expr_to_block (&null, error);
1386 /* When POINTER is not NULL, we free it. */
1387 gfc_start_block (&non_null);
1388 if (add_when_allocated)
1389 gfc_add_expr_to_block (&non_null, add_when_allocated);
1390 gfc_add_finalizer_call (&non_null, expr);
1391 if (coarray_dealloc_mode == GFC_CAF_COARRAY_NOCOARRAY
1392 || flag_coarray != GFC_FCOARRAY_LIB)
1394 tmp = build_call_expr_loc (input_location,
1395 builtin_decl_explicit (BUILT_IN_FREE), 1,
1396 fold_convert (pvoid_type_node, pointer));
1397 gfc_add_expr_to_block (&non_null, tmp);
1398 gfc_add_modify (&non_null, pointer, build_int_cst (TREE_TYPE (pointer),
1399 0));
1401 if (status != NULL_TREE && !integer_zerop (status))
1403 /* We set STATUS to zero if it is present. */
1404 tree status_type = TREE_TYPE (TREE_TYPE (status));
1405 tree cond2;
1407 cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1408 status,
1409 build_int_cst (TREE_TYPE (status), 0));
1410 tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
1411 fold_build1_loc (input_location, INDIRECT_REF,
1412 status_type, status),
1413 build_int_cst (status_type, 0));
1414 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1415 gfc_unlikely (cond2, PRED_FORTRAN_FAIL_ALLOC),
1416 tmp, build_empty_stmt (input_location));
1417 gfc_add_expr_to_block (&non_null, tmp);
1420 else
1422 tree cond2, pstat = null_pointer_node;
1424 if (errmsg == NULL_TREE)
1426 gcc_assert (errlen == NULL_TREE);
1427 errmsg = null_pointer_node;
1428 errlen = build_zero_cst (integer_type_node);
1430 else
1432 gcc_assert (errlen != NULL_TREE);
1433 if (!POINTER_TYPE_P (TREE_TYPE (errmsg)))
1434 errmsg = gfc_build_addr_expr (NULL_TREE, errmsg);
1437 if (status != NULL_TREE && !integer_zerop (status))
1439 gcc_assert (status_type == integer_type_node);
1440 pstat = status;
1443 token = gfc_build_addr_expr (NULL_TREE, token);
1444 gcc_assert (caf_dereg_type > GFC_CAF_COARRAY_ANALYZE);
1445 tmp = build_call_expr_loc (input_location,
1446 gfor_fndecl_caf_deregister, 5,
1447 token, build_int_cst (integer_type_node,
1448 caf_dereg_type),
1449 pstat, errmsg, errlen);
1450 gfc_add_expr_to_block (&non_null, tmp);
1452 /* It guarantees memory consistency within the same segment */
1453 tmp = gfc_build_string_const (strlen ("memory")+1, "memory"),
1454 tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
1455 gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
1456 tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
1457 ASM_VOLATILE_P (tmp) = 1;
1458 gfc_add_expr_to_block (&non_null, tmp);
1460 if (status != NULL_TREE)
1462 tree stat = build_fold_indirect_ref_loc (input_location, status);
1463 tree nullify = fold_build2_loc (input_location, MODIFY_EXPR,
1464 void_type_node, pointer,
1465 build_int_cst (TREE_TYPE (pointer),
1466 0));
1468 TREE_USED (label_finish) = 1;
1469 tmp = build1_v (GOTO_EXPR, label_finish);
1470 cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1471 stat, build_zero_cst (TREE_TYPE (stat)));
1472 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1473 gfc_unlikely (cond2, PRED_FORTRAN_REALLOC),
1474 tmp, nullify);
1475 gfc_add_expr_to_block (&non_null, tmp);
1477 else
1478 gfc_add_modify (&non_null, pointer, build_int_cst (TREE_TYPE (pointer),
1479 0));
1482 return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
1483 gfc_finish_block (&null),
1484 gfc_finish_block (&non_null));
1488 /* Generate code for deallocation of allocatable scalars (variables or
1489 components). Before the object itself is freed, any allocatable
1490 subcomponents are being deallocated. */
1492 tree
1493 gfc_deallocate_scalar_with_status (tree pointer, tree status, tree label_finish,
1494 bool can_fail, gfc_expr* expr,
1495 gfc_typespec ts, bool coarray)
1497 stmtblock_t null, non_null;
1498 tree cond, tmp, error;
1499 bool finalizable, comp_ref;
1500 gfc_coarray_deregtype caf_dereg_type = GFC_CAF_COARRAY_DEREGISTER;
1502 if (coarray && expr && !gfc_caf_attr (expr, false, &comp_ref).coarray_comp
1503 && comp_ref)
1504 caf_dereg_type = GFC_CAF_COARRAY_DEALLOCATE_ONLY;
1506 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, pointer,
1507 build_int_cst (TREE_TYPE (pointer), 0));
1509 /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
1510 we emit a runtime error. */
1511 gfc_start_block (&null);
1512 if (!can_fail)
1514 tree varname;
1516 gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree);
1518 varname = gfc_build_cstring_const (expr->symtree->name);
1519 varname = gfc_build_addr_expr (pchar_type_node, varname);
1521 error = gfc_trans_runtime_error (true, &expr->where,
1522 "Attempt to DEALLOCATE unallocated '%s'",
1523 varname);
1525 else
1526 error = build_empty_stmt (input_location);
1528 if (status != NULL_TREE && !integer_zerop (status))
1530 tree status_type = TREE_TYPE (TREE_TYPE (status));
1531 tree cond2;
1533 cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1534 status, build_int_cst (TREE_TYPE (status), 0));
1535 tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
1536 fold_build1_loc (input_location, INDIRECT_REF,
1537 status_type, status),
1538 build_int_cst (status_type, 1));
1539 error = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1540 cond2, tmp, error);
1542 gfc_add_expr_to_block (&null, error);
1544 /* When POINTER is not NULL, we free it. */
1545 gfc_start_block (&non_null);
1547 /* Free allocatable components. */
1548 finalizable = gfc_add_finalizer_call (&non_null, expr);
1549 if (!finalizable && ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
1551 int caf_mode = coarray
1552 ? ((caf_dereg_type == GFC_CAF_COARRAY_DEALLOCATE_ONLY
1553 ? GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY : 0)
1554 | GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
1555 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY)
1556 : 0;
1557 if (coarray && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer)))
1558 tmp = gfc_conv_descriptor_data_get (pointer);
1559 else
1560 tmp = build_fold_indirect_ref_loc (input_location, pointer);
1561 tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0, caf_mode);
1562 gfc_add_expr_to_block (&non_null, tmp);
1565 if (!coarray || flag_coarray == GFC_FCOARRAY_SINGLE)
1567 tmp = build_call_expr_loc (input_location,
1568 builtin_decl_explicit (BUILT_IN_FREE), 1,
1569 fold_convert (pvoid_type_node, pointer));
1570 gfc_add_expr_to_block (&non_null, tmp);
1572 if (status != NULL_TREE && !integer_zerop (status))
1574 /* We set STATUS to zero if it is present. */
1575 tree status_type = TREE_TYPE (TREE_TYPE (status));
1576 tree cond2;
1578 cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1579 status,
1580 build_int_cst (TREE_TYPE (status), 0));
1581 tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
1582 fold_build1_loc (input_location, INDIRECT_REF,
1583 status_type, status),
1584 build_int_cst (status_type, 0));
1585 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1586 cond2, tmp, build_empty_stmt (input_location));
1587 gfc_add_expr_to_block (&non_null, tmp);
1590 else
1592 tree token;
1593 tree pstat = null_pointer_node;
1594 gfc_se se;
1596 gfc_init_se (&se, NULL);
1597 token = gfc_get_ultimate_alloc_ptr_comps_caf_token (&se, expr);
1598 gcc_assert (token != NULL_TREE);
1600 if (status != NULL_TREE && !integer_zerop (status))
1602 gcc_assert (TREE_TYPE (TREE_TYPE (status)) == integer_type_node);
1603 pstat = status;
1606 tmp = build_call_expr_loc (input_location,
1607 gfor_fndecl_caf_deregister, 5,
1608 token, build_int_cst (integer_type_node,
1609 caf_dereg_type),
1610 pstat, null_pointer_node, integer_zero_node);
1611 gfc_add_expr_to_block (&non_null, tmp);
1613 /* It guarantees memory consistency within the same segment. */
1614 tmp = gfc_build_string_const (strlen ("memory")+1, "memory");
1615 tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
1616 gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
1617 tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
1618 ASM_VOLATILE_P (tmp) = 1;
1619 gfc_add_expr_to_block (&non_null, tmp);
1621 if (status != NULL_TREE)
1623 tree stat = build_fold_indirect_ref_loc (input_location, status);
1624 tree cond2;
1626 TREE_USED (label_finish) = 1;
1627 tmp = build1_v (GOTO_EXPR, label_finish);
1628 cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1629 stat, build_zero_cst (TREE_TYPE (stat)));
1630 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1631 gfc_unlikely (cond2, PRED_FORTRAN_REALLOC),
1632 tmp, build_empty_stmt (input_location));
1633 gfc_add_expr_to_block (&non_null, tmp);
1637 return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
1638 gfc_finish_block (&null),
1639 gfc_finish_block (&non_null));
1642 /* Reallocate MEM so it has SIZE bytes of data. This behaves like the
1643 following pseudo-code:
1645 void *
1646 internal_realloc (void *mem, size_t size)
1648 res = realloc (mem, size);
1649 if (!res && size != 0)
1650 _gfortran_os_error ("Allocation would exceed memory limit");
1652 return res;
1653 } */
1654 tree
1655 gfc_call_realloc (stmtblock_t * block, tree mem, tree size)
1657 tree msg, res, nonzero, null_result, tmp;
1658 tree type = TREE_TYPE (mem);
1660 /* Only evaluate the size once. */
1661 size = save_expr (fold_convert (size_type_node, size));
1663 /* Create a variable to hold the result. */
1664 res = gfc_create_var (type, NULL);
1666 /* Call realloc and check the result. */
1667 tmp = build_call_expr_loc (input_location,
1668 builtin_decl_explicit (BUILT_IN_REALLOC), 2,
1669 fold_convert (pvoid_type_node, mem), size);
1670 gfc_add_modify (block, res, fold_convert (type, tmp));
1671 null_result = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
1672 res, build_int_cst (pvoid_type_node, 0));
1673 nonzero = fold_build2_loc (input_location, NE_EXPR, logical_type_node, size,
1674 build_int_cst (size_type_node, 0));
1675 null_result = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
1676 null_result, nonzero);
1677 msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
1678 ("Allocation would exceed memory limit"));
1679 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1680 null_result,
1681 build_call_expr_loc (input_location,
1682 gfor_fndecl_os_error, 1, msg),
1683 build_empty_stmt (input_location));
1684 gfc_add_expr_to_block (block, tmp);
1686 return res;
1690 /* Add an expression to another one, either at the front or the back. */
1692 static void
1693 add_expr_to_chain (tree* chain, tree expr, bool front)
1695 if (expr == NULL_TREE || IS_EMPTY_STMT (expr))
1696 return;
1698 if (*chain)
1700 if (TREE_CODE (*chain) != STATEMENT_LIST)
1702 tree tmp;
1704 tmp = *chain;
1705 *chain = NULL_TREE;
1706 append_to_statement_list (tmp, chain);
1709 if (front)
1711 tree_stmt_iterator i;
1713 i = tsi_start (*chain);
1714 tsi_link_before (&i, expr, TSI_CONTINUE_LINKING);
1716 else
1717 append_to_statement_list (expr, chain);
1719 else
1720 *chain = expr;
1724 /* Add a statement at the end of a block. */
1726 void
1727 gfc_add_expr_to_block (stmtblock_t * block, tree expr)
1729 gcc_assert (block);
1730 add_expr_to_chain (&block->head, expr, false);
1734 /* Add a statement at the beginning of a block. */
1736 void
1737 gfc_prepend_expr_to_block (stmtblock_t * block, tree expr)
1739 gcc_assert (block);
1740 add_expr_to_chain (&block->head, expr, true);
1744 /* Add a block the end of a block. */
1746 void
1747 gfc_add_block_to_block (stmtblock_t * block, stmtblock_t * append)
1749 gcc_assert (append);
1750 gcc_assert (!append->has_scope);
1752 gfc_add_expr_to_block (block, append->head);
1753 append->head = NULL_TREE;
1757 /* Save the current locus. The structure may not be complete, and should
1758 only be used with gfc_restore_backend_locus. */
1760 void
1761 gfc_save_backend_locus (locus * loc)
1763 loc->lb = XCNEW (gfc_linebuf);
1764 loc->lb->location = input_location;
1765 loc->lb->file = gfc_current_backend_file;
1769 /* Set the current locus. */
1771 void
1772 gfc_set_backend_locus (locus * loc)
1774 gfc_current_backend_file = loc->lb->file;
1775 input_location = loc->lb->location;
1779 /* Restore the saved locus. Only used in conjunction with
1780 gfc_save_backend_locus, to free the memory when we are done. */
1782 void
1783 gfc_restore_backend_locus (locus * loc)
1785 gfc_set_backend_locus (loc);
1786 free (loc->lb);
1790 /* Translate an executable statement. The tree cond is used by gfc_trans_do.
1791 This static function is wrapped by gfc_trans_code_cond and
1792 gfc_trans_code. */
1794 static tree
1795 trans_code (gfc_code * code, tree cond)
1797 stmtblock_t block;
1798 tree res;
1800 if (!code)
1801 return build_empty_stmt (input_location);
1803 gfc_start_block (&block);
1805 /* Translate statements one by one into GENERIC trees until we reach
1806 the end of this gfc_code branch. */
1807 for (; code; code = code->next)
1809 if (code->here != 0)
1811 res = gfc_trans_label_here (code);
1812 gfc_add_expr_to_block (&block, res);
1815 gfc_current_locus = code->loc;
1816 gfc_set_backend_locus (&code->loc);
1818 switch (code->op)
1820 case EXEC_NOP:
1821 case EXEC_END_BLOCK:
1822 case EXEC_END_NESTED_BLOCK:
1823 case EXEC_END_PROCEDURE:
1824 res = NULL_TREE;
1825 break;
1827 case EXEC_ASSIGN:
1828 res = gfc_trans_assign (code);
1829 break;
1831 case EXEC_LABEL_ASSIGN:
1832 res = gfc_trans_label_assign (code);
1833 break;
1835 case EXEC_POINTER_ASSIGN:
1836 res = gfc_trans_pointer_assign (code);
1837 break;
1839 case EXEC_INIT_ASSIGN:
1840 if (code->expr1->ts.type == BT_CLASS)
1841 res = gfc_trans_class_init_assign (code);
1842 else
1843 res = gfc_trans_init_assign (code);
1844 break;
1846 case EXEC_CONTINUE:
1847 res = NULL_TREE;
1848 break;
1850 case EXEC_CRITICAL:
1851 res = gfc_trans_critical (code);
1852 break;
1854 case EXEC_CYCLE:
1855 res = gfc_trans_cycle (code);
1856 break;
1858 case EXEC_EXIT:
1859 res = gfc_trans_exit (code);
1860 break;
1862 case EXEC_GOTO:
1863 res = gfc_trans_goto (code);
1864 break;
1866 case EXEC_ENTRY:
1867 res = gfc_trans_entry (code);
1868 break;
1870 case EXEC_PAUSE:
1871 res = gfc_trans_pause (code);
1872 break;
1874 case EXEC_STOP:
1875 case EXEC_ERROR_STOP:
1876 res = gfc_trans_stop (code, code->op == EXEC_ERROR_STOP);
1877 break;
1879 case EXEC_CALL:
1880 /* For MVBITS we've got the special exception that we need a
1881 dependency check, too. */
1883 bool is_mvbits = false;
1885 if (code->resolved_isym)
1887 res = gfc_conv_intrinsic_subroutine (code);
1888 if (res != NULL_TREE)
1889 break;
1892 if (code->resolved_isym
1893 && code->resolved_isym->id == GFC_ISYM_MVBITS)
1894 is_mvbits = true;
1896 res = gfc_trans_call (code, is_mvbits, NULL_TREE,
1897 NULL_TREE, false);
1899 break;
1901 case EXEC_CALL_PPC:
1902 res = gfc_trans_call (code, false, NULL_TREE,
1903 NULL_TREE, false);
1904 break;
1906 case EXEC_ASSIGN_CALL:
1907 res = gfc_trans_call (code, true, NULL_TREE,
1908 NULL_TREE, false);
1909 break;
1911 case EXEC_RETURN:
1912 res = gfc_trans_return (code);
1913 break;
1915 case EXEC_IF:
1916 res = gfc_trans_if (code);
1917 break;
1919 case EXEC_ARITHMETIC_IF:
1920 res = gfc_trans_arithmetic_if (code);
1921 break;
1923 case EXEC_BLOCK:
1924 res = gfc_trans_block_construct (code);
1925 break;
1927 case EXEC_DO:
1928 res = gfc_trans_do (code, cond);
1929 break;
1931 case EXEC_DO_CONCURRENT:
1932 res = gfc_trans_do_concurrent (code);
1933 break;
1935 case EXEC_DO_WHILE:
1936 res = gfc_trans_do_while (code);
1937 break;
1939 case EXEC_SELECT:
1940 res = gfc_trans_select (code);
1941 break;
1943 case EXEC_SELECT_TYPE:
1944 res = gfc_trans_select_type (code);
1945 break;
1947 case EXEC_FLUSH:
1948 res = gfc_trans_flush (code);
1949 break;
1951 case EXEC_SYNC_ALL:
1952 case EXEC_SYNC_IMAGES:
1953 case EXEC_SYNC_MEMORY:
1954 res = gfc_trans_sync (code, code->op);
1955 break;
1957 case EXEC_LOCK:
1958 case EXEC_UNLOCK:
1959 res = gfc_trans_lock_unlock (code, code->op);
1960 break;
1962 case EXEC_EVENT_POST:
1963 case EXEC_EVENT_WAIT:
1964 res = gfc_trans_event_post_wait (code, code->op);
1965 break;
1967 case EXEC_FAIL_IMAGE:
1968 res = gfc_trans_fail_image (code);
1969 break;
1971 case EXEC_FORALL:
1972 res = gfc_trans_forall (code);
1973 break;
1975 case EXEC_FORM_TEAM:
1976 res = gfc_trans_form_team (code);
1977 break;
1979 case EXEC_CHANGE_TEAM:
1980 res = gfc_trans_change_team (code);
1981 break;
1983 case EXEC_END_TEAM:
1984 res = gfc_trans_end_team (code);
1985 break;
1987 case EXEC_SYNC_TEAM:
1988 res = gfc_trans_sync_team (code);
1989 break;
1991 case EXEC_WHERE:
1992 res = gfc_trans_where (code);
1993 break;
1995 case EXEC_ALLOCATE:
1996 res = gfc_trans_allocate (code);
1997 break;
1999 case EXEC_DEALLOCATE:
2000 res = gfc_trans_deallocate (code);
2001 break;
2003 case EXEC_OPEN:
2004 res = gfc_trans_open (code);
2005 break;
2007 case EXEC_CLOSE:
2008 res = gfc_trans_close (code);
2009 break;
2011 case EXEC_READ:
2012 res = gfc_trans_read (code);
2013 break;
2015 case EXEC_WRITE:
2016 res = gfc_trans_write (code);
2017 break;
2019 case EXEC_IOLENGTH:
2020 res = gfc_trans_iolength (code);
2021 break;
2023 case EXEC_BACKSPACE:
2024 res = gfc_trans_backspace (code);
2025 break;
2027 case EXEC_ENDFILE:
2028 res = gfc_trans_endfile (code);
2029 break;
2031 case EXEC_INQUIRE:
2032 res = gfc_trans_inquire (code);
2033 break;
2035 case EXEC_WAIT:
2036 res = gfc_trans_wait (code);
2037 break;
2039 case EXEC_REWIND:
2040 res = gfc_trans_rewind (code);
2041 break;
2043 case EXEC_TRANSFER:
2044 res = gfc_trans_transfer (code);
2045 break;
2047 case EXEC_DT_END:
2048 res = gfc_trans_dt_end (code);
2049 break;
2051 case EXEC_OMP_ATOMIC:
2052 case EXEC_OMP_BARRIER:
2053 case EXEC_OMP_CANCEL:
2054 case EXEC_OMP_CANCELLATION_POINT:
2055 case EXEC_OMP_CRITICAL:
2056 case EXEC_OMP_DISTRIBUTE:
2057 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
2058 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
2059 case EXEC_OMP_DISTRIBUTE_SIMD:
2060 case EXEC_OMP_DO:
2061 case EXEC_OMP_DO_SIMD:
2062 case EXEC_OMP_FLUSH:
2063 case EXEC_OMP_MASTER:
2064 case EXEC_OMP_ORDERED:
2065 case EXEC_OMP_PARALLEL:
2066 case EXEC_OMP_PARALLEL_DO:
2067 case EXEC_OMP_PARALLEL_DO_SIMD:
2068 case EXEC_OMP_PARALLEL_SECTIONS:
2069 case EXEC_OMP_PARALLEL_WORKSHARE:
2070 case EXEC_OMP_SECTIONS:
2071 case EXEC_OMP_SIMD:
2072 case EXEC_OMP_SINGLE:
2073 case EXEC_OMP_TARGET:
2074 case EXEC_OMP_TARGET_DATA:
2075 case EXEC_OMP_TARGET_ENTER_DATA:
2076 case EXEC_OMP_TARGET_EXIT_DATA:
2077 case EXEC_OMP_TARGET_PARALLEL:
2078 case EXEC_OMP_TARGET_PARALLEL_DO:
2079 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
2080 case EXEC_OMP_TARGET_SIMD:
2081 case EXEC_OMP_TARGET_TEAMS:
2082 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
2083 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
2084 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
2085 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
2086 case EXEC_OMP_TARGET_UPDATE:
2087 case EXEC_OMP_TASK:
2088 case EXEC_OMP_TASKGROUP:
2089 case EXEC_OMP_TASKLOOP:
2090 case EXEC_OMP_TASKLOOP_SIMD:
2091 case EXEC_OMP_TASKWAIT:
2092 case EXEC_OMP_TASKYIELD:
2093 case EXEC_OMP_TEAMS:
2094 case EXEC_OMP_TEAMS_DISTRIBUTE:
2095 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
2096 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
2097 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
2098 case EXEC_OMP_WORKSHARE:
2099 res = gfc_trans_omp_directive (code);
2100 break;
2102 case EXEC_OACC_CACHE:
2103 case EXEC_OACC_WAIT:
2104 case EXEC_OACC_UPDATE:
2105 case EXEC_OACC_LOOP:
2106 case EXEC_OACC_HOST_DATA:
2107 case EXEC_OACC_DATA:
2108 case EXEC_OACC_KERNELS:
2109 case EXEC_OACC_KERNELS_LOOP:
2110 case EXEC_OACC_PARALLEL:
2111 case EXEC_OACC_PARALLEL_LOOP:
2112 case EXEC_OACC_ENTER_DATA:
2113 case EXEC_OACC_EXIT_DATA:
2114 case EXEC_OACC_ATOMIC:
2115 case EXEC_OACC_DECLARE:
2116 res = gfc_trans_oacc_directive (code);
2117 break;
2119 default:
2120 gfc_internal_error ("gfc_trans_code(): Bad statement code");
2123 gfc_set_backend_locus (&code->loc);
2125 if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
2127 if (TREE_CODE (res) != STATEMENT_LIST)
2128 SET_EXPR_LOCATION (res, input_location);
2130 /* Add the new statement to the block. */
2131 gfc_add_expr_to_block (&block, res);
2135 /* Return the finished block. */
2136 return gfc_finish_block (&block);
2140 /* Translate an executable statement with condition, cond. The condition is
2141 used by gfc_trans_do to test for IO result conditions inside implied
2142 DO loops of READ and WRITE statements. See build_dt in trans-io.c. */
2144 tree
2145 gfc_trans_code_cond (gfc_code * code, tree cond)
2147 return trans_code (code, cond);
2150 /* Translate an executable statement without condition. */
2152 tree
2153 gfc_trans_code (gfc_code * code)
2155 return trans_code (code, NULL_TREE);
2159 /* This function is called after a complete program unit has been parsed
2160 and resolved. */
2162 void
2163 gfc_generate_code (gfc_namespace * ns)
2165 ompws_flags = 0;
2166 if (ns->is_block_data)
2168 gfc_generate_block_data (ns);
2169 return;
2172 gfc_generate_function_code (ns);
2176 /* This function is called after a complete module has been parsed
2177 and resolved. */
2179 void
2180 gfc_generate_module_code (gfc_namespace * ns)
2182 gfc_namespace *n;
2183 struct module_htab_entry *entry;
2185 gcc_assert (ns->proc_name->backend_decl == NULL);
2186 ns->proc_name->backend_decl
2187 = build_decl (ns->proc_name->declared_at.lb->location,
2188 NAMESPACE_DECL, get_identifier (ns->proc_name->name),
2189 void_type_node);
2190 entry = gfc_find_module (ns->proc_name->name);
2191 if (entry->namespace_decl)
2192 /* Buggy sourcecode, using a module before defining it? */
2193 entry->decls->empty ();
2194 entry->namespace_decl = ns->proc_name->backend_decl;
2196 gfc_generate_module_vars (ns);
2198 /* We need to generate all module function prototypes first, to allow
2199 sibling calls. */
2200 for (n = ns->contained; n; n = n->sibling)
2202 gfc_entry_list *el;
2204 if (!n->proc_name)
2205 continue;
2207 gfc_create_function_decl (n, false);
2208 DECL_CONTEXT (n->proc_name->backend_decl) = ns->proc_name->backend_decl;
2209 gfc_module_add_decl (entry, n->proc_name->backend_decl);
2210 for (el = ns->entries; el; el = el->next)
2212 DECL_CONTEXT (el->sym->backend_decl) = ns->proc_name->backend_decl;
2213 gfc_module_add_decl (entry, el->sym->backend_decl);
2217 for (n = ns->contained; n; n = n->sibling)
2219 if (!n->proc_name)
2220 continue;
2222 gfc_generate_function_code (n);
2227 /* Initialize an init/cleanup block with existing code. */
2229 void
2230 gfc_start_wrapped_block (gfc_wrapped_block* block, tree code)
2232 gcc_assert (block);
2234 block->init = NULL_TREE;
2235 block->code = code;
2236 block->cleanup = NULL_TREE;
2240 /* Add a new pair of initializers/clean-up code. */
2242 void
2243 gfc_add_init_cleanup (gfc_wrapped_block* block, tree init, tree cleanup)
2245 gcc_assert (block);
2247 /* The new pair of init/cleanup should be "wrapped around" the existing
2248 block of code, thus the initialization is added to the front and the
2249 cleanup to the back. */
2250 add_expr_to_chain (&block->init, init, true);
2251 add_expr_to_chain (&block->cleanup, cleanup, false);
2255 /* Finish up a wrapped block by building a corresponding try-finally expr. */
2257 tree
2258 gfc_finish_wrapped_block (gfc_wrapped_block* block)
2260 tree result;
2262 gcc_assert (block);
2264 /* Build the final expression. For this, just add init and body together,
2265 and put clean-up with that into a TRY_FINALLY_EXPR. */
2266 result = block->init;
2267 add_expr_to_chain (&result, block->code, false);
2268 if (block->cleanup)
2269 result = build2_loc (input_location, TRY_FINALLY_EXPR, void_type_node,
2270 result, block->cleanup);
2272 /* Clear the block. */
2273 block->init = NULL_TREE;
2274 block->code = NULL_TREE;
2275 block->cleanup = NULL_TREE;
2277 return result;
2281 /* Helper function for marking a boolean expression tree as unlikely. */
2283 tree
2284 gfc_unlikely (tree cond, enum br_predictor predictor)
2286 tree tmp;
2288 if (optimize)
2290 cond = fold_convert (long_integer_type_node, cond);
2291 tmp = build_zero_cst (long_integer_type_node);
2292 cond = build_call_expr_loc (input_location,
2293 builtin_decl_explicit (BUILT_IN_EXPECT),
2294 3, cond, tmp,
2295 build_int_cst (integer_type_node,
2296 predictor));
2298 return cond;
2302 /* Helper function for marking a boolean expression tree as likely. */
2304 tree
2305 gfc_likely (tree cond, enum br_predictor predictor)
2307 tree tmp;
2309 if (optimize)
2311 cond = fold_convert (long_integer_type_node, cond);
2312 tmp = build_one_cst (long_integer_type_node);
2313 cond = build_call_expr_loc (input_location,
2314 builtin_decl_explicit (BUILT_IN_EXPECT),
2315 3, cond, tmp,
2316 build_int_cst (integer_type_node,
2317 predictor));
2319 return cond;
2323 /* Get the string length for a deferred character length component. */
2325 bool
2326 gfc_deferred_strlen (gfc_component *c, tree *decl)
2328 char name[GFC_MAX_SYMBOL_LEN+9];
2329 gfc_component *strlen;
2330 if (!(c->ts.type == BT_CHARACTER
2331 && (c->ts.deferred || c->attr.pdt_string)))
2332 return false;
2333 sprintf (name, "_%s_length", c->name);
2334 for (strlen = c; strlen; strlen = strlen->next)
2335 if (strcmp (strlen->name, name) == 0)
2336 break;
2337 *decl = strlen ? strlen->backend_decl : NULL_TREE;
2338 return strlen != NULL;