1 /* Code translation -- generate GCC trees from gfc_code.
2 Copyright (C) 2002-2020 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
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
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/>. */
23 #include "coretypes.h"
27 #include "gimple-expr.h" /* For create_tmp_var_raw. */
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 /* Return a location_t suitable for 'tree' for a gfortran locus. The way the
52 parser works in gfortran, loc->lb->location contains only the line number
53 and LOCATION_COLUMN is 0; hence, the column has to be added when generating
54 locations for 'tree'. Cf. error.c's gfc_format_decoder. */
57 gfc_get_location (locus
*loc
)
59 return linemap_position_for_loc_and_offset (line_table
, loc
->lb
->location
,
60 loc
->nextc
- loc
->lb
->line
);
63 /* Advance along TREE_CHAIN n times. */
66 gfc_advance_chain (tree t
, int n
)
70 gcc_assert (t
!= NULL_TREE
);
76 /* Creates a variable declaration with a given TYPE. */
79 gfc_create_var_np (tree type
, const char *prefix
)
83 t
= create_tmp_var_raw (type
, prefix
);
85 /* No warnings for anonymous variables. */
87 TREE_NO_WARNING (t
) = 1;
93 /* Like above, but also adds it to the current scope. */
96 gfc_create_var (tree type
, const char *prefix
)
100 tmp
= gfc_create_var_np (type
, prefix
);
108 /* If the expression is not constant, evaluate it now. We assign the
109 result of the expression to an artificially created variable VAR, and
110 return a pointer to the VAR_DECL node for this variable. */
113 gfc_evaluate_now_loc (location_t loc
, tree expr
, stmtblock_t
* pblock
)
117 if (CONSTANT_CLASS_P (expr
))
120 var
= gfc_create_var (TREE_TYPE (expr
), NULL
);
121 gfc_add_modify_loc (loc
, pblock
, var
, expr
);
128 gfc_evaluate_now (tree expr
, stmtblock_t
* pblock
)
130 return gfc_evaluate_now_loc (input_location
, expr
, pblock
);
133 /* Like gfc_evaluate_now, but add the created variable to the
137 gfc_evaluate_now_function_scope (tree expr
, stmtblock_t
* pblock
)
140 var
= gfc_create_var_np (TREE_TYPE (expr
), NULL
);
141 gfc_add_decl_to_function (var
);
142 gfc_add_modify (pblock
, var
, expr
);
147 /* Build a MODIFY_EXPR node and add it to a given statement block PBLOCK.
148 A MODIFY_EXPR is an assignment:
152 gfc_add_modify_loc (location_t loc
, stmtblock_t
* pblock
, tree lhs
, tree rhs
)
157 t1
= TREE_TYPE (rhs
);
158 t2
= TREE_TYPE (lhs
);
159 /* Make sure that the types of the rhs and the lhs are compatible
160 for scalar assignments. We should probably have something
161 similar for aggregates, but right now removing that check just
162 breaks everything. */
163 gcc_checking_assert (TYPE_MAIN_VARIANT (t1
) == TYPE_MAIN_VARIANT (t2
)
164 || AGGREGATE_TYPE_P (TREE_TYPE (lhs
)));
166 tmp
= fold_build2_loc (loc
, MODIFY_EXPR
, void_type_node
, lhs
,
168 gfc_add_expr_to_block (pblock
, tmp
);
173 gfc_add_modify (stmtblock_t
* pblock
, tree lhs
, tree rhs
)
175 gfc_add_modify_loc (input_location
, pblock
, lhs
, rhs
);
179 /* Create a new scope/binding level and initialize a block. Care must be
180 taken when translating expressions as any temporaries will be placed in
181 the innermost scope. */
184 gfc_start_block (stmtblock_t
* block
)
186 /* Start a new binding level. */
188 block
->has_scope
= 1;
190 /* The block is empty. */
191 block
->head
= NULL_TREE
;
195 /* Initialize a block without creating a new scope. */
198 gfc_init_block (stmtblock_t
* block
)
200 block
->head
= NULL_TREE
;
201 block
->has_scope
= 0;
205 /* Sometimes we create a scope but it turns out that we don't actually
206 need it. This function merges the scope of BLOCK with its parent.
207 Only variable decls will be merged, you still need to add the code. */
210 gfc_merge_block_scope (stmtblock_t
* block
)
215 gcc_assert (block
->has_scope
);
216 block
->has_scope
= 0;
218 /* Remember the decls in this scope. */
222 /* Add them to the parent scope. */
223 while (decl
!= NULL_TREE
)
225 next
= DECL_CHAIN (decl
);
226 DECL_CHAIN (decl
) = NULL_TREE
;
234 /* Finish a scope containing a block of statements. */
237 gfc_finish_block (stmtblock_t
* stmtblock
)
243 expr
= stmtblock
->head
;
245 expr
= build_empty_stmt (input_location
);
247 stmtblock
->head
= NULL_TREE
;
249 if (stmtblock
->has_scope
)
255 block
= poplevel (1, 0);
256 expr
= build3_v (BIND_EXPR
, decl
, expr
, block
);
266 /* Build an ADDR_EXPR and cast the result to TYPE. If TYPE is NULL, the
267 natural type is used. */
270 gfc_build_addr_expr (tree type
, tree t
)
272 tree base_type
= TREE_TYPE (t
);
275 if (type
&& POINTER_TYPE_P (type
)
276 && TREE_CODE (base_type
) == ARRAY_TYPE
277 && TYPE_MAIN_VARIANT (TREE_TYPE (type
))
278 == TYPE_MAIN_VARIANT (TREE_TYPE (base_type
)))
280 tree min_val
= size_zero_node
;
281 tree type_domain
= TYPE_DOMAIN (base_type
);
282 if (type_domain
&& TYPE_MIN_VALUE (type_domain
))
283 min_val
= TYPE_MIN_VALUE (type_domain
);
284 t
= fold (build4_loc (input_location
, ARRAY_REF
, TREE_TYPE (type
),
285 t
, min_val
, NULL_TREE
, NULL_TREE
));
289 natural_type
= build_pointer_type (base_type
);
291 if (TREE_CODE (t
) == INDIRECT_REF
)
295 t
= TREE_OPERAND (t
, 0);
296 natural_type
= TREE_TYPE (t
);
300 tree base
= get_base_address (t
);
301 if (base
&& DECL_P (base
))
302 TREE_ADDRESSABLE (base
) = 1;
303 t
= fold_build1_loc (input_location
, ADDR_EXPR
, natural_type
, t
);
306 if (type
&& natural_type
!= type
)
307 t
= convert (type
, t
);
314 get_array_span (tree type
, tree decl
)
318 /* Component references are guaranteed to have a reliable value for
319 'span'. Likewise indirect references since they emerge from the
320 conversion of a CFI descriptor or the hidden dummy descriptor. */
321 if (TREE_CODE (decl
) == COMPONENT_REF
322 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
)))
323 return gfc_conv_descriptor_span_get (decl
);
324 else if (TREE_CODE (decl
) == INDIRECT_REF
325 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
)))
326 return gfc_conv_descriptor_span_get (decl
);
328 /* Return the span for deferred character length array references. */
329 if (type
&& TREE_CODE (type
) == ARRAY_TYPE
330 && TYPE_MAX_VALUE (TYPE_DOMAIN (type
)) != NULL_TREE
331 && (VAR_P (TYPE_MAX_VALUE (TYPE_DOMAIN (type
)))
332 || TREE_CODE (TYPE_MAX_VALUE (TYPE_DOMAIN (type
))) == INDIRECT_REF
)
333 && (TREE_CODE (TYPE_MAX_VALUE (TYPE_DOMAIN (type
))) == INDIRECT_REF
334 || TREE_CODE (decl
) == FUNCTION_DECL
335 || DECL_CONTEXT (TYPE_MAX_VALUE (TYPE_DOMAIN (type
)))
336 == DECL_CONTEXT (decl
)))
338 span
= fold_convert (gfc_array_index_type
,
339 TYPE_MAX_VALUE (TYPE_DOMAIN (type
)));
340 span
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
341 fold_convert (gfc_array_index_type
,
342 TYPE_SIZE_UNIT (TREE_TYPE (type
))),
345 else if (type
&& TREE_CODE (type
) == ARRAY_TYPE
346 && TYPE_MAX_VALUE (TYPE_DOMAIN (type
)) != NULL_TREE
347 && integer_zerop (TYPE_MAX_VALUE (TYPE_DOMAIN (type
))))
349 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
)))
350 span
= gfc_conv_descriptor_span_get (decl
);
354 /* Likewise for class array or pointer array references. */
355 else if (TREE_CODE (decl
) == FIELD_DECL
356 || VAR_OR_FUNCTION_DECL_P (decl
)
357 || TREE_CODE (decl
) == PARM_DECL
)
359 if (GFC_DECL_CLASS (decl
))
361 /* When a temporary is in place for the class array, then the
362 original class' declaration is stored in the saved
364 if (DECL_LANG_SPECIFIC (decl
) && GFC_DECL_SAVED_DESCRIPTOR (decl
))
365 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
368 /* Allow for dummy arguments and other good things. */
369 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
370 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
372 /* Check if '_data' is an array descriptor. If it is not,
373 the array must be one of the components of the class
374 object, so return a null span. */
375 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (
376 gfc_class_data_get (decl
))))
379 span
= gfc_class_vtab_size_get (decl
);
381 else if (GFC_DECL_PTR_ARRAY_P (decl
))
383 if (TREE_CODE (decl
) == PARM_DECL
)
384 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
385 span
= gfc_conv_descriptor_span_get (decl
);
397 /* Build an ARRAY_REF with its natural type. */
400 gfc_build_array_ref (tree base
, tree offset
, tree decl
, tree vptr
)
402 tree type
= TREE_TYPE (base
);
404 tree span
= NULL_TREE
;
406 if (GFC_ARRAY_TYPE_P (type
) && GFC_TYPE_ARRAY_RANK (type
) == 0)
408 gcc_assert (GFC_TYPE_ARRAY_CORANK (type
) > 0);
410 return fold_convert (TYPE_MAIN_VARIANT (type
), base
);
413 /* Scalar coarray, there is nothing to do. */
414 if (TREE_CODE (type
) != ARRAY_TYPE
)
416 gcc_assert (decl
== NULL_TREE
);
417 gcc_assert (integer_zerop (offset
));
421 type
= TREE_TYPE (type
);
424 TREE_ADDRESSABLE (base
) = 1;
426 /* Strip NON_LVALUE_EXPR nodes. */
427 STRIP_TYPE_NOPS (offset
);
429 /* If decl or vptr are non-null, pointer arithmetic for the array reference
430 is likely. Generate the 'span' for the array reference. */
432 span
= gfc_vptr_size_get (vptr
);
434 span
= get_array_span (type
, decl
);
436 /* If a non-null span has been generated reference the element with
437 pointer arithmetic. */
438 if (span
!= NULL_TREE
)
440 offset
= fold_build2_loc (input_location
, MULT_EXPR
,
441 gfc_array_index_type
,
443 tmp
= gfc_build_addr_expr (pvoid_type_node
, base
);
444 tmp
= fold_build_pointer_plus_loc (input_location
, tmp
, offset
);
445 tmp
= fold_convert (build_pointer_type (type
), tmp
);
446 if ((TREE_CODE (type
) != INTEGER_TYPE
&& TREE_CODE (type
) != ARRAY_TYPE
)
447 || !TYPE_STRING_FLAG (type
))
448 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
451 /* Otherwise use a straightforward array reference. */
453 return build4_loc (input_location
, ARRAY_REF
, type
, base
, offset
,
454 NULL_TREE
, NULL_TREE
);
458 /* Generate a call to print a runtime error possibly including multiple
459 arguments and a locus. */
462 trans_runtime_error_vararg (tree errorfunc
, locus
* where
, const char* msgid
,
475 /* Compute the number of extra arguments from the format string. */
476 for (p
= msgid
, nargs
= 0; *p
; p
++)
484 /* The code to generate the error. */
485 gfc_start_block (&block
);
489 line
= LOCATION_LINE (where
->lb
->location
);
490 message
= xasprintf ("At line %d of file %s", line
,
491 where
->lb
->file
->filename
);
494 message
= xasprintf ("In file '%s', around line %d",
495 gfc_source_file
, LOCATION_LINE (input_location
) + 1);
497 arg
= gfc_build_addr_expr (pchar_type_node
,
498 gfc_build_localized_cstring_const (message
));
501 message
= xasprintf ("%s", _(msgid
));
502 arg2
= gfc_build_addr_expr (pchar_type_node
,
503 gfc_build_localized_cstring_const (message
));
506 /* Build the argument array. */
507 argarray
= XALLOCAVEC (tree
, nargs
+ 2);
510 for (i
= 0; i
< nargs
; i
++)
511 argarray
[2 + i
] = va_arg (ap
, tree
);
513 /* Build the function call to runtime_(warning,error)_at; because of the
514 variable number of arguments, we can't use build_call_expr_loc dinput_location,
516 fntype
= TREE_TYPE (errorfunc
);
518 loc
= where
? gfc_get_location (where
) : input_location
;
519 tmp
= fold_build_call_array_loc (loc
, TREE_TYPE (fntype
),
520 fold_build1_loc (loc
, ADDR_EXPR
,
521 build_pointer_type (fntype
),
523 nargs
+ 2, argarray
);
524 gfc_add_expr_to_block (&block
, tmp
);
526 return gfc_finish_block (&block
);
531 gfc_trans_runtime_error (bool error
, locus
* where
, const char* msgid
, ...)
536 va_start (ap
, msgid
);
537 result
= trans_runtime_error_vararg (error
538 ? gfor_fndecl_runtime_error_at
539 : gfor_fndecl_runtime_warning_at
,
546 /* Generate a runtime error if COND is true. */
549 gfc_trans_runtime_check (bool error
, bool once
, tree cond
, stmtblock_t
* pblock
,
550 locus
* where
, const char * msgid
, ...)
558 if (integer_zerop (cond
))
563 tmpvar
= gfc_create_var (logical_type_node
, "print_warning");
564 TREE_STATIC (tmpvar
) = 1;
565 DECL_INITIAL (tmpvar
) = logical_true_node
;
566 gfc_add_expr_to_block (pblock
, tmpvar
);
569 gfc_start_block (&block
);
571 /* For error, runtime_error_at already implies PRED_NORETURN. */
573 gfc_add_expr_to_block (&block
, build_predict_expr (PRED_FORTRAN_WARN_ONCE
,
576 /* The code to generate the error. */
577 va_start (ap
, msgid
);
578 gfc_add_expr_to_block (&block
,
579 trans_runtime_error_vararg
580 (error
? gfor_fndecl_runtime_error_at
581 : gfor_fndecl_runtime_warning_at
,
586 gfc_add_modify (&block
, tmpvar
, logical_false_node
);
588 body
= gfc_finish_block (&block
);
590 if (integer_onep (cond
))
592 gfc_add_expr_to_block (pblock
, body
);
597 cond
= fold_build2_loc (gfc_get_location (where
), TRUTH_AND_EXPR
,
598 long_integer_type_node
, tmpvar
, cond
);
600 cond
= fold_convert (long_integer_type_node
, cond
);
602 tmp
= fold_build3_loc (gfc_get_location (where
), COND_EXPR
, void_type_node
,
604 build_empty_stmt (gfc_get_location (where
)));
605 gfc_add_expr_to_block (pblock
, tmp
);
611 trans_os_error_at (locus
* where
, const char* msgid
, ...)
616 va_start (ap
, msgid
);
617 result
= trans_runtime_error_vararg (gfor_fndecl_os_error_at
,
625 /* Call malloc to allocate size bytes of memory, with special conditions:
626 + if size == 0, return a malloced area of size 1,
627 + if malloc returns NULL, issue a runtime error. */
629 gfc_call_malloc (stmtblock_t
* block
, tree type
, tree size
)
631 tree tmp
, malloc_result
, null_result
, res
, malloc_tree
;
634 /* Create a variable to hold the result. */
635 res
= gfc_create_var (prvoid_type_node
, NULL
);
638 gfc_start_block (&block2
);
640 size
= fold_convert (size_type_node
, size
);
641 size
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
, size
,
642 build_int_cst (size_type_node
, 1));
644 malloc_tree
= builtin_decl_explicit (BUILT_IN_MALLOC
);
645 gfc_add_modify (&block2
, res
,
646 fold_convert (prvoid_type_node
,
647 build_call_expr_loc (input_location
,
648 malloc_tree
, 1, size
)));
650 /* Optionally check whether malloc was successful. */
651 if (gfc_option
.rtcheck
& GFC_RTCHECK_MEM
)
653 null_result
= fold_build2_loc (input_location
, EQ_EXPR
,
654 logical_type_node
, res
,
655 build_int_cst (pvoid_type_node
, 0));
656 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
658 trans_os_error_at (NULL
,
659 "Error allocating %lu bytes",
661 (long_unsigned_type_node
,
663 build_empty_stmt (input_location
));
664 gfc_add_expr_to_block (&block2
, tmp
);
667 malloc_result
= gfc_finish_block (&block2
);
668 gfc_add_expr_to_block (block
, malloc_result
);
671 res
= fold_convert (type
, res
);
676 /* Allocate memory, using an optional status argument.
678 This function follows the following pseudo-code:
681 allocate (size_t size, integer_type stat)
688 newmem = malloc (MAX (size, 1));
692 *stat = LIBERROR_ALLOCATION;
694 runtime_error ("Allocation would exceed memory limit");
699 gfc_allocate_using_malloc (stmtblock_t
* block
, tree pointer
,
700 tree size
, tree status
)
702 tree tmp
, error_cond
;
703 stmtblock_t on_error
;
704 tree status_type
= status
? TREE_TYPE (status
) : NULL_TREE
;
706 /* If successful and stat= is given, set status to 0. */
707 if (status
!= NULL_TREE
)
708 gfc_add_expr_to_block (block
,
709 fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
710 status
, build_int_cst (status_type
, 0)));
712 /* The allocation itself. */
713 size
= fold_convert (size_type_node
, size
);
714 gfc_add_modify (block
, pointer
,
715 fold_convert (TREE_TYPE (pointer
),
716 build_call_expr_loc (input_location
,
717 builtin_decl_explicit (BUILT_IN_MALLOC
), 1,
718 fold_build2_loc (input_location
,
719 MAX_EXPR
, size_type_node
, size
,
720 build_int_cst (size_type_node
, 1)))));
722 /* What to do in case of error. */
723 gfc_start_block (&on_error
);
724 if (status
!= NULL_TREE
)
726 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
, status
,
727 build_int_cst (status_type
, LIBERROR_ALLOCATION
));
728 gfc_add_expr_to_block (&on_error
, tmp
);
732 /* Here, os_error_at already implies PRED_NORETURN. */
733 tree lusize
= fold_convert (long_unsigned_type_node
, size
);
734 tmp
= trans_os_error_at (NULL
, "Error allocating %lu bytes", lusize
);
735 gfc_add_expr_to_block (&on_error
, tmp
);
738 error_cond
= fold_build2_loc (input_location
, EQ_EXPR
,
739 logical_type_node
, pointer
,
740 build_int_cst (prvoid_type_node
, 0));
741 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
742 gfc_unlikely (error_cond
, PRED_FORTRAN_FAIL_ALLOC
),
743 gfc_finish_block (&on_error
),
744 build_empty_stmt (input_location
));
746 gfc_add_expr_to_block (block
, tmp
);
750 /* Allocate memory, using an optional status argument.
752 This function follows the following pseudo-code:
755 allocate (size_t size, void** token, int *stat, char* errmsg, int errlen)
759 newmem = _caf_register (size, regtype, token, &stat, errmsg, errlen);
763 gfc_allocate_using_caf_lib (stmtblock_t
* block
, tree pointer
, tree size
,
764 tree token
, tree status
, tree errmsg
, tree errlen
,
765 gfc_coarray_regtype alloc_type
)
769 gcc_assert (token
!= NULL_TREE
);
771 /* The allocation itself. */
772 if (status
== NULL_TREE
)
773 pstat
= null_pointer_node
;
775 pstat
= gfc_build_addr_expr (NULL_TREE
, status
);
777 if (errmsg
== NULL_TREE
)
779 gcc_assert(errlen
== NULL_TREE
);
780 errmsg
= null_pointer_node
;
781 errlen
= build_int_cst (integer_type_node
, 0);
784 size
= fold_convert (size_type_node
, size
);
785 tmp
= build_call_expr_loc (input_location
,
786 gfor_fndecl_caf_register
, 7,
787 fold_build2_loc (input_location
,
788 MAX_EXPR
, size_type_node
, size
, size_one_node
),
789 build_int_cst (integer_type_node
, alloc_type
),
790 token
, gfc_build_addr_expr (pvoid_type_node
, pointer
),
791 pstat
, errmsg
, errlen
);
793 gfc_add_expr_to_block (block
, tmp
);
795 /* It guarantees memory consistency within the same segment */
796 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
797 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
798 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
799 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
800 ASM_VOLATILE_P (tmp
) = 1;
801 gfc_add_expr_to_block (block
, tmp
);
805 /* Generate code for an ALLOCATE statement when the argument is an
806 allocatable variable. If the variable is currently allocated, it is an
807 error to allocate it again.
809 This function follows the following pseudo-code:
812 allocate_allocatable (void *mem, size_t size, integer_type stat)
815 return allocate (size, stat);
819 stat = LIBERROR_ALLOCATION;
821 runtime_error ("Attempting to allocate already allocated variable");
825 expr must be set to the original expression being allocated for its locus
826 and variable name in case a runtime error has to be printed. */
828 gfc_allocate_allocatable (stmtblock_t
* block
, tree mem
, tree size
,
829 tree token
, tree status
, tree errmsg
, tree errlen
,
830 tree label_finish
, gfc_expr
* expr
, int corank
)
832 stmtblock_t alloc_block
;
833 tree tmp
, null_mem
, alloc
, error
;
834 tree type
= TREE_TYPE (mem
);
835 symbol_attribute caf_attr
;
836 bool need_assign
= false, refs_comp
= false;
837 gfc_coarray_regtype caf_alloc_type
= GFC_CAF_COARRAY_ALLOC
;
839 size
= fold_convert (size_type_node
, size
);
840 null_mem
= gfc_unlikely (fold_build2_loc (input_location
, NE_EXPR
,
841 logical_type_node
, mem
,
842 build_int_cst (type
, 0)),
843 PRED_FORTRAN_REALLOC
);
845 /* If mem is NULL, we call gfc_allocate_using_malloc or
846 gfc_allocate_using_lib. */
847 gfc_start_block (&alloc_block
);
849 if (flag_coarray
== GFC_FCOARRAY_LIB
)
850 caf_attr
= gfc_caf_attr (expr
, true, &refs_comp
);
852 if (flag_coarray
== GFC_FCOARRAY_LIB
853 && (corank
> 0 || caf_attr
.codimension
))
855 tree cond
, sub_caf_tree
;
857 bool compute_special_caf_types_size
= false;
859 if (expr
->ts
.type
== BT_DERIVED
860 && expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
861 && expr
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
863 compute_special_caf_types_size
= true;
864 caf_alloc_type
= GFC_CAF_LOCK_ALLOC
;
866 else if (expr
->ts
.type
== BT_DERIVED
867 && expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
868 && expr
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
870 compute_special_caf_types_size
= true;
871 caf_alloc_type
= GFC_CAF_EVENT_ALLOC
;
873 else if (!caf_attr
.coarray_comp
&& refs_comp
)
874 /* Only allocatable components in a derived type coarray can be
876 caf_alloc_type
= GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY
;
878 gfc_init_se (&se
, NULL
);
879 sub_caf_tree
= gfc_get_ultimate_alloc_ptr_comps_caf_token (&se
, expr
);
880 if (sub_caf_tree
== NULL_TREE
)
881 sub_caf_tree
= token
;
883 /* When mem is an array ref, then strip the .data-ref. */
884 if (TREE_CODE (mem
) == COMPONENT_REF
885 && !(GFC_ARRAY_TYPE_P (TREE_TYPE (mem
))))
886 tmp
= TREE_OPERAND (mem
, 0);
890 if (!(GFC_ARRAY_TYPE_P (TREE_TYPE (tmp
))
891 && TYPE_LANG_SPECIFIC (TREE_TYPE (tmp
))->corank
== 0)
892 && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)))
894 symbol_attribute attr
;
896 gfc_clear_attr (&attr
);
897 tmp
= gfc_conv_scalar_to_descriptor (&se
, mem
, attr
);
900 gfc_add_block_to_block (&alloc_block
, &se
.pre
);
902 /* In the front end, we represent the lock variable as pointer. However,
903 the FE only passes the pointer around and leaves the actual
904 representation to the library. Hence, we have to convert back to the
905 number of elements. */
906 if (compute_special_caf_types_size
)
907 size
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, size_type_node
,
908 size
, TYPE_SIZE_UNIT (ptr_type_node
));
910 gfc_allocate_using_caf_lib (&alloc_block
, tmp
, size
, sub_caf_tree
,
911 status
, errmsg
, errlen
, caf_alloc_type
);
913 gfc_add_modify (&alloc_block
, mem
, fold_convert (TREE_TYPE (mem
),
914 gfc_conv_descriptor_data_get (tmp
)));
915 if (status
!= NULL_TREE
)
917 TREE_USED (label_finish
) = 1;
918 tmp
= build1_v (GOTO_EXPR
, label_finish
);
919 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
920 status
, build_zero_cst (TREE_TYPE (status
)));
921 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
922 gfc_unlikely (cond
, PRED_FORTRAN_FAIL_ALLOC
),
923 tmp
, build_empty_stmt (input_location
));
924 gfc_add_expr_to_block (&alloc_block
, tmp
);
928 gfc_allocate_using_malloc (&alloc_block
, mem
, size
, status
);
930 alloc
= gfc_finish_block (&alloc_block
);
932 /* If mem is not NULL, we issue a runtime error or set the
938 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
&& expr
->symtree
);
939 varname
= gfc_build_cstring_const (expr
->symtree
->name
);
940 varname
= gfc_build_addr_expr (pchar_type_node
, varname
);
942 error
= gfc_trans_runtime_error (true, &expr
->where
,
943 "Attempting to allocate already"
944 " allocated variable '%s'",
948 error
= gfc_trans_runtime_error (true, NULL
,
949 "Attempting to allocate already allocated"
952 if (status
!= NULL_TREE
)
954 tree status_type
= TREE_TYPE (status
);
956 error
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
957 status
, build_int_cst (status_type
, LIBERROR_ALLOCATION
));
960 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, null_mem
,
962 gfc_add_expr_to_block (block
, tmp
);
966 /* Free a given variable. */
969 gfc_call_free (tree var
)
971 return build_call_expr_loc (input_location
,
972 builtin_decl_explicit (BUILT_IN_FREE
),
973 1, fold_convert (pvoid_type_node
, var
));
977 /* Build a call to a FINAL procedure, which finalizes "var". */
980 gfc_build_final_call (gfc_typespec ts
, gfc_expr
*final_wrapper
, gfc_expr
*var
,
981 bool fini_coarray
, gfc_expr
*class_size
)
985 tree final_fndecl
, array
, size
, tmp
;
986 symbol_attribute attr
;
988 gcc_assert (final_wrapper
->expr_type
== EXPR_VARIABLE
);
991 gfc_start_block (&block
);
992 gfc_init_se (&se
, NULL
);
993 gfc_conv_expr (&se
, final_wrapper
);
994 final_fndecl
= se
.expr
;
995 if (POINTER_TYPE_P (TREE_TYPE (final_fndecl
)))
996 final_fndecl
= build_fold_indirect_ref_loc (input_location
, final_fndecl
);
998 if (ts
.type
== BT_DERIVED
)
1002 gcc_assert (!class_size
);
1003 elem_size
= gfc_typenode_for_spec (&ts
);
1004 elem_size
= TYPE_SIZE_UNIT (elem_size
);
1005 size
= fold_convert (gfc_array_index_type
, elem_size
);
1007 gfc_init_se (&se
, NULL
);
1008 se
.want_pointer
= 1;
1011 se
.descriptor_only
= 1;
1012 gfc_conv_expr_descriptor (&se
, var
);
1017 gfc_conv_expr (&se
, var
);
1018 gcc_assert (se
.pre
.head
== NULL_TREE
&& se
.post
.head
== NULL_TREE
);
1021 /* No copy back needed, hence set attr's allocatable/pointer
1023 gfc_clear_attr (&attr
);
1024 gfc_init_se (&se
, NULL
);
1025 array
= gfc_conv_scalar_to_descriptor (&se
, array
, attr
);
1026 gcc_assert (se
.post
.head
== NULL_TREE
);
1031 gfc_expr
*array_expr
;
1032 gcc_assert (class_size
);
1033 gfc_init_se (&se
, NULL
);
1034 gfc_conv_expr (&se
, class_size
);
1035 gfc_add_block_to_block (&block
, &se
.pre
);
1036 gcc_assert (se
.post
.head
== NULL_TREE
);
1039 array_expr
= gfc_copy_expr (var
);
1040 gfc_init_se (&se
, NULL
);
1041 se
.want_pointer
= 1;
1042 if (array_expr
->rank
)
1044 gfc_add_class_array_ref (array_expr
);
1045 se
.descriptor_only
= 1;
1046 gfc_conv_expr_descriptor (&se
, array_expr
);
1051 gfc_add_data_component (array_expr
);
1052 gfc_conv_expr (&se
, array_expr
);
1053 gfc_add_block_to_block (&block
, &se
.pre
);
1054 gcc_assert (se
.post
.head
== NULL_TREE
);
1057 if (!gfc_is_coarray (array_expr
))
1059 /* No copy back needed, hence set attr's allocatable/pointer
1061 gfc_clear_attr (&attr
);
1062 gfc_init_se (&se
, NULL
);
1063 array
= gfc_conv_scalar_to_descriptor (&se
, array
, attr
);
1065 gcc_assert (se
.post
.head
== NULL_TREE
);
1067 gfc_free_expr (array_expr
);
1070 if (!POINTER_TYPE_P (TREE_TYPE (array
)))
1071 array
= gfc_build_addr_expr (NULL
, array
);
1073 gfc_add_block_to_block (&block
, &se
.pre
);
1074 tmp
= build_call_expr_loc (input_location
,
1075 final_fndecl
, 3, array
,
1076 size
, fini_coarray
? boolean_true_node
1077 : boolean_false_node
);
1078 gfc_add_block_to_block (&block
, &se
.post
);
1079 gfc_add_expr_to_block (&block
, tmp
);
1080 return gfc_finish_block (&block
);
1085 gfc_add_comp_finalizer_call (stmtblock_t
*block
, tree decl
, gfc_component
*comp
,
1090 tree final_fndecl
, size
, array
, tmp
, cond
;
1091 symbol_attribute attr
;
1092 gfc_expr
*final_expr
= NULL
;
1094 if (comp
->ts
.type
!= BT_DERIVED
&& comp
->ts
.type
!= BT_CLASS
)
1097 gfc_init_block (&block2
);
1099 if (comp
->ts
.type
== BT_DERIVED
)
1101 if (comp
->attr
.pointer
)
1104 gfc_is_finalizable (comp
->ts
.u
.derived
, &final_expr
);
1108 gfc_init_se (&se
, NULL
);
1109 gfc_conv_expr (&se
, final_expr
);
1110 final_fndecl
= se
.expr
;
1111 size
= gfc_typenode_for_spec (&comp
->ts
);
1112 size
= TYPE_SIZE_UNIT (size
);
1113 size
= fold_convert (gfc_array_index_type
, size
);
1117 else /* comp->ts.type == BT_CLASS. */
1119 if (CLASS_DATA (comp
)->attr
.class_pointer
)
1122 gfc_is_finalizable (CLASS_DATA (comp
)->ts
.u
.derived
, &final_expr
);
1123 final_fndecl
= gfc_class_vtab_final_get (decl
);
1124 size
= gfc_class_vtab_size_get (decl
);
1125 array
= gfc_class_data_get (decl
);
1128 if (comp
->attr
.allocatable
1129 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)->attr
.allocatable
))
1131 tmp
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array
))
1132 ? gfc_conv_descriptor_data_get (array
) : array
;
1133 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
1134 tmp
, fold_convert (TREE_TYPE (tmp
),
1135 null_pointer_node
));
1138 cond
= logical_true_node
;
1140 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array
)))
1142 gfc_clear_attr (&attr
);
1143 gfc_init_se (&se
, NULL
);
1144 array
= gfc_conv_scalar_to_descriptor (&se
, array
, attr
);
1145 gfc_add_block_to_block (&block2
, &se
.pre
);
1146 gcc_assert (se
.post
.head
== NULL_TREE
);
1149 if (!POINTER_TYPE_P (TREE_TYPE (array
)))
1150 array
= gfc_build_addr_expr (NULL
, array
);
1154 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
1156 fold_convert (TREE_TYPE (final_fndecl
),
1157 null_pointer_node
));
1158 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1159 logical_type_node
, cond
, tmp
);
1162 if (POINTER_TYPE_P (TREE_TYPE (final_fndecl
)))
1163 final_fndecl
= build_fold_indirect_ref_loc (input_location
, final_fndecl
);
1165 tmp
= build_call_expr_loc (input_location
,
1166 final_fndecl
, 3, array
,
1167 size
, fini_coarray
? boolean_true_node
1168 : boolean_false_node
);
1169 gfc_add_expr_to_block (&block2
, tmp
);
1170 tmp
= gfc_finish_block (&block2
);
1172 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
1173 build_empty_stmt (input_location
));
1174 gfc_add_expr_to_block (block
, tmp
);
1180 /* Add a call to the finalizer, using the passed *expr. Returns
1181 true when a finalizer call has been inserted. */
1184 gfc_add_finalizer_call (stmtblock_t
*block
, gfc_expr
*expr2
)
1189 gfc_expr
*final_expr
= NULL
;
1190 gfc_expr
*elem_size
= NULL
;
1191 bool has_finalizer
= false;
1193 if (!expr2
|| (expr2
->ts
.type
!= BT_DERIVED
&& expr2
->ts
.type
!= BT_CLASS
))
1196 if (expr2
->ts
.type
== BT_DERIVED
)
1198 gfc_is_finalizable (expr2
->ts
.u
.derived
, &final_expr
);
1203 /* If we have a class array, we need go back to the class
1205 expr
= gfc_copy_expr (expr2
);
1207 if (expr
->ref
&& expr
->ref
->next
&& !expr
->ref
->next
->next
1208 && expr
->ref
->next
->type
== REF_ARRAY
1209 && expr
->ref
->type
== REF_COMPONENT
1210 && strcmp (expr
->ref
->u
.c
.component
->name
, "_data") == 0)
1212 gfc_free_ref_list (expr
->ref
);
1216 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1217 if (ref
->next
&& ref
->next
->next
&& !ref
->next
->next
->next
1218 && ref
->next
->next
->type
== REF_ARRAY
1219 && ref
->next
->type
== REF_COMPONENT
1220 && strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0)
1222 gfc_free_ref_list (ref
->next
);
1226 if (expr
->ts
.type
== BT_CLASS
)
1228 has_finalizer
= gfc_is_finalizable (expr
->ts
.u
.derived
, NULL
);
1230 if (!expr2
->rank
&& !expr2
->ref
&& CLASS_DATA (expr2
->symtree
->n
.sym
)->as
)
1231 expr
->rank
= CLASS_DATA (expr2
->symtree
->n
.sym
)->as
->rank
;
1233 final_expr
= gfc_copy_expr (expr
);
1234 gfc_add_vptr_component (final_expr
);
1235 gfc_add_final_component (final_expr
);
1237 elem_size
= gfc_copy_expr (expr
);
1238 gfc_add_vptr_component (elem_size
);
1239 gfc_add_size_component (elem_size
);
1242 gcc_assert (final_expr
->expr_type
== EXPR_VARIABLE
);
1244 tmp
= gfc_build_final_call (expr
->ts
, final_expr
, expr
,
1247 if (expr
->ts
.type
== BT_CLASS
&& !has_finalizer
)
1252 gfc_init_se (&se
, NULL
);
1253 se
.want_pointer
= 1;
1254 gfc_conv_expr (&se
, final_expr
);
1255 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
1256 se
.expr
, build_int_cst (TREE_TYPE (se
.expr
), 0));
1258 /* For CLASS(*) not only sym->_vtab->_final can be NULL
1259 but already sym->_vtab itself. */
1260 if (UNLIMITED_POLY (expr
))
1263 gfc_expr
*vptr_expr
;
1265 vptr_expr
= gfc_copy_expr (expr
);
1266 gfc_add_vptr_component (vptr_expr
);
1268 gfc_init_se (&se
, NULL
);
1269 se
.want_pointer
= 1;
1270 gfc_conv_expr (&se
, vptr_expr
);
1271 gfc_free_expr (vptr_expr
);
1273 cond2
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
1275 build_int_cst (TREE_TYPE (se
.expr
), 0));
1276 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1277 logical_type_node
, cond2
, cond
);
1280 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1281 cond
, tmp
, build_empty_stmt (input_location
));
1284 gfc_add_expr_to_block (block
, tmp
);
1290 /* User-deallocate; we emit the code directly from the front-end, and the
1291 logic is the same as the previous library function:
1294 deallocate (void *pointer, GFC_INTEGER_4 * stat)
1301 runtime_error ("Attempt to DEALLOCATE unallocated memory.");
1311 In this front-end version, status doesn't have to be GFC_INTEGER_4.
1312 Moreover, if CAN_FAIL is true, then we will not emit a runtime error,
1313 even when no status variable is passed to us (this is used for
1314 unconditional deallocation generated by the front-end at end of
1317 If a runtime-message is possible, `expr' must point to the original
1318 expression being deallocated for its locus and variable name.
1320 For coarrays, "pointer" must be the array descriptor and not its
1323 COARRAY_DEALLOC_MODE gives the mode unregister coarrays. Available modes are
1324 the ones of GFC_CAF_DEREGTYPE, -1 when the mode for deregistration is to be
1325 analyzed and set by this routine, and -2 to indicate that a non-coarray is to
1328 gfc_deallocate_with_status (tree pointer
, tree status
, tree errmsg
,
1329 tree errlen
, tree label_finish
,
1330 bool can_fail
, gfc_expr
* expr
,
1331 int coarray_dealloc_mode
, tree add_when_allocated
,
1334 stmtblock_t null
, non_null
;
1335 tree cond
, tmp
, error
;
1336 tree status_type
= NULL_TREE
;
1337 tree token
= NULL_TREE
;
1338 gfc_coarray_deregtype caf_dereg_type
= GFC_CAF_COARRAY_DEREGISTER
;
1340 if (coarray_dealloc_mode
>= GFC_CAF_COARRAY_ANALYZE
)
1342 if (flag_coarray
== GFC_FCOARRAY_LIB
)
1348 tree caf_type
, caf_decl
= pointer
;
1349 pointer
= gfc_conv_descriptor_data_get (caf_decl
);
1350 caf_type
= TREE_TYPE (caf_decl
);
1351 STRIP_NOPS (pointer
);
1352 if (GFC_DESCRIPTOR_TYPE_P (caf_type
))
1353 token
= gfc_conv_descriptor_token (caf_decl
);
1354 else if (DECL_LANG_SPECIFIC (caf_decl
)
1355 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
1356 token
= GFC_DECL_TOKEN (caf_decl
);
1359 gcc_assert (GFC_ARRAY_TYPE_P (caf_type
)
1360 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
)
1362 token
= GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
);
1366 if (coarray_dealloc_mode
== GFC_CAF_COARRAY_ANALYZE
)
1369 if (expr
&& !gfc_caf_attr (expr
, false, &comp_ref
).coarray_comp
1371 caf_dereg_type
= GFC_CAF_COARRAY_DEALLOCATE_ONLY
;
1372 // else do a deregister as set by default.
1375 caf_dereg_type
= (enum gfc_coarray_deregtype
) coarray_dealloc_mode
;
1377 else if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
1378 pointer
= gfc_conv_descriptor_data_get (pointer
);
1380 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer
)))
1381 pointer
= gfc_conv_descriptor_data_get (pointer
);
1383 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, pointer
,
1384 build_int_cst (TREE_TYPE (pointer
), 0));
1386 /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
1387 we emit a runtime error. */
1388 gfc_start_block (&null
);
1393 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
&& expr
->symtree
);
1395 varname
= gfc_build_cstring_const (expr
->symtree
->name
);
1396 varname
= gfc_build_addr_expr (pchar_type_node
, varname
);
1398 error
= gfc_trans_runtime_error (true, &expr
->where
,
1399 "Attempt to DEALLOCATE unallocated '%s'",
1403 error
= build_empty_stmt (input_location
);
1405 if (status
!= NULL_TREE
&& !integer_zerop (status
))
1409 status_type
= TREE_TYPE (TREE_TYPE (status
));
1410 cond2
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
1411 status
, build_int_cst (TREE_TYPE (status
), 0));
1412 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
1413 fold_build1_loc (input_location
, INDIRECT_REF
,
1414 status_type
, status
),
1415 build_int_cst (status_type
, 1));
1416 error
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1420 gfc_add_expr_to_block (&null
, error
);
1422 /* When POINTER is not NULL, we free it. */
1423 gfc_start_block (&non_null
);
1424 if (add_when_allocated
)
1425 gfc_add_expr_to_block (&non_null
, add_when_allocated
);
1426 gfc_add_finalizer_call (&non_null
, expr
);
1427 if (coarray_dealloc_mode
== GFC_CAF_COARRAY_NOCOARRAY
1428 || flag_coarray
!= GFC_FCOARRAY_LIB
)
1430 tmp
= build_call_expr_loc (input_location
,
1431 builtin_decl_explicit (BUILT_IN_FREE
), 1,
1432 fold_convert (pvoid_type_node
, pointer
));
1433 gfc_add_expr_to_block (&non_null
, tmp
);
1434 gfc_add_modify (&non_null
, pointer
, build_int_cst (TREE_TYPE (pointer
),
1437 if (status
!= NULL_TREE
&& !integer_zerop (status
))
1439 /* We set STATUS to zero if it is present. */
1440 tree status_type
= TREE_TYPE (TREE_TYPE (status
));
1443 cond2
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
1445 build_int_cst (TREE_TYPE (status
), 0));
1446 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
1447 fold_build1_loc (input_location
, INDIRECT_REF
,
1448 status_type
, status
),
1449 build_int_cst (status_type
, 0));
1450 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1451 gfc_unlikely (cond2
, PRED_FORTRAN_FAIL_ALLOC
),
1452 tmp
, build_empty_stmt (input_location
));
1453 gfc_add_expr_to_block (&non_null
, tmp
);
1458 tree cond2
, pstat
= null_pointer_node
;
1460 if (errmsg
== NULL_TREE
)
1462 gcc_assert (errlen
== NULL_TREE
);
1463 errmsg
= null_pointer_node
;
1464 errlen
= build_zero_cst (integer_type_node
);
1468 gcc_assert (errlen
!= NULL_TREE
);
1469 if (!POINTER_TYPE_P (TREE_TYPE (errmsg
)))
1470 errmsg
= gfc_build_addr_expr (NULL_TREE
, errmsg
);
1473 if (status
!= NULL_TREE
&& !integer_zerop (status
))
1475 gcc_assert (status_type
== integer_type_node
);
1479 token
= gfc_build_addr_expr (NULL_TREE
, token
);
1480 gcc_assert (caf_dereg_type
> GFC_CAF_COARRAY_ANALYZE
);
1481 tmp
= build_call_expr_loc (input_location
,
1482 gfor_fndecl_caf_deregister
, 5,
1483 token
, build_int_cst (integer_type_node
,
1485 pstat
, errmsg
, errlen
);
1486 gfc_add_expr_to_block (&non_null
, tmp
);
1488 /* It guarantees memory consistency within the same segment */
1489 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
1490 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1491 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
1492 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
1493 ASM_VOLATILE_P (tmp
) = 1;
1494 gfc_add_expr_to_block (&non_null
, tmp
);
1496 if (status
!= NULL_TREE
)
1498 tree stat
= build_fold_indirect_ref_loc (input_location
, status
);
1499 tree nullify
= fold_build2_loc (input_location
, MODIFY_EXPR
,
1500 void_type_node
, pointer
,
1501 build_int_cst (TREE_TYPE (pointer
),
1504 TREE_USED (label_finish
) = 1;
1505 tmp
= build1_v (GOTO_EXPR
, label_finish
);
1506 cond2
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
1507 stat
, build_zero_cst (TREE_TYPE (stat
)));
1508 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1509 gfc_unlikely (cond2
, PRED_FORTRAN_REALLOC
),
1511 gfc_add_expr_to_block (&non_null
, tmp
);
1514 gfc_add_modify (&non_null
, pointer
, build_int_cst (TREE_TYPE (pointer
),
1518 return fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
1519 gfc_finish_block (&null
),
1520 gfc_finish_block (&non_null
));
1524 /* Generate code for deallocation of allocatable scalars (variables or
1525 components). Before the object itself is freed, any allocatable
1526 subcomponents are being deallocated. */
1529 gfc_deallocate_scalar_with_status (tree pointer
, tree status
, tree label_finish
,
1530 bool can_fail
, gfc_expr
* expr
,
1531 gfc_typespec ts
, bool coarray
)
1533 stmtblock_t null
, non_null
;
1534 tree cond
, tmp
, error
;
1535 bool finalizable
, comp_ref
;
1536 gfc_coarray_deregtype caf_dereg_type
= GFC_CAF_COARRAY_DEREGISTER
;
1538 if (coarray
&& expr
&& !gfc_caf_attr (expr
, false, &comp_ref
).coarray_comp
1540 caf_dereg_type
= GFC_CAF_COARRAY_DEALLOCATE_ONLY
;
1542 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, pointer
,
1543 build_int_cst (TREE_TYPE (pointer
), 0));
1545 /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
1546 we emit a runtime error. */
1547 gfc_start_block (&null
);
1552 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
&& expr
->symtree
);
1554 varname
= gfc_build_cstring_const (expr
->symtree
->name
);
1555 varname
= gfc_build_addr_expr (pchar_type_node
, varname
);
1557 error
= gfc_trans_runtime_error (true, &expr
->where
,
1558 "Attempt to DEALLOCATE unallocated '%s'",
1562 error
= build_empty_stmt (input_location
);
1564 if (status
!= NULL_TREE
&& !integer_zerop (status
))
1566 tree status_type
= TREE_TYPE (TREE_TYPE (status
));
1569 cond2
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
1570 status
, build_int_cst (TREE_TYPE (status
), 0));
1571 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
1572 fold_build1_loc (input_location
, INDIRECT_REF
,
1573 status_type
, status
),
1574 build_int_cst (status_type
, 1));
1575 error
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1578 gfc_add_expr_to_block (&null
, error
);
1580 /* When POINTER is not NULL, we free it. */
1581 gfc_start_block (&non_null
);
1583 /* Free allocatable components. */
1584 finalizable
= gfc_add_finalizer_call (&non_null
, expr
);
1585 if (!finalizable
&& ts
.type
== BT_DERIVED
&& ts
.u
.derived
->attr
.alloc_comp
)
1587 int caf_mode
= coarray
1588 ? ((caf_dereg_type
== GFC_CAF_COARRAY_DEALLOCATE_ONLY
1589 ? GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY
: 0)
1590 | GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
1591 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY
)
1593 if (coarray
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer
)))
1594 tmp
= gfc_conv_descriptor_data_get (pointer
);
1596 tmp
= build_fold_indirect_ref_loc (input_location
, pointer
);
1597 tmp
= gfc_deallocate_alloc_comp (ts
.u
.derived
, tmp
, 0, caf_mode
);
1598 gfc_add_expr_to_block (&non_null
, tmp
);
1601 if (!coarray
|| flag_coarray
== GFC_FCOARRAY_SINGLE
)
1603 tmp
= build_call_expr_loc (input_location
,
1604 builtin_decl_explicit (BUILT_IN_FREE
), 1,
1605 fold_convert (pvoid_type_node
, pointer
));
1606 gfc_add_expr_to_block (&non_null
, tmp
);
1608 if (status
!= NULL_TREE
&& !integer_zerop (status
))
1610 /* We set STATUS to zero if it is present. */
1611 tree status_type
= TREE_TYPE (TREE_TYPE (status
));
1614 cond2
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
1616 build_int_cst (TREE_TYPE (status
), 0));
1617 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
1618 fold_build1_loc (input_location
, INDIRECT_REF
,
1619 status_type
, status
),
1620 build_int_cst (status_type
, 0));
1621 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1622 cond2
, tmp
, build_empty_stmt (input_location
));
1623 gfc_add_expr_to_block (&non_null
, tmp
);
1629 tree pstat
= null_pointer_node
;
1632 gfc_init_se (&se
, NULL
);
1633 token
= gfc_get_ultimate_alloc_ptr_comps_caf_token (&se
, expr
);
1634 gcc_assert (token
!= NULL_TREE
);
1636 if (status
!= NULL_TREE
&& !integer_zerop (status
))
1638 gcc_assert (TREE_TYPE (TREE_TYPE (status
)) == integer_type_node
);
1642 tmp
= build_call_expr_loc (input_location
,
1643 gfor_fndecl_caf_deregister
, 5,
1644 token
, build_int_cst (integer_type_node
,
1646 pstat
, null_pointer_node
, integer_zero_node
);
1647 gfc_add_expr_to_block (&non_null
, tmp
);
1649 /* It guarantees memory consistency within the same segment. */
1650 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory");
1651 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1652 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
1653 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
1654 ASM_VOLATILE_P (tmp
) = 1;
1655 gfc_add_expr_to_block (&non_null
, tmp
);
1657 if (status
!= NULL_TREE
)
1659 tree stat
= build_fold_indirect_ref_loc (input_location
, status
);
1662 TREE_USED (label_finish
) = 1;
1663 tmp
= build1_v (GOTO_EXPR
, label_finish
);
1664 cond2
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
1665 stat
, build_zero_cst (TREE_TYPE (stat
)));
1666 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1667 gfc_unlikely (cond2
, PRED_FORTRAN_REALLOC
),
1668 tmp
, build_empty_stmt (input_location
));
1669 gfc_add_expr_to_block (&non_null
, tmp
);
1673 return fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
1674 gfc_finish_block (&null
),
1675 gfc_finish_block (&non_null
));
1678 /* Reallocate MEM so it has SIZE bytes of data. This behaves like the
1679 following pseudo-code:
1682 internal_realloc (void *mem, size_t size)
1684 res = realloc (mem, size);
1685 if (!res && size != 0)
1686 _gfortran_os_error ("Allocation would exceed memory limit");
1691 gfc_call_realloc (stmtblock_t
* block
, tree mem
, tree size
)
1693 tree res
, nonzero
, null_result
, tmp
;
1694 tree type
= TREE_TYPE (mem
);
1696 /* Only evaluate the size once. */
1697 size
= save_expr (fold_convert (size_type_node
, size
));
1699 /* Create a variable to hold the result. */
1700 res
= gfc_create_var (type
, NULL
);
1702 /* Call realloc and check the result. */
1703 tmp
= build_call_expr_loc (input_location
,
1704 builtin_decl_explicit (BUILT_IN_REALLOC
), 2,
1705 fold_convert (pvoid_type_node
, mem
), size
);
1706 gfc_add_modify (block
, res
, fold_convert (type
, tmp
));
1707 null_result
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
1708 res
, build_int_cst (pvoid_type_node
, 0));
1709 nonzero
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, size
,
1710 build_int_cst (size_type_node
, 0));
1711 null_result
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, logical_type_node
,
1712 null_result
, nonzero
);
1713 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1715 trans_os_error_at (NULL
,
1716 "Error reallocating to %lu bytes",
1718 (long_unsigned_type_node
, size
)),
1719 build_empty_stmt (input_location
));
1720 gfc_add_expr_to_block (block
, tmp
);
1726 /* Add an expression to another one, either at the front or the back. */
1729 add_expr_to_chain (tree
* chain
, tree expr
, bool front
)
1731 if (expr
== NULL_TREE
|| IS_EMPTY_STMT (expr
))
1736 if (TREE_CODE (*chain
) != STATEMENT_LIST
)
1742 append_to_statement_list (tmp
, chain
);
1747 tree_stmt_iterator i
;
1749 i
= tsi_start (*chain
);
1750 tsi_link_before (&i
, expr
, TSI_CONTINUE_LINKING
);
1753 append_to_statement_list (expr
, chain
);
1760 /* Add a statement at the end of a block. */
1763 gfc_add_expr_to_block (stmtblock_t
* block
, tree expr
)
1766 add_expr_to_chain (&block
->head
, expr
, false);
1770 /* Add a statement at the beginning of a block. */
1773 gfc_prepend_expr_to_block (stmtblock_t
* block
, tree expr
)
1776 add_expr_to_chain (&block
->head
, expr
, true);
1780 /* Add a block the end of a block. */
1783 gfc_add_block_to_block (stmtblock_t
* block
, stmtblock_t
* append
)
1785 gcc_assert (append
);
1786 gcc_assert (!append
->has_scope
);
1788 gfc_add_expr_to_block (block
, append
->head
);
1789 append
->head
= NULL_TREE
;
1793 /* Save the current locus. The structure may not be complete, and should
1794 only be used with gfc_restore_backend_locus. */
1797 gfc_save_backend_locus (locus
* loc
)
1799 loc
->lb
= XCNEW (gfc_linebuf
);
1800 loc
->lb
->location
= input_location
;
1801 loc
->lb
->file
= gfc_current_backend_file
;
1805 /* Set the current locus. */
1808 gfc_set_backend_locus (locus
* loc
)
1810 gfc_current_backend_file
= loc
->lb
->file
;
1811 input_location
= loc
->lb
->location
;
1815 /* Restore the saved locus. Only used in conjunction with
1816 gfc_save_backend_locus, to free the memory when we are done. */
1819 gfc_restore_backend_locus (locus
* loc
)
1821 gfc_set_backend_locus (loc
);
1826 /* Translate an executable statement. The tree cond is used by gfc_trans_do.
1827 This static function is wrapped by gfc_trans_code_cond and
1831 trans_code (gfc_code
* code
, tree cond
)
1837 return build_empty_stmt (input_location
);
1839 gfc_start_block (&block
);
1841 /* Translate statements one by one into GENERIC trees until we reach
1842 the end of this gfc_code branch. */
1843 for (; code
; code
= code
->next
)
1845 if (code
->here
!= 0)
1847 res
= gfc_trans_label_here (code
);
1848 gfc_add_expr_to_block (&block
, res
);
1851 gfc_current_locus
= code
->loc
;
1852 gfc_set_backend_locus (&code
->loc
);
1857 case EXEC_END_BLOCK
:
1858 case EXEC_END_NESTED_BLOCK
:
1859 case EXEC_END_PROCEDURE
:
1864 res
= gfc_trans_assign (code
);
1867 case EXEC_LABEL_ASSIGN
:
1868 res
= gfc_trans_label_assign (code
);
1871 case EXEC_POINTER_ASSIGN
:
1872 res
= gfc_trans_pointer_assign (code
);
1875 case EXEC_INIT_ASSIGN
:
1876 if (code
->expr1
->ts
.type
== BT_CLASS
)
1877 res
= gfc_trans_class_init_assign (code
);
1879 res
= gfc_trans_init_assign (code
);
1887 res
= gfc_trans_critical (code
);
1891 res
= gfc_trans_cycle (code
);
1895 res
= gfc_trans_exit (code
);
1899 res
= gfc_trans_goto (code
);
1903 res
= gfc_trans_entry (code
);
1907 res
= gfc_trans_pause (code
);
1911 case EXEC_ERROR_STOP
:
1912 res
= gfc_trans_stop (code
, code
->op
== EXEC_ERROR_STOP
);
1916 /* For MVBITS we've got the special exception that we need a
1917 dependency check, too. */
1919 bool is_mvbits
= false;
1921 if (code
->resolved_isym
)
1923 res
= gfc_conv_intrinsic_subroutine (code
);
1924 if (res
!= NULL_TREE
)
1928 if (code
->resolved_isym
1929 && code
->resolved_isym
->id
== GFC_ISYM_MVBITS
)
1932 res
= gfc_trans_call (code
, is_mvbits
, NULL_TREE
,
1938 res
= gfc_trans_call (code
, false, NULL_TREE
,
1942 case EXEC_ASSIGN_CALL
:
1943 res
= gfc_trans_call (code
, true, NULL_TREE
,
1948 res
= gfc_trans_return (code
);
1952 res
= gfc_trans_if (code
);
1955 case EXEC_ARITHMETIC_IF
:
1956 res
= gfc_trans_arithmetic_if (code
);
1960 res
= gfc_trans_block_construct (code
);
1964 res
= gfc_trans_do (code
, cond
);
1967 case EXEC_DO_CONCURRENT
:
1968 res
= gfc_trans_do_concurrent (code
);
1972 res
= gfc_trans_do_while (code
);
1976 res
= gfc_trans_select (code
);
1979 case EXEC_SELECT_TYPE
:
1980 res
= gfc_trans_select_type (code
);
1983 case EXEC_SELECT_RANK
:
1984 res
= gfc_trans_select_rank (code
);
1988 res
= gfc_trans_flush (code
);
1992 case EXEC_SYNC_IMAGES
:
1993 case EXEC_SYNC_MEMORY
:
1994 res
= gfc_trans_sync (code
, code
->op
);
1999 res
= gfc_trans_lock_unlock (code
, code
->op
);
2002 case EXEC_EVENT_POST
:
2003 case EXEC_EVENT_WAIT
:
2004 res
= gfc_trans_event_post_wait (code
, code
->op
);
2007 case EXEC_FAIL_IMAGE
:
2008 res
= gfc_trans_fail_image (code
);
2012 res
= gfc_trans_forall (code
);
2015 case EXEC_FORM_TEAM
:
2016 res
= gfc_trans_form_team (code
);
2019 case EXEC_CHANGE_TEAM
:
2020 res
= gfc_trans_change_team (code
);
2024 res
= gfc_trans_end_team (code
);
2027 case EXEC_SYNC_TEAM
:
2028 res
= gfc_trans_sync_team (code
);
2032 res
= gfc_trans_where (code
);
2036 res
= gfc_trans_allocate (code
);
2039 case EXEC_DEALLOCATE
:
2040 res
= gfc_trans_deallocate (code
);
2044 res
= gfc_trans_open (code
);
2048 res
= gfc_trans_close (code
);
2052 res
= gfc_trans_read (code
);
2056 res
= gfc_trans_write (code
);
2060 res
= gfc_trans_iolength (code
);
2063 case EXEC_BACKSPACE
:
2064 res
= gfc_trans_backspace (code
);
2068 res
= gfc_trans_endfile (code
);
2072 res
= gfc_trans_inquire (code
);
2076 res
= gfc_trans_wait (code
);
2080 res
= gfc_trans_rewind (code
);
2084 res
= gfc_trans_transfer (code
);
2088 res
= gfc_trans_dt_end (code
);
2091 case EXEC_OMP_ATOMIC
:
2092 case EXEC_OMP_BARRIER
:
2093 case EXEC_OMP_CANCEL
:
2094 case EXEC_OMP_CANCELLATION_POINT
:
2095 case EXEC_OMP_CRITICAL
:
2096 case EXEC_OMP_DISTRIBUTE
:
2097 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
2098 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
2099 case EXEC_OMP_DISTRIBUTE_SIMD
:
2101 case EXEC_OMP_DO_SIMD
:
2102 case EXEC_OMP_FLUSH
:
2103 case EXEC_OMP_MASTER
:
2104 case EXEC_OMP_ORDERED
:
2105 case EXEC_OMP_PARALLEL
:
2106 case EXEC_OMP_PARALLEL_DO
:
2107 case EXEC_OMP_PARALLEL_DO_SIMD
:
2108 case EXEC_OMP_PARALLEL_SECTIONS
:
2109 case EXEC_OMP_PARALLEL_WORKSHARE
:
2110 case EXEC_OMP_SECTIONS
:
2112 case EXEC_OMP_SINGLE
:
2113 case EXEC_OMP_TARGET
:
2114 case EXEC_OMP_TARGET_DATA
:
2115 case EXEC_OMP_TARGET_ENTER_DATA
:
2116 case EXEC_OMP_TARGET_EXIT_DATA
:
2117 case EXEC_OMP_TARGET_PARALLEL
:
2118 case EXEC_OMP_TARGET_PARALLEL_DO
:
2119 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
2120 case EXEC_OMP_TARGET_SIMD
:
2121 case EXEC_OMP_TARGET_TEAMS
:
2122 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
2123 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2124 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2125 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
2126 case EXEC_OMP_TARGET_UPDATE
:
2128 case EXEC_OMP_TASKGROUP
:
2129 case EXEC_OMP_TASKLOOP
:
2130 case EXEC_OMP_TASKLOOP_SIMD
:
2131 case EXEC_OMP_TASKWAIT
:
2132 case EXEC_OMP_TASKYIELD
:
2133 case EXEC_OMP_TEAMS
:
2134 case EXEC_OMP_TEAMS_DISTRIBUTE
:
2135 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2136 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2137 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
2138 case EXEC_OMP_WORKSHARE
:
2139 res
= gfc_trans_omp_directive (code
);
2142 case EXEC_OACC_CACHE
:
2143 case EXEC_OACC_WAIT
:
2144 case EXEC_OACC_UPDATE
:
2145 case EXEC_OACC_LOOP
:
2146 case EXEC_OACC_HOST_DATA
:
2147 case EXEC_OACC_DATA
:
2148 case EXEC_OACC_KERNELS
:
2149 case EXEC_OACC_KERNELS_LOOP
:
2150 case EXEC_OACC_PARALLEL
:
2151 case EXEC_OACC_PARALLEL_LOOP
:
2152 case EXEC_OACC_SERIAL
:
2153 case EXEC_OACC_SERIAL_LOOP
:
2154 case EXEC_OACC_ENTER_DATA
:
2155 case EXEC_OACC_EXIT_DATA
:
2156 case EXEC_OACC_ATOMIC
:
2157 case EXEC_OACC_DECLARE
:
2158 res
= gfc_trans_oacc_directive (code
);
2162 gfc_internal_error ("gfc_trans_code(): Bad statement code");
2165 gfc_set_backend_locus (&code
->loc
);
2167 if (res
!= NULL_TREE
&& ! IS_EMPTY_STMT (res
))
2169 if (TREE_CODE (res
) != STATEMENT_LIST
)
2170 SET_EXPR_LOCATION (res
, input_location
);
2172 /* Add the new statement to the block. */
2173 gfc_add_expr_to_block (&block
, res
);
2177 /* Return the finished block. */
2178 return gfc_finish_block (&block
);
2182 /* Translate an executable statement with condition, cond. The condition is
2183 used by gfc_trans_do to test for IO result conditions inside implied
2184 DO loops of READ and WRITE statements. See build_dt in trans-io.c. */
2187 gfc_trans_code_cond (gfc_code
* code
, tree cond
)
2189 return trans_code (code
, cond
);
2192 /* Translate an executable statement without condition. */
2195 gfc_trans_code (gfc_code
* code
)
2197 return trans_code (code
, NULL_TREE
);
2201 /* This function is called after a complete program unit has been parsed
2205 gfc_generate_code (gfc_namespace
* ns
)
2208 if (ns
->is_block_data
)
2210 gfc_generate_block_data (ns
);
2214 gfc_generate_function_code (ns
);
2218 /* This function is called after a complete module has been parsed
2222 gfc_generate_module_code (gfc_namespace
* ns
)
2225 struct module_htab_entry
*entry
;
2227 gcc_assert (ns
->proc_name
->backend_decl
== NULL
);
2228 ns
->proc_name
->backend_decl
2229 = build_decl (gfc_get_location (&ns
->proc_name
->declared_at
),
2230 NAMESPACE_DECL
, get_identifier (ns
->proc_name
->name
),
2232 entry
= gfc_find_module (ns
->proc_name
->name
);
2233 if (entry
->namespace_decl
)
2234 /* Buggy sourcecode, using a module before defining it? */
2235 entry
->decls
->empty ();
2236 entry
->namespace_decl
= ns
->proc_name
->backend_decl
;
2238 gfc_generate_module_vars (ns
);
2240 /* We need to generate all module function prototypes first, to allow
2242 for (n
= ns
->contained
; n
; n
= n
->sibling
)
2249 gfc_create_function_decl (n
, false);
2250 DECL_CONTEXT (n
->proc_name
->backend_decl
) = ns
->proc_name
->backend_decl
;
2251 gfc_module_add_decl (entry
, n
->proc_name
->backend_decl
);
2252 for (el
= ns
->entries
; el
; el
= el
->next
)
2254 DECL_CONTEXT (el
->sym
->backend_decl
) = ns
->proc_name
->backend_decl
;
2255 gfc_module_add_decl (entry
, el
->sym
->backend_decl
);
2259 for (n
= ns
->contained
; n
; n
= n
->sibling
)
2264 gfc_generate_function_code (n
);
2269 /* Initialize an init/cleanup block with existing code. */
2272 gfc_start_wrapped_block (gfc_wrapped_block
* block
, tree code
)
2276 block
->init
= NULL_TREE
;
2278 block
->cleanup
= NULL_TREE
;
2282 /* Add a new pair of initializers/clean-up code. */
2285 gfc_add_init_cleanup (gfc_wrapped_block
* block
, tree init
, tree cleanup
)
2289 /* The new pair of init/cleanup should be "wrapped around" the existing
2290 block of code, thus the initialization is added to the front and the
2291 cleanup to the back. */
2292 add_expr_to_chain (&block
->init
, init
, true);
2293 add_expr_to_chain (&block
->cleanup
, cleanup
, false);
2297 /* Finish up a wrapped block by building a corresponding try-finally expr. */
2300 gfc_finish_wrapped_block (gfc_wrapped_block
* block
)
2306 /* Build the final expression. For this, just add init and body together,
2307 and put clean-up with that into a TRY_FINALLY_EXPR. */
2308 result
= block
->init
;
2309 add_expr_to_chain (&result
, block
->code
, false);
2311 result
= build2_loc (input_location
, TRY_FINALLY_EXPR
, void_type_node
,
2312 result
, block
->cleanup
);
2314 /* Clear the block. */
2315 block
->init
= NULL_TREE
;
2316 block
->code
= NULL_TREE
;
2317 block
->cleanup
= NULL_TREE
;
2323 /* Helper function for marking a boolean expression tree as unlikely. */
2326 gfc_unlikely (tree cond
, enum br_predictor predictor
)
2332 cond
= fold_convert (long_integer_type_node
, cond
);
2333 tmp
= build_zero_cst (long_integer_type_node
);
2334 cond
= build_call_expr_loc (input_location
,
2335 builtin_decl_explicit (BUILT_IN_EXPECT
),
2337 build_int_cst (integer_type_node
,
2344 /* Helper function for marking a boolean expression tree as likely. */
2347 gfc_likely (tree cond
, enum br_predictor predictor
)
2353 cond
= fold_convert (long_integer_type_node
, cond
);
2354 tmp
= build_one_cst (long_integer_type_node
);
2355 cond
= build_call_expr_loc (input_location
,
2356 builtin_decl_explicit (BUILT_IN_EXPECT
),
2358 build_int_cst (integer_type_node
,
2365 /* Get the string length for a deferred character length component. */
2368 gfc_deferred_strlen (gfc_component
*c
, tree
*decl
)
2370 char name
[GFC_MAX_SYMBOL_LEN
+9];
2371 gfc_component
*strlen
;
2372 if (!(c
->ts
.type
== BT_CHARACTER
2373 && (c
->ts
.deferred
|| c
->attr
.pdt_string
)))
2375 sprintf (name
, "_%s_length", c
->name
);
2376 for (strlen
= c
; strlen
; strlen
= strlen
->next
)
2377 if (strcmp (strlen
->name
, name
) == 0)
2379 *decl
= strlen
? strlen
->backend_decl
: NULL_TREE
;
2380 return strlen
!= NULL
;