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
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 /* Advance along TREE_CHAIN n times. */
54 gfc_advance_chain (tree t
, int n
)
58 gcc_assert (t
!= NULL_TREE
);
65 /* Strip off a legitimate source ending from the input
66 string NAME of length LEN. */
69 remove_suffix (char *name
, int len
)
73 for (i
= 2; i
< 8 && len
> i
; i
++)
75 if (name
[len
- i
] == '.')
84 /* Creates a variable declaration with a given TYPE. */
87 gfc_create_var_np (tree type
, const char *prefix
)
91 t
= create_tmp_var_raw (type
, prefix
);
93 /* No warnings for anonymous variables. */
95 TREE_NO_WARNING (t
) = 1;
101 /* Like above, but also adds it to the current scope. */
104 gfc_create_var (tree type
, const char *prefix
)
108 tmp
= gfc_create_var_np (type
, prefix
);
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. */
121 gfc_evaluate_now_loc (location_t loc
, tree expr
, stmtblock_t
* pblock
)
125 if (CONSTANT_CLASS_P (expr
))
128 var
= gfc_create_var (TREE_TYPE (expr
), NULL
);
129 gfc_add_modify_loc (loc
, pblock
, var
, expr
);
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:
147 gfc_add_modify_loc (location_t loc
, stmtblock_t
* pblock
, tree lhs
, tree rhs
)
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
,
163 gfc_add_expr_to_block (pblock
, tmp
);
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. */
179 gfc_start_block (stmtblock_t
* block
)
181 /* Start a new binding level. */
183 block
->has_scope
= 1;
185 /* The block is empty. */
186 block
->head
= NULL_TREE
;
190 /* Initialize a block without creating a new scope. */
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. */
205 gfc_merge_block_scope (stmtblock_t
* block
)
210 gcc_assert (block
->has_scope
);
211 block
->has_scope
= 0;
213 /* Remember the decls in this scope. */
217 /* Add them to the parent scope. */
218 while (decl
!= NULL_TREE
)
220 next
= DECL_CHAIN (decl
);
221 DECL_CHAIN (decl
) = NULL_TREE
;
229 /* Finish a scope containing a block of statements. */
232 gfc_finish_block (stmtblock_t
* stmtblock
)
238 expr
= stmtblock
->head
;
240 expr
= build_empty_stmt (input_location
);
242 stmtblock
->head
= NULL_TREE
;
244 if (stmtblock
->has_scope
)
250 block
= poplevel (1, 0);
251 expr
= build3_v (BIND_EXPR
, decl
, expr
, block
);
261 /* Build an ADDR_EXPR and cast the result to TYPE. If TYPE is NULL, the
262 natural type is used. */
265 gfc_build_addr_expr (tree type
, tree t
)
267 tree base_type
= TREE_TYPE (t
);
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
));
284 natural_type
= build_pointer_type (base_type
);
286 if (TREE_CODE (t
) == INDIRECT_REF
)
290 t
= TREE_OPERAND (t
, 0);
291 natural_type
= TREE_TYPE (t
);
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
);
309 get_array_span (tree type
, tree decl
)
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
))),
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
340 if (DECL_LANG_SPECIFIC (decl
) && GFC_DECL_SAVED_DESCRIPTOR (decl
))
341 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
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
))))
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
);
373 /* Build an ARRAY_REF with its natural type. */
376 gfc_build_array_ref (tree base
, tree offset
, tree decl
, tree vptr
)
378 tree type
= TREE_TYPE (base
);
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
));
397 type
= TREE_TYPE (type
);
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. */
408 span
= gfc_vptr_size_get (vptr
);
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
,
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
);
426 /* Otherwise use a straightforward array reference. */
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. */
437 trans_runtime_error_vararg (bool error
, locus
* where
, const char* msgid
,
450 /* Compute the number of extra arguments from the format string. */
451 for (p
= msgid
, nargs
= 0; *p
; p
++)
459 /* The code to generate the error. */
460 gfc_start_block (&block
);
464 line
= LOCATION_LINE (where
->lb
->location
);
465 message
= xasprintf ("At line %d of file %s", line
,
466 where
->lb
->file
->filename
);
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
));
476 message
= xasprintf ("%s", _(msgid
));
477 arg2
= gfc_build_addr_expr (pchar_type_node
,
478 gfc_build_localized_cstring_const (message
));
481 /* Build the argument array. */
482 argarray
= XALLOCAVEC (tree
, nargs
+ 2);
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,
492 fntype
= TREE_TYPE (gfor_fndecl_runtime_error_at
);
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
),
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
);
511 gfc_trans_runtime_error (bool error
, locus
* where
, const char* msgid
, ...)
516 va_start (ap
, msgid
);
517 result
= trans_runtime_error_vararg (error
, where
, msgid
, ap
);
523 /* Generate a runtime error if COND is true. */
526 gfc_trans_runtime_check (bool error
, bool once
, tree cond
, stmtblock_t
* pblock
,
527 locus
* where
, const char * msgid
, ...)
535 if (integer_zerop (cond
))
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. */
550 gfc_add_expr_to_block (&block
, build_predict_expr (PRED_FORTRAN_WARN_ONCE
,
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
,
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
);
572 cond
= fold_build2_loc (where
->lb
->location
, TRUTH_AND_EXPR
,
573 long_integer_type_node
, tmpvar
, cond
);
575 cond
= fold_convert (long_integer_type_node
, cond
);
577 tmp
= fold_build3_loc (where
->lb
->location
, COND_EXPR
, void_type_node
,
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. */
589 gfc_call_malloc (stmtblock_t
* block
, tree type
, tree size
)
591 tree tmp
, msg
, malloc_result
, null_result
, res
, malloc_tree
;
594 /* Create a variable to hold the result. */
595 res
= gfc_create_var (prvoid_type_node
, NULL
);
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
,
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
);
630 res
= fold_convert (type
, res
);
635 /* Allocate memory, using an optional status argument.
637 This function follows the following pseudo-code:
640 allocate (size_t size, integer_type stat)
647 newmem = malloc (MAX (size, 1));
651 *stat = LIBERROR_ALLOCATION;
653 runtime_error ("Allocation would exceed memory limit");
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
);
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:
716 allocate (size_t size, void** token, int *stat, char* errmsg, int errlen)
720 newmem = _caf_register (size, regtype, token, &stat, errmsg, errlen);
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
)
730 gcc_assert (token
!= NULL_TREE
);
732 /* The allocation itself. */
733 if (status
== NULL_TREE
)
734 pstat
= null_pointer_node
;
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:
773 allocate_allocatable (void *mem, size_t size, integer_type stat)
776 return allocate (size, stat);
780 stat = LIBERROR_ALLOCATION;
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. */
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
;
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
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);
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
);
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
);
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
);
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
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'",
909 error
= gfc_trans_runtime_error (true, NULL
,
910 "Attempting to allocate already allocated"
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
,
923 gfc_add_expr_to_block (block
, tmp
);
927 /* Free a given variable. */
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". */
941 gfc_build_final_call (gfc_typespec ts
, gfc_expr
*final_wrapper
, gfc_expr
*var
,
942 bool fini_coarray
, gfc_expr
*class_size
)
946 tree final_fndecl
, array
, size
, tmp
;
947 symbol_attribute attr
;
949 gcc_assert (final_wrapper
->expr_type
== EXPR_VARIABLE
);
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
)
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
);
972 se
.descriptor_only
= 1;
973 gfc_conv_expr_descriptor (&se
, var
);
978 gfc_conv_expr (&se
, var
);
979 gcc_assert (se
.pre
.head
== NULL_TREE
&& se
.post
.head
== NULL_TREE
);
982 /* No copy back needed, hence set attr's allocatable/pointer
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
);
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
);
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
);
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
);
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
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
);
1049 gfc_add_comp_finalizer_call (stmtblock_t
*block
, tree decl
, gfc_component
*comp
,
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
)
1061 gfc_init_block (&block2
);
1063 if (comp
->ts
.type
== BT_DERIVED
)
1065 if (comp
->attr
.pointer
)
1068 gfc_is_finalizable (comp
->ts
.u
.derived
, &final_expr
);
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
);
1081 else /* comp->ts.type == BT_CLASS. */
1083 if (CLASS_DATA (comp
)->attr
.class_pointer
)
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
));
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
);
1118 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
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
);
1144 /* Add a call to the finalizer, using the passed *expr. Returns
1145 true when a finalizer call has been inserted. */
1148 gfc_add_finalizer_call (stmtblock_t
*block
, gfc_expr
*expr2
)
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
))
1160 if (expr2
->ts
.type
== BT_DERIVED
)
1162 gfc_is_finalizable (expr2
->ts
.u
.derived
, &final_expr
);
1167 /* If we have a class array, we need go back to the class
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
);
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
);
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
,
1211 if (expr
->ts
.type
== BT_CLASS
&& !has_finalizer
)
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
))
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
,
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
);
1254 /* User-deallocate; we emit the code directly from the front-end, and the
1255 logic is the same as the previous library function:
1258 deallocate (void *pointer, GFC_INTEGER_4 * stat)
1265 runtime_error ("Attempt to DEALLOCATE unallocated memory.");
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
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
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
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
,
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
)
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
);
1323 gcc_assert (GFC_ARRAY_TYPE_P (caf_type
)
1324 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
)
1326 token
= GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
);
1330 if (coarray_dealloc_mode
== GFC_CAF_COARRAY_ANALYZE
)
1333 if (expr
&& !gfc_caf_attr (expr
, false, &comp_ref
).coarray_comp
1335 caf_dereg_type
= GFC_CAF_COARRAY_DEALLOCATE_ONLY
;
1336 // else do a deregister as set by default.
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
);
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'",
1367 error
= build_empty_stmt (input_location
);
1369 if (status
!= NULL_TREE
&& !integer_zerop (status
))
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
,
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
),
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
));
1407 cond2
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
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
);
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
);
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
);
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
,
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
),
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
),
1475 gfc_add_expr_to_block (&non_null
, tmp
);
1478 gfc_add_modify (&non_null
, pointer
, build_int_cst (TREE_TYPE (pointer
),
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. */
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
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
);
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'",
1526 error
= build_empty_stmt (input_location
);
1528 if (status
!= NULL_TREE
&& !integer_zerop (status
))
1530 tree status_type
= TREE_TYPE (TREE_TYPE (status
));
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
,
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
)
1557 if (coarray
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer
)))
1558 tmp
= gfc_conv_descriptor_data_get (pointer
);
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
));
1578 cond2
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
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
);
1593 tree pstat
= null_pointer_node
;
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
);
1606 tmp
= build_call_expr_loc (input_location
,
1607 gfor_fndecl_caf_deregister
, 5,
1608 token
, build_int_cst (integer_type_node
,
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
);
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:
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");
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
,
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
);
1690 /* Add an expression to another one, either at the front or the back. */
1693 add_expr_to_chain (tree
* chain
, tree expr
, bool front
)
1695 if (expr
== NULL_TREE
|| IS_EMPTY_STMT (expr
))
1700 if (TREE_CODE (*chain
) != STATEMENT_LIST
)
1706 append_to_statement_list (tmp
, chain
);
1711 tree_stmt_iterator i
;
1713 i
= tsi_start (*chain
);
1714 tsi_link_before (&i
, expr
, TSI_CONTINUE_LINKING
);
1717 append_to_statement_list (expr
, chain
);
1724 /* Add a statement at the end of a block. */
1727 gfc_add_expr_to_block (stmtblock_t
* block
, tree expr
)
1730 add_expr_to_chain (&block
->head
, expr
, false);
1734 /* Add a statement at the beginning of a block. */
1737 gfc_prepend_expr_to_block (stmtblock_t
* block
, tree expr
)
1740 add_expr_to_chain (&block
->head
, expr
, true);
1744 /* Add a block the end of a block. */
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. */
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. */
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. */
1783 gfc_restore_backend_locus (locus
* loc
)
1785 gfc_set_backend_locus (loc
);
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
1795 trans_code (gfc_code
* code
, tree cond
)
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
);
1821 case EXEC_END_BLOCK
:
1822 case EXEC_END_NESTED_BLOCK
:
1823 case EXEC_END_PROCEDURE
:
1828 res
= gfc_trans_assign (code
);
1831 case EXEC_LABEL_ASSIGN
:
1832 res
= gfc_trans_label_assign (code
);
1835 case EXEC_POINTER_ASSIGN
:
1836 res
= gfc_trans_pointer_assign (code
);
1839 case EXEC_INIT_ASSIGN
:
1840 if (code
->expr1
->ts
.type
== BT_CLASS
)
1841 res
= gfc_trans_class_init_assign (code
);
1843 res
= gfc_trans_init_assign (code
);
1851 res
= gfc_trans_critical (code
);
1855 res
= gfc_trans_cycle (code
);
1859 res
= gfc_trans_exit (code
);
1863 res
= gfc_trans_goto (code
);
1867 res
= gfc_trans_entry (code
);
1871 res
= gfc_trans_pause (code
);
1875 case EXEC_ERROR_STOP
:
1876 res
= gfc_trans_stop (code
, code
->op
== EXEC_ERROR_STOP
);
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
)
1892 if (code
->resolved_isym
1893 && code
->resolved_isym
->id
== GFC_ISYM_MVBITS
)
1896 res
= gfc_trans_call (code
, is_mvbits
, NULL_TREE
,
1902 res
= gfc_trans_call (code
, false, NULL_TREE
,
1906 case EXEC_ASSIGN_CALL
:
1907 res
= gfc_trans_call (code
, true, NULL_TREE
,
1912 res
= gfc_trans_return (code
);
1916 res
= gfc_trans_if (code
);
1919 case EXEC_ARITHMETIC_IF
:
1920 res
= gfc_trans_arithmetic_if (code
);
1924 res
= gfc_trans_block_construct (code
);
1928 res
= gfc_trans_do (code
, cond
);
1931 case EXEC_DO_CONCURRENT
:
1932 res
= gfc_trans_do_concurrent (code
);
1936 res
= gfc_trans_do_while (code
);
1940 res
= gfc_trans_select (code
);
1943 case EXEC_SELECT_TYPE
:
1944 res
= gfc_trans_select_type (code
);
1948 res
= gfc_trans_flush (code
);
1952 case EXEC_SYNC_IMAGES
:
1953 case EXEC_SYNC_MEMORY
:
1954 res
= gfc_trans_sync (code
, code
->op
);
1959 res
= gfc_trans_lock_unlock (code
, code
->op
);
1962 case EXEC_EVENT_POST
:
1963 case EXEC_EVENT_WAIT
:
1964 res
= gfc_trans_event_post_wait (code
, code
->op
);
1967 case EXEC_FAIL_IMAGE
:
1968 res
= gfc_trans_fail_image (code
);
1972 res
= gfc_trans_forall (code
);
1975 case EXEC_FORM_TEAM
:
1976 res
= gfc_trans_form_team (code
);
1979 case EXEC_CHANGE_TEAM
:
1980 res
= gfc_trans_change_team (code
);
1984 res
= gfc_trans_end_team (code
);
1987 case EXEC_SYNC_TEAM
:
1988 res
= gfc_trans_sync_team (code
);
1992 res
= gfc_trans_where (code
);
1996 res
= gfc_trans_allocate (code
);
1999 case EXEC_DEALLOCATE
:
2000 res
= gfc_trans_deallocate (code
);
2004 res
= gfc_trans_open (code
);
2008 res
= gfc_trans_close (code
);
2012 res
= gfc_trans_read (code
);
2016 res
= gfc_trans_write (code
);
2020 res
= gfc_trans_iolength (code
);
2023 case EXEC_BACKSPACE
:
2024 res
= gfc_trans_backspace (code
);
2028 res
= gfc_trans_endfile (code
);
2032 res
= gfc_trans_inquire (code
);
2036 res
= gfc_trans_wait (code
);
2040 res
= gfc_trans_rewind (code
);
2044 res
= gfc_trans_transfer (code
);
2048 res
= gfc_trans_dt_end (code
);
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
:
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
:
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
:
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
);
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
);
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. */
2145 gfc_trans_code_cond (gfc_code
* code
, tree cond
)
2147 return trans_code (code
, cond
);
2150 /* Translate an executable statement without condition. */
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
2163 gfc_generate_code (gfc_namespace
* ns
)
2166 if (ns
->is_block_data
)
2168 gfc_generate_block_data (ns
);
2172 gfc_generate_function_code (ns
);
2176 /* This function is called after a complete module has been parsed
2180 gfc_generate_module_code (gfc_namespace
* ns
)
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
),
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
2200 for (n
= ns
->contained
; n
; n
= n
->sibling
)
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
)
2222 gfc_generate_function_code (n
);
2227 /* Initialize an init/cleanup block with existing code. */
2230 gfc_start_wrapped_block (gfc_wrapped_block
* block
, tree code
)
2234 block
->init
= NULL_TREE
;
2236 block
->cleanup
= NULL_TREE
;
2240 /* Add a new pair of initializers/clean-up code. */
2243 gfc_add_init_cleanup (gfc_wrapped_block
* block
, tree init
, tree cleanup
)
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. */
2258 gfc_finish_wrapped_block (gfc_wrapped_block
* 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);
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
;
2281 /* Helper function for marking a boolean expression tree as unlikely. */
2284 gfc_unlikely (tree cond
, enum br_predictor predictor
)
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
),
2295 build_int_cst (integer_type_node
,
2302 /* Helper function for marking a boolean expression tree as likely. */
2305 gfc_likely (tree cond
, enum br_predictor predictor
)
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
),
2316 build_int_cst (integer_type_node
,
2323 /* Get the string length for a deferred character length component. */
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
)))
2333 sprintf (name
, "_%s_length", c
->name
);
2334 for (strlen
= c
; strlen
; strlen
= strlen
->next
)
2335 if (strcmp (strlen
->name
, name
) == 0)
2337 *decl
= strlen
? strlen
->backend_decl
: NULL_TREE
;
2338 return strlen
!= NULL
;