1 /* Code translation -- generate GCC trees from gfc_code.
2 Copyright (C) 2002-2016 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 the same
155 for scalar assignments. We should probably have something
156 similar for aggregates, but right now removing that check just
157 breaks everything. */
158 gcc_checking_assert (t1
== t2
159 || AGGREGATE_TYPE_P (TREE_TYPE (lhs
)));
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
);
308 /* Build an ARRAY_REF with its natural type. */
311 gfc_build_array_ref (tree base
, tree offset
, tree decl
, tree vptr
)
313 tree type
= TREE_TYPE (base
);
317 if (GFC_ARRAY_TYPE_P (type
) && GFC_TYPE_ARRAY_RANK (type
) == 0)
319 gcc_assert (GFC_TYPE_ARRAY_CORANK (type
) > 0);
321 return fold_convert (TYPE_MAIN_VARIANT (type
), base
);
324 /* Scalar coarray, there is nothing to do. */
325 if (TREE_CODE (type
) != ARRAY_TYPE
)
327 gcc_assert (decl
== NULL_TREE
);
328 gcc_assert (integer_zerop (offset
));
332 type
= TREE_TYPE (type
);
334 /* Use pointer arithmetic for deferred character length array
336 if (type
&& TREE_CODE (type
) == ARRAY_TYPE
337 && TYPE_MAXVAL (TYPE_DOMAIN (type
)) != NULL_TREE
338 && (VAR_P (TYPE_MAXVAL (TYPE_DOMAIN (type
)))
339 || TREE_CODE (TYPE_MAXVAL (TYPE_DOMAIN (type
))) == INDIRECT_REF
)
341 && (TREE_CODE (TYPE_MAXVAL (TYPE_DOMAIN (type
))) == INDIRECT_REF
342 || TREE_CODE (decl
) == FUNCTION_DECL
343 || DECL_CONTEXT (TYPE_MAXVAL (TYPE_DOMAIN (type
)))
344 == DECL_CONTEXT (decl
)))
345 span
= TYPE_MAXVAL (TYPE_DOMAIN (type
));
350 TREE_ADDRESSABLE (base
) = 1;
352 /* Strip NON_LVALUE_EXPR nodes. */
353 STRIP_TYPE_NOPS (offset
);
355 /* If the array reference is to a pointer, whose target contains a
356 subreference, use the span that is stored with the backend decl
357 and reference the element with pointer arithmetic. */
358 if ((decl
&& (TREE_CODE (decl
) == FIELD_DECL
359 || VAR_OR_FUNCTION_DECL_P (decl
)
360 || TREE_CODE (decl
) == PARM_DECL
)
361 && ((GFC_DECL_SUBREF_ARRAY_P (decl
)
362 && !integer_zerop (GFC_DECL_SPAN (decl
)))
363 || GFC_DECL_CLASS (decl
)
364 || span
!= NULL_TREE
))
365 || vptr
!= NULL_TREE
)
369 if (GFC_DECL_CLASS (decl
))
371 /* When a temporary is in place for the class array, then the
372 original class' declaration is stored in the saved
374 if (DECL_LANG_SPECIFIC (decl
) && GFC_DECL_SAVED_DESCRIPTOR (decl
))
375 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
378 /* Allow for dummy arguments and other good things. */
379 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
380 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
382 /* Check if '_data' is an array descriptor. If it is not,
383 the array must be one of the components of the class
384 object, so return a normal array reference. */
385 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (
386 gfc_class_data_get (decl
))))
387 return build4_loc (input_location
, ARRAY_REF
, type
, base
,
388 offset
, NULL_TREE
, NULL_TREE
);
391 span
= gfc_class_vtab_size_get (decl
);
393 else if (GFC_DECL_SUBREF_ARRAY_P (decl
))
394 span
= GFC_DECL_SPAN (decl
);
396 span
= fold_convert (gfc_array_index_type
, span
);
401 span
= gfc_vptr_size_get (vptr
);
405 offset
= fold_build2_loc (input_location
, MULT_EXPR
,
406 gfc_array_index_type
,
408 tmp
= gfc_build_addr_expr (pvoid_type_node
, base
);
409 tmp
= fold_build_pointer_plus_loc (input_location
, tmp
, offset
);
410 tmp
= fold_convert (build_pointer_type (type
), tmp
);
411 if (!TYPE_STRING_FLAG (type
))
412 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
416 /* Otherwise use a straightforward array reference. */
417 return build4_loc (input_location
, ARRAY_REF
, type
, base
, offset
,
418 NULL_TREE
, NULL_TREE
);
422 /* Generate a call to print a runtime error possibly including multiple
423 arguments and a locus. */
426 trans_runtime_error_vararg (bool error
, locus
* where
, const char* msgid
,
439 /* Compute the number of extra arguments from the format string. */
440 for (p
= msgid
, nargs
= 0; *p
; p
++)
448 /* The code to generate the error. */
449 gfc_start_block (&block
);
453 line
= LOCATION_LINE (where
->lb
->location
);
454 message
= xasprintf ("At line %d of file %s", line
,
455 where
->lb
->file
->filename
);
458 message
= xasprintf ("In file '%s', around line %d",
459 gfc_source_file
, LOCATION_LINE (input_location
) + 1);
461 arg
= gfc_build_addr_expr (pchar_type_node
,
462 gfc_build_localized_cstring_const (message
));
465 message
= xasprintf ("%s", _(msgid
));
466 arg2
= gfc_build_addr_expr (pchar_type_node
,
467 gfc_build_localized_cstring_const (message
));
470 /* Build the argument array. */
471 argarray
= XALLOCAVEC (tree
, nargs
+ 2);
474 for (i
= 0; i
< nargs
; i
++)
475 argarray
[2 + i
] = va_arg (ap
, tree
);
477 /* Build the function call to runtime_(warning,error)_at; because of the
478 variable number of arguments, we can't use build_call_expr_loc dinput_location,
481 fntype
= TREE_TYPE (gfor_fndecl_runtime_error_at
);
483 fntype
= TREE_TYPE (gfor_fndecl_runtime_warning_at
);
485 loc
= where
? where
->lb
->location
: input_location
;
486 tmp
= fold_build_call_array_loc (loc
, TREE_TYPE (fntype
),
487 fold_build1_loc (loc
, ADDR_EXPR
,
488 build_pointer_type (fntype
),
490 ? gfor_fndecl_runtime_error_at
491 : gfor_fndecl_runtime_warning_at
),
492 nargs
+ 2, argarray
);
493 gfc_add_expr_to_block (&block
, tmp
);
495 return gfc_finish_block (&block
);
500 gfc_trans_runtime_error (bool error
, locus
* where
, const char* msgid
, ...)
505 va_start (ap
, msgid
);
506 result
= trans_runtime_error_vararg (error
, where
, msgid
, ap
);
512 /* Generate a runtime error if COND is true. */
515 gfc_trans_runtime_check (bool error
, bool once
, tree cond
, stmtblock_t
* pblock
,
516 locus
* where
, const char * msgid
, ...)
524 if (integer_zerop (cond
))
529 tmpvar
= gfc_create_var (boolean_type_node
, "print_warning");
530 TREE_STATIC (tmpvar
) = 1;
531 DECL_INITIAL (tmpvar
) = boolean_true_node
;
532 gfc_add_expr_to_block (pblock
, tmpvar
);
535 gfc_start_block (&block
);
537 /* For error, runtime_error_at already implies PRED_NORETURN. */
539 gfc_add_expr_to_block (&block
, build_predict_expr (PRED_FORTRAN_WARN_ONCE
,
542 /* The code to generate the error. */
543 va_start (ap
, msgid
);
544 gfc_add_expr_to_block (&block
,
545 trans_runtime_error_vararg (error
, where
,
550 gfc_add_modify (&block
, tmpvar
, boolean_false_node
);
552 body
= gfc_finish_block (&block
);
554 if (integer_onep (cond
))
556 gfc_add_expr_to_block (pblock
, body
);
561 cond
= fold_build2_loc (where
->lb
->location
, TRUTH_AND_EXPR
,
562 long_integer_type_node
, tmpvar
, cond
);
564 cond
= fold_convert (long_integer_type_node
, cond
);
566 tmp
= fold_build3_loc (where
->lb
->location
, COND_EXPR
, void_type_node
,
568 build_empty_stmt (where
->lb
->location
));
569 gfc_add_expr_to_block (pblock
, tmp
);
574 /* Call malloc to allocate size bytes of memory, with special conditions:
575 + if size == 0, return a malloced area of size 1,
576 + if malloc returns NULL, issue a runtime error. */
578 gfc_call_malloc (stmtblock_t
* block
, tree type
, tree size
)
580 tree tmp
, msg
, malloc_result
, null_result
, res
, malloc_tree
;
583 /* Create a variable to hold the result. */
584 res
= gfc_create_var (prvoid_type_node
, NULL
);
587 gfc_start_block (&block2
);
589 size
= fold_convert (size_type_node
, size
);
590 size
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
, size
,
591 build_int_cst (size_type_node
, 1));
593 malloc_tree
= builtin_decl_explicit (BUILT_IN_MALLOC
);
594 gfc_add_modify (&block2
, res
,
595 fold_convert (prvoid_type_node
,
596 build_call_expr_loc (input_location
,
597 malloc_tree
, 1, size
)));
599 /* Optionally check whether malloc was successful. */
600 if (gfc_option
.rtcheck
& GFC_RTCHECK_MEM
)
602 null_result
= fold_build2_loc (input_location
, EQ_EXPR
,
603 boolean_type_node
, res
,
604 build_int_cst (pvoid_type_node
, 0));
605 msg
= gfc_build_addr_expr (pchar_type_node
,
606 gfc_build_localized_cstring_const ("Memory allocation failed"));
607 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
609 build_call_expr_loc (input_location
,
610 gfor_fndecl_os_error
, 1, msg
),
611 build_empty_stmt (input_location
));
612 gfc_add_expr_to_block (&block2
, tmp
);
615 malloc_result
= gfc_finish_block (&block2
);
616 gfc_add_expr_to_block (block
, malloc_result
);
619 res
= fold_convert (type
, res
);
624 /* Allocate memory, using an optional status argument.
626 This function follows the following pseudo-code:
629 allocate (size_t size, integer_type stat)
636 newmem = malloc (MAX (size, 1));
640 *stat = LIBERROR_ALLOCATION;
642 runtime_error ("Allocation would exceed memory limit");
647 gfc_allocate_using_malloc (stmtblock_t
* block
, tree pointer
,
648 tree size
, tree status
)
650 tree tmp
, error_cond
;
651 stmtblock_t on_error
;
652 tree status_type
= status
? TREE_TYPE (status
) : NULL_TREE
;
654 /* If successful and stat= is given, set status to 0. */
655 if (status
!= NULL_TREE
)
656 gfc_add_expr_to_block (block
,
657 fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
658 status
, build_int_cst (status_type
, 0)));
660 /* The allocation itself. */
661 size
= fold_convert (size_type_node
, size
);
662 gfc_add_modify (block
, pointer
,
663 fold_convert (TREE_TYPE (pointer
),
664 build_call_expr_loc (input_location
,
665 builtin_decl_explicit (BUILT_IN_MALLOC
), 1,
666 fold_build2_loc (input_location
,
667 MAX_EXPR
, size_type_node
, size
,
668 build_int_cst (size_type_node
, 1)))));
670 /* What to do in case of error. */
671 gfc_start_block (&on_error
);
672 if (status
!= NULL_TREE
)
674 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
, status
,
675 build_int_cst (status_type
, LIBERROR_ALLOCATION
));
676 gfc_add_expr_to_block (&on_error
, tmp
);
680 /* Here, os_error already implies PRED_NORETURN. */
681 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_os_error
, 1,
682 gfc_build_addr_expr (pchar_type_node
,
683 gfc_build_localized_cstring_const
684 ("Allocation would exceed memory limit")));
685 gfc_add_expr_to_block (&on_error
, tmp
);
688 error_cond
= fold_build2_loc (input_location
, EQ_EXPR
,
689 boolean_type_node
, pointer
,
690 build_int_cst (prvoid_type_node
, 0));
691 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
692 gfc_unlikely (error_cond
, PRED_FORTRAN_FAIL_ALLOC
),
693 gfc_finish_block (&on_error
),
694 build_empty_stmt (input_location
));
696 gfc_add_expr_to_block (block
, tmp
);
700 /* Allocate memory, using an optional status argument.
702 This function follows the following pseudo-code:
705 allocate (size_t size, void** token, int *stat, char* errmsg, int errlen)
709 newmem = _caf_register (size, regtype, token, &stat, errmsg, errlen);
713 gfc_allocate_using_lib (stmtblock_t
* block
, tree pointer
, tree size
,
714 tree token
, tree status
, tree errmsg
, tree errlen
,
715 bool lock_var
, bool event_var
)
719 gcc_assert (token
!= NULL_TREE
);
721 /* The allocation itself. */
722 if (status
== NULL_TREE
)
723 pstat
= null_pointer_node
;
725 pstat
= gfc_build_addr_expr (NULL_TREE
, status
);
727 if (errmsg
== NULL_TREE
)
729 gcc_assert(errlen
== NULL_TREE
);
730 errmsg
= null_pointer_node
;
731 errlen
= build_int_cst (integer_type_node
, 0);
734 size
= fold_convert (size_type_node
, size
);
735 tmp
= build_call_expr_loc (input_location
,
736 gfor_fndecl_caf_register
, 7,
737 fold_build2_loc (input_location
,
738 MAX_EXPR
, size_type_node
, size
,
739 build_int_cst (size_type_node
, 1)),
740 build_int_cst (integer_type_node
,
741 lock_var
? GFC_CAF_LOCK_ALLOC
742 : event_var
? GFC_CAF_EVENT_ALLOC
743 : GFC_CAF_COARRAY_ALLOC
),
744 token
, gfc_build_addr_expr (pvoid_type_node
, pointer
),
745 pstat
, errmsg
, errlen
);
747 gfc_add_expr_to_block (block
, tmp
);
749 /* It guarantees memory consistency within the same segment */
750 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
751 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
752 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
753 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
754 ASM_VOLATILE_P (tmp
) = 1;
755 gfc_add_expr_to_block (block
, tmp
);
759 /* Generate code for an ALLOCATE statement when the argument is an
760 allocatable variable. If the variable is currently allocated, it is an
761 error to allocate it again.
763 This function follows the following pseudo-code:
766 allocate_allocatable (void *mem, size_t size, integer_type stat)
769 return allocate (size, stat);
773 stat = LIBERROR_ALLOCATION;
775 runtime_error ("Attempting to allocate already allocated variable");
779 expr must be set to the original expression being allocated for its locus
780 and variable name in case a runtime error has to be printed. */
782 gfc_allocate_allocatable (stmtblock_t
* block
, tree mem
, tree size
,
783 tree token
, tree status
, tree errmsg
, tree errlen
,
784 tree label_finish
, gfc_expr
* expr
, int corank
)
786 stmtblock_t alloc_block
;
787 tree tmp
, null_mem
, alloc
, error
;
788 tree type
= TREE_TYPE (mem
);
789 symbol_attribute caf_attr
;
790 bool need_assign
= false;
792 size
= fold_convert (size_type_node
, size
);
793 null_mem
= gfc_unlikely (fold_build2_loc (input_location
, NE_EXPR
,
794 boolean_type_node
, mem
,
795 build_int_cst (type
, 0)),
796 PRED_FORTRAN_REALLOC
);
798 /* If mem is NULL, we call gfc_allocate_using_malloc or
799 gfc_allocate_using_lib. */
800 gfc_start_block (&alloc_block
);
802 if (flag_coarray
== GFC_FCOARRAY_LIB
)
803 caf_attr
= gfc_caf_attr (expr
, true);
805 if (flag_coarray
== GFC_FCOARRAY_LIB
806 && (corank
> 0 || caf_attr
.codimension
))
809 bool lock_var
= expr
->ts
.type
== BT_DERIVED
810 && expr
->ts
.u
.derived
->from_intmod
811 == INTMOD_ISO_FORTRAN_ENV
812 && expr
->ts
.u
.derived
->intmod_sym_id
813 == ISOFORTRAN_LOCK_TYPE
;
814 bool event_var
= expr
->ts
.type
== BT_DERIVED
815 && expr
->ts
.u
.derived
->from_intmod
816 == INTMOD_ISO_FORTRAN_ENV
817 && expr
->ts
.u
.derived
->intmod_sym_id
818 == ISOFORTRAN_EVENT_TYPE
;
820 gfc_init_se (&se
, NULL
);
822 tree sub_caf_tree
= gfc_get_ultimate_alloc_ptr_comps_caf_token (&se
,
824 if (sub_caf_tree
== NULL_TREE
)
825 sub_caf_tree
= token
;
827 /* When mem is an array ref, then strip the .data-ref. */
828 if (TREE_CODE (mem
) == COMPONENT_REF
829 && !(GFC_ARRAY_TYPE_P (TREE_TYPE (mem
))))
830 tmp
= TREE_OPERAND (mem
, 0);
834 if (!(GFC_ARRAY_TYPE_P (TREE_TYPE (tmp
))
835 && TYPE_LANG_SPECIFIC (TREE_TYPE (tmp
))->corank
== 0)
836 && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)))
838 symbol_attribute attr
;
840 gfc_clear_attr (&attr
);
841 tmp
= gfc_conv_scalar_to_descriptor (&se
, mem
, attr
);
844 gfc_add_block_to_block (&alloc_block
, &se
.pre
);
846 /* In the front end, we represent the lock variable as pointer. However,
847 the FE only passes the pointer around and leaves the actual
848 representation to the library. Hence, we have to convert back to the
849 number of elements. */
850 if (lock_var
|| event_var
)
851 size
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, size_type_node
,
852 size
, TYPE_SIZE_UNIT (ptr_type_node
));
854 gfc_allocate_using_lib (&alloc_block
, tmp
, size
, sub_caf_tree
,
855 status
, errmsg
, errlen
, lock_var
, event_var
);
857 gfc_add_modify (&alloc_block
, mem
, fold_convert (TREE_TYPE (mem
),
858 gfc_conv_descriptor_data_get (tmp
)));
859 if (status
!= NULL_TREE
)
861 TREE_USED (label_finish
) = 1;
862 tmp
= build1_v (GOTO_EXPR
, label_finish
);
863 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
864 status
, build_zero_cst (TREE_TYPE (status
)));
865 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
866 gfc_unlikely (cond
, PRED_FORTRAN_FAIL_ALLOC
),
867 tmp
, build_empty_stmt (input_location
));
868 gfc_add_expr_to_block (&alloc_block
, tmp
);
872 gfc_allocate_using_malloc (&alloc_block
, mem
, size
, status
);
874 alloc
= gfc_finish_block (&alloc_block
);
876 /* If mem is not NULL, we issue a runtime error or set the
882 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
&& expr
->symtree
);
883 varname
= gfc_build_cstring_const (expr
->symtree
->name
);
884 varname
= gfc_build_addr_expr (pchar_type_node
, varname
);
886 error
= gfc_trans_runtime_error (true, &expr
->where
,
887 "Attempting to allocate already"
888 " allocated variable '%s'",
892 error
= gfc_trans_runtime_error (true, NULL
,
893 "Attempting to allocate already allocated"
896 if (status
!= NULL_TREE
)
898 tree status_type
= TREE_TYPE (status
);
900 error
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
901 status
, build_int_cst (status_type
, LIBERROR_ALLOCATION
));
904 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, null_mem
,
906 gfc_add_expr_to_block (block
, tmp
);
910 /* Free a given variable. */
913 gfc_call_free (tree var
)
915 return build_call_expr_loc (input_location
,
916 builtin_decl_explicit (BUILT_IN_FREE
),
917 1, fold_convert (pvoid_type_node
, var
));
921 /* Build a call to a FINAL procedure, which finalizes "var". */
924 gfc_build_final_call (gfc_typespec ts
, gfc_expr
*final_wrapper
, gfc_expr
*var
,
925 bool fini_coarray
, gfc_expr
*class_size
)
929 tree final_fndecl
, array
, size
, tmp
;
930 symbol_attribute attr
;
932 gcc_assert (final_wrapper
->expr_type
== EXPR_VARIABLE
);
935 gfc_start_block (&block
);
936 gfc_init_se (&se
, NULL
);
937 gfc_conv_expr (&se
, final_wrapper
);
938 final_fndecl
= se
.expr
;
939 if (POINTER_TYPE_P (TREE_TYPE (final_fndecl
)))
940 final_fndecl
= build_fold_indirect_ref_loc (input_location
, final_fndecl
);
942 if (ts
.type
== BT_DERIVED
)
946 gcc_assert (!class_size
);
947 elem_size
= gfc_typenode_for_spec (&ts
);
948 elem_size
= TYPE_SIZE_UNIT (elem_size
);
949 size
= fold_convert (gfc_array_index_type
, elem_size
);
951 gfc_init_se (&se
, NULL
);
955 se
.descriptor_only
= 1;
956 gfc_conv_expr_descriptor (&se
, var
);
961 gfc_conv_expr (&se
, var
);
962 gcc_assert (se
.pre
.head
== NULL_TREE
&& se
.post
.head
== NULL_TREE
);
965 /* No copy back needed, hence set attr's allocatable/pointer
967 gfc_clear_attr (&attr
);
968 gfc_init_se (&se
, NULL
);
969 array
= gfc_conv_scalar_to_descriptor (&se
, array
, attr
);
970 gcc_assert (se
.post
.head
== NULL_TREE
);
975 gfc_expr
*array_expr
;
976 gcc_assert (class_size
);
977 gfc_init_se (&se
, NULL
);
978 gfc_conv_expr (&se
, class_size
);
979 gfc_add_block_to_block (&block
, &se
.pre
);
980 gcc_assert (se
.post
.head
== NULL_TREE
);
983 array_expr
= gfc_copy_expr (var
);
984 gfc_init_se (&se
, NULL
);
986 if (array_expr
->rank
)
988 gfc_add_class_array_ref (array_expr
);
989 se
.descriptor_only
= 1;
990 gfc_conv_expr_descriptor (&se
, array_expr
);
995 gfc_add_data_component (array_expr
);
996 gfc_conv_expr (&se
, array_expr
);
997 gfc_add_block_to_block (&block
, &se
.pre
);
998 gcc_assert (se
.post
.head
== NULL_TREE
);
1000 if (TREE_CODE (array
) == ADDR_EXPR
1001 && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (array
, 0))))
1002 tmp
= TREE_OPERAND (array
, 0);
1004 if (!gfc_is_coarray (array_expr
))
1006 /* No copy back needed, hence set attr's allocatable/pointer
1008 gfc_clear_attr (&attr
);
1009 gfc_init_se (&se
, NULL
);
1010 array
= gfc_conv_scalar_to_descriptor (&se
, array
, attr
);
1012 gcc_assert (se
.post
.head
== NULL_TREE
);
1014 gfc_free_expr (array_expr
);
1017 if (!POINTER_TYPE_P (TREE_TYPE (array
)))
1018 array
= gfc_build_addr_expr (NULL
, array
);
1020 gfc_add_block_to_block (&block
, &se
.pre
);
1021 tmp
= build_call_expr_loc (input_location
,
1022 final_fndecl
, 3, array
,
1023 size
, fini_coarray
? boolean_true_node
1024 : boolean_false_node
);
1025 gfc_add_block_to_block (&block
, &se
.post
);
1026 gfc_add_expr_to_block (&block
, tmp
);
1027 return gfc_finish_block (&block
);
1032 gfc_add_comp_finalizer_call (stmtblock_t
*block
, tree decl
, gfc_component
*comp
,
1037 tree final_fndecl
, size
, array
, tmp
, cond
;
1038 symbol_attribute attr
;
1039 gfc_expr
*final_expr
= NULL
;
1041 if (comp
->ts
.type
!= BT_DERIVED
&& comp
->ts
.type
!= BT_CLASS
)
1044 gfc_init_block (&block2
);
1046 if (comp
->ts
.type
== BT_DERIVED
)
1048 if (comp
->attr
.pointer
)
1051 gfc_is_finalizable (comp
->ts
.u
.derived
, &final_expr
);
1055 gfc_init_se (&se
, NULL
);
1056 gfc_conv_expr (&se
, final_expr
);
1057 final_fndecl
= se
.expr
;
1058 size
= gfc_typenode_for_spec (&comp
->ts
);
1059 size
= TYPE_SIZE_UNIT (size
);
1060 size
= fold_convert (gfc_array_index_type
, size
);
1064 else /* comp->ts.type == BT_CLASS. */
1066 if (CLASS_DATA (comp
)->attr
.class_pointer
)
1069 gfc_is_finalizable (CLASS_DATA (comp
)->ts
.u
.derived
, &final_expr
);
1070 final_fndecl
= gfc_class_vtab_final_get (decl
);
1071 size
= gfc_class_vtab_size_get (decl
);
1072 array
= gfc_class_data_get (decl
);
1075 if (comp
->attr
.allocatable
1076 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)->attr
.allocatable
))
1078 tmp
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array
))
1079 ? gfc_conv_descriptor_data_get (array
) : array
;
1080 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1081 tmp
, fold_convert (TREE_TYPE (tmp
),
1082 null_pointer_node
));
1085 cond
= boolean_true_node
;
1087 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array
)))
1089 gfc_clear_attr (&attr
);
1090 gfc_init_se (&se
, NULL
);
1091 array
= gfc_conv_scalar_to_descriptor (&se
, array
, attr
);
1092 gfc_add_block_to_block (&block2
, &se
.pre
);
1093 gcc_assert (se
.post
.head
== NULL_TREE
);
1096 if (!POINTER_TYPE_P (TREE_TYPE (array
)))
1097 array
= gfc_build_addr_expr (NULL
, array
);
1101 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1103 fold_convert (TREE_TYPE (final_fndecl
),
1104 null_pointer_node
));
1105 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1106 boolean_type_node
, cond
, tmp
);
1109 if (POINTER_TYPE_P (TREE_TYPE (final_fndecl
)))
1110 final_fndecl
= build_fold_indirect_ref_loc (input_location
, final_fndecl
);
1112 tmp
= build_call_expr_loc (input_location
,
1113 final_fndecl
, 3, array
,
1114 size
, fini_coarray
? boolean_true_node
1115 : boolean_false_node
);
1116 gfc_add_expr_to_block (&block2
, tmp
);
1117 tmp
= gfc_finish_block (&block2
);
1119 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
1120 build_empty_stmt (input_location
));
1121 gfc_add_expr_to_block (block
, tmp
);
1127 /* Add a call to the finalizer, using the passed *expr. Returns
1128 true when a finalizer call has been inserted. */
1131 gfc_add_finalizer_call (stmtblock_t
*block
, gfc_expr
*expr2
)
1136 gfc_expr
*final_expr
= NULL
;
1137 gfc_expr
*elem_size
= NULL
;
1138 bool has_finalizer
= false;
1140 if (!expr2
|| (expr2
->ts
.type
!= BT_DERIVED
&& expr2
->ts
.type
!= BT_CLASS
))
1143 if (expr2
->ts
.type
== BT_DERIVED
)
1145 gfc_is_finalizable (expr2
->ts
.u
.derived
, &final_expr
);
1150 /* If we have a class array, we need go back to the class
1152 expr
= gfc_copy_expr (expr2
);
1154 if (expr
->ref
&& expr
->ref
->next
&& !expr
->ref
->next
->next
1155 && expr
->ref
->next
->type
== REF_ARRAY
1156 && expr
->ref
->type
== REF_COMPONENT
1157 && strcmp (expr
->ref
->u
.c
.component
->name
, "_data") == 0)
1159 gfc_free_ref_list (expr
->ref
);
1163 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1164 if (ref
->next
&& ref
->next
->next
&& !ref
->next
->next
->next
1165 && ref
->next
->next
->type
== REF_ARRAY
1166 && ref
->next
->type
== REF_COMPONENT
1167 && strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0)
1169 gfc_free_ref_list (ref
->next
);
1173 if (expr
->ts
.type
== BT_CLASS
)
1175 has_finalizer
= gfc_is_finalizable (expr
->ts
.u
.derived
, NULL
);
1177 if (!expr2
->rank
&& !expr2
->ref
&& CLASS_DATA (expr2
->symtree
->n
.sym
)->as
)
1178 expr
->rank
= CLASS_DATA (expr2
->symtree
->n
.sym
)->as
->rank
;
1180 final_expr
= gfc_copy_expr (expr
);
1181 gfc_add_vptr_component (final_expr
);
1182 gfc_add_final_component (final_expr
);
1184 elem_size
= gfc_copy_expr (expr
);
1185 gfc_add_vptr_component (elem_size
);
1186 gfc_add_size_component (elem_size
);
1189 gcc_assert (final_expr
->expr_type
== EXPR_VARIABLE
);
1191 tmp
= gfc_build_final_call (expr
->ts
, final_expr
, expr
,
1194 if (expr
->ts
.type
== BT_CLASS
&& !has_finalizer
)
1199 gfc_init_se (&se
, NULL
);
1200 se
.want_pointer
= 1;
1201 gfc_conv_expr (&se
, final_expr
);
1202 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1203 se
.expr
, build_int_cst (TREE_TYPE (se
.expr
), 0));
1205 /* For CLASS(*) not only sym->_vtab->_final can be NULL
1206 but already sym->_vtab itself. */
1207 if (UNLIMITED_POLY (expr
))
1210 gfc_expr
*vptr_expr
;
1212 vptr_expr
= gfc_copy_expr (expr
);
1213 gfc_add_vptr_component (vptr_expr
);
1215 gfc_init_se (&se
, NULL
);
1216 se
.want_pointer
= 1;
1217 gfc_conv_expr (&se
, vptr_expr
);
1218 gfc_free_expr (vptr_expr
);
1220 cond2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1222 build_int_cst (TREE_TYPE (se
.expr
), 0));
1223 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1224 boolean_type_node
, cond2
, cond
);
1227 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1228 cond
, tmp
, build_empty_stmt (input_location
));
1231 gfc_add_expr_to_block (block
, tmp
);
1237 /* User-deallocate; we emit the code directly from the front-end, and the
1238 logic is the same as the previous library function:
1241 deallocate (void *pointer, GFC_INTEGER_4 * stat)
1248 runtime_error ("Attempt to DEALLOCATE unallocated memory.");
1258 In this front-end version, status doesn't have to be GFC_INTEGER_4.
1259 Moreover, if CAN_FAIL is true, then we will not emit a runtime error,
1260 even when no status variable is passed to us (this is used for
1261 unconditional deallocation generated by the front-end at end of
1264 If a runtime-message is possible, `expr' must point to the original
1265 expression being deallocated for its locus and variable name.
1267 For coarrays, "pointer" must be the array descriptor and not its
1268 "data" component. */
1270 gfc_deallocate_with_status (tree pointer
, tree status
, tree errmsg
,
1271 tree errlen
, tree label_finish
,
1272 bool can_fail
, gfc_expr
* expr
, bool coarray
)
1274 stmtblock_t null
, non_null
;
1275 tree cond
, tmp
, error
;
1276 tree status_type
= NULL_TREE
;
1277 tree caf_decl
= NULL_TREE
;
1281 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer
)));
1283 pointer
= gfc_conv_descriptor_data_get (caf_decl
);
1284 STRIP_NOPS (pointer
);
1287 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, pointer
,
1288 build_int_cst (TREE_TYPE (pointer
), 0));
1290 /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
1291 we emit a runtime error. */
1292 gfc_start_block (&null
);
1297 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
&& expr
->symtree
);
1299 varname
= gfc_build_cstring_const (expr
->symtree
->name
);
1300 varname
= gfc_build_addr_expr (pchar_type_node
, varname
);
1302 error
= gfc_trans_runtime_error (true, &expr
->where
,
1303 "Attempt to DEALLOCATE unallocated '%s'",
1307 error
= build_empty_stmt (input_location
);
1309 if (status
!= NULL_TREE
&& !integer_zerop (status
))
1313 status_type
= TREE_TYPE (TREE_TYPE (status
));
1314 cond2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1315 status
, build_int_cst (TREE_TYPE (status
), 0));
1316 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
1317 fold_build1_loc (input_location
, INDIRECT_REF
,
1318 status_type
, status
),
1319 build_int_cst (status_type
, 1));
1320 error
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1324 gfc_add_expr_to_block (&null
, error
);
1326 /* When POINTER is not NULL, we free it. */
1327 gfc_start_block (&non_null
);
1328 gfc_add_finalizer_call (&non_null
, expr
);
1329 if (!coarray
|| flag_coarray
!= GFC_FCOARRAY_LIB
)
1331 tmp
= build_call_expr_loc (input_location
,
1332 builtin_decl_explicit (BUILT_IN_FREE
), 1,
1333 fold_convert (pvoid_type_node
, pointer
));
1334 gfc_add_expr_to_block (&non_null
, tmp
);
1336 if (status
!= NULL_TREE
&& !integer_zerop (status
))
1338 /* We set STATUS to zero if it is present. */
1339 tree status_type
= TREE_TYPE (TREE_TYPE (status
));
1342 cond2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1344 build_int_cst (TREE_TYPE (status
), 0));
1345 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
1346 fold_build1_loc (input_location
, INDIRECT_REF
,
1347 status_type
, status
),
1348 build_int_cst (status_type
, 0));
1349 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1350 gfc_unlikely (cond2
, PRED_FORTRAN_FAIL_ALLOC
),
1351 tmp
, build_empty_stmt (input_location
));
1352 gfc_add_expr_to_block (&non_null
, tmp
);
1357 tree caf_type
, token
, cond2
;
1358 tree pstat
= null_pointer_node
;
1360 if (errmsg
== NULL_TREE
)
1362 gcc_assert (errlen
== NULL_TREE
);
1363 errmsg
= null_pointer_node
;
1364 errlen
= build_zero_cst (integer_type_node
);
1368 gcc_assert (errlen
!= NULL_TREE
);
1369 if (!POINTER_TYPE_P (TREE_TYPE (errmsg
)))
1370 errmsg
= gfc_build_addr_expr (NULL_TREE
, errmsg
);
1373 caf_type
= TREE_TYPE (caf_decl
);
1375 if (status
!= NULL_TREE
&& !integer_zerop (status
))
1377 gcc_assert (status_type
== integer_type_node
);
1381 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
1382 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
1383 token
= gfc_conv_descriptor_token (caf_decl
);
1384 else if (DECL_LANG_SPECIFIC (caf_decl
)
1385 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
1386 token
= GFC_DECL_TOKEN (caf_decl
);
1389 gcc_assert (GFC_ARRAY_TYPE_P (caf_type
)
1390 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) != NULL_TREE
);
1391 token
= GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
);
1394 token
= gfc_build_addr_expr (NULL_TREE
, token
);
1395 tmp
= build_call_expr_loc (input_location
,
1396 gfor_fndecl_caf_deregister
, 4,
1397 token
, pstat
, errmsg
, errlen
);
1398 gfc_add_expr_to_block (&non_null
, tmp
);
1400 /* It guarantees memory consistency within the same segment */
1401 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
1402 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1403 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
1404 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
1405 ASM_VOLATILE_P (tmp
) = 1;
1406 gfc_add_expr_to_block (&non_null
, tmp
);
1408 if (status
!= NULL_TREE
)
1410 tree stat
= build_fold_indirect_ref_loc (input_location
, status
);
1412 TREE_USED (label_finish
) = 1;
1413 tmp
= build1_v (GOTO_EXPR
, label_finish
);
1414 cond2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1415 stat
, build_zero_cst (TREE_TYPE (stat
)));
1416 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1417 gfc_unlikely (cond2
, PRED_FORTRAN_REALLOC
),
1418 tmp
, build_empty_stmt (input_location
));
1419 gfc_add_expr_to_block (&non_null
, tmp
);
1423 return fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
1424 gfc_finish_block (&null
),
1425 gfc_finish_block (&non_null
));
1429 /* Generate code for deallocation of allocatable scalars (variables or
1430 components). Before the object itself is freed, any allocatable
1431 subcomponents are being deallocated. */
1434 gfc_deallocate_scalar_with_status (tree pointer
, tree status
, bool can_fail
,
1435 gfc_expr
* expr
, gfc_typespec ts
)
1437 stmtblock_t null
, non_null
;
1438 tree cond
, tmp
, error
;
1441 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, pointer
,
1442 build_int_cst (TREE_TYPE (pointer
), 0));
1444 /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
1445 we emit a runtime error. */
1446 gfc_start_block (&null
);
1451 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
&& expr
->symtree
);
1453 varname
= gfc_build_cstring_const (expr
->symtree
->name
);
1454 varname
= gfc_build_addr_expr (pchar_type_node
, varname
);
1456 error
= gfc_trans_runtime_error (true, &expr
->where
,
1457 "Attempt to DEALLOCATE unallocated '%s'",
1461 error
= build_empty_stmt (input_location
);
1463 if (status
!= NULL_TREE
&& !integer_zerop (status
))
1465 tree status_type
= TREE_TYPE (TREE_TYPE (status
));
1468 cond2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1469 status
, build_int_cst (TREE_TYPE (status
), 0));
1470 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
1471 fold_build1_loc (input_location
, INDIRECT_REF
,
1472 status_type
, status
),
1473 build_int_cst (status_type
, 1));
1474 error
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1478 gfc_add_expr_to_block (&null
, error
);
1480 /* When POINTER is not NULL, we free it. */
1481 gfc_start_block (&non_null
);
1483 /* Free allocatable components. */
1484 finalizable
= gfc_add_finalizer_call (&non_null
, expr
);
1485 if (!finalizable
&& ts
.type
== BT_DERIVED
&& ts
.u
.derived
->attr
.alloc_comp
)
1487 tmp
= build_fold_indirect_ref_loc (input_location
, pointer
);
1488 tmp
= gfc_deallocate_alloc_comp (ts
.u
.derived
, tmp
, 0);
1489 gfc_add_expr_to_block (&non_null
, tmp
);
1492 tmp
= build_call_expr_loc (input_location
,
1493 builtin_decl_explicit (BUILT_IN_FREE
), 1,
1494 fold_convert (pvoid_type_node
, pointer
));
1495 gfc_add_expr_to_block (&non_null
, tmp
);
1497 if (status
!= NULL_TREE
&& !integer_zerop (status
))
1499 /* We set STATUS to zero if it is present. */
1500 tree status_type
= TREE_TYPE (TREE_TYPE (status
));
1503 cond2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1504 status
, build_int_cst (TREE_TYPE (status
), 0));
1505 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
1506 fold_build1_loc (input_location
, INDIRECT_REF
,
1507 status_type
, status
),
1508 build_int_cst (status_type
, 0));
1509 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
1510 tmp
, build_empty_stmt (input_location
));
1511 gfc_add_expr_to_block (&non_null
, tmp
);
1514 return fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
1515 gfc_finish_block (&null
),
1516 gfc_finish_block (&non_null
));
1520 /* Reallocate MEM so it has SIZE bytes of data. This behaves like the
1521 following pseudo-code:
1524 internal_realloc (void *mem, size_t size)
1526 res = realloc (mem, size);
1527 if (!res && size != 0)
1528 _gfortran_os_error ("Allocation would exceed memory limit");
1533 gfc_call_realloc (stmtblock_t
* block
, tree mem
, tree size
)
1535 tree msg
, res
, nonzero
, null_result
, tmp
;
1536 tree type
= TREE_TYPE (mem
);
1538 /* Only evaluate the size once. */
1539 size
= save_expr (fold_convert (size_type_node
, size
));
1541 /* Create a variable to hold the result. */
1542 res
= gfc_create_var (type
, NULL
);
1544 /* Call realloc and check the result. */
1545 tmp
= build_call_expr_loc (input_location
,
1546 builtin_decl_explicit (BUILT_IN_REALLOC
), 2,
1547 fold_convert (pvoid_type_node
, mem
), size
);
1548 gfc_add_modify (block
, res
, fold_convert (type
, tmp
));
1549 null_result
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1550 res
, build_int_cst (pvoid_type_node
, 0));
1551 nonzero
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, size
,
1552 build_int_cst (size_type_node
, 0));
1553 null_result
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, boolean_type_node
,
1554 null_result
, nonzero
);
1555 msg
= gfc_build_addr_expr (pchar_type_node
, gfc_build_localized_cstring_const
1556 ("Allocation would exceed memory limit"));
1557 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1559 build_call_expr_loc (input_location
,
1560 gfor_fndecl_os_error
, 1, msg
),
1561 build_empty_stmt (input_location
));
1562 gfc_add_expr_to_block (block
, tmp
);
1568 /* Add an expression to another one, either at the front or the back. */
1571 add_expr_to_chain (tree
* chain
, tree expr
, bool front
)
1573 if (expr
== NULL_TREE
|| IS_EMPTY_STMT (expr
))
1578 if (TREE_CODE (*chain
) != STATEMENT_LIST
)
1584 append_to_statement_list (tmp
, chain
);
1589 tree_stmt_iterator i
;
1591 i
= tsi_start (*chain
);
1592 tsi_link_before (&i
, expr
, TSI_CONTINUE_LINKING
);
1595 append_to_statement_list (expr
, chain
);
1602 /* Add a statement at the end of a block. */
1605 gfc_add_expr_to_block (stmtblock_t
* block
, tree expr
)
1608 add_expr_to_chain (&block
->head
, expr
, false);
1612 /* Add a statement at the beginning of a block. */
1615 gfc_prepend_expr_to_block (stmtblock_t
* block
, tree expr
)
1618 add_expr_to_chain (&block
->head
, expr
, true);
1622 /* Add a block the end of a block. */
1625 gfc_add_block_to_block (stmtblock_t
* block
, stmtblock_t
* append
)
1627 gcc_assert (append
);
1628 gcc_assert (!append
->has_scope
);
1630 gfc_add_expr_to_block (block
, append
->head
);
1631 append
->head
= NULL_TREE
;
1635 /* Save the current locus. The structure may not be complete, and should
1636 only be used with gfc_restore_backend_locus. */
1639 gfc_save_backend_locus (locus
* loc
)
1641 loc
->lb
= XCNEW (gfc_linebuf
);
1642 loc
->lb
->location
= input_location
;
1643 loc
->lb
->file
= gfc_current_backend_file
;
1647 /* Set the current locus. */
1650 gfc_set_backend_locus (locus
* loc
)
1652 gfc_current_backend_file
= loc
->lb
->file
;
1653 input_location
= loc
->lb
->location
;
1657 /* Restore the saved locus. Only used in conjunction with
1658 gfc_save_backend_locus, to free the memory when we are done. */
1661 gfc_restore_backend_locus (locus
* loc
)
1663 gfc_set_backend_locus (loc
);
1668 /* Translate an executable statement. The tree cond is used by gfc_trans_do.
1669 This static function is wrapped by gfc_trans_code_cond and
1673 trans_code (gfc_code
* code
, tree cond
)
1679 return build_empty_stmt (input_location
);
1681 gfc_start_block (&block
);
1683 /* Translate statements one by one into GENERIC trees until we reach
1684 the end of this gfc_code branch. */
1685 for (; code
; code
= code
->next
)
1687 if (code
->here
!= 0)
1689 res
= gfc_trans_label_here (code
);
1690 gfc_add_expr_to_block (&block
, res
);
1693 gfc_current_locus
= code
->loc
;
1694 gfc_set_backend_locus (&code
->loc
);
1699 case EXEC_END_BLOCK
:
1700 case EXEC_END_NESTED_BLOCK
:
1701 case EXEC_END_PROCEDURE
:
1706 res
= gfc_trans_assign (code
);
1709 case EXEC_LABEL_ASSIGN
:
1710 res
= gfc_trans_label_assign (code
);
1713 case EXEC_POINTER_ASSIGN
:
1714 res
= gfc_trans_pointer_assign (code
);
1717 case EXEC_INIT_ASSIGN
:
1718 if (code
->expr1
->ts
.type
== BT_CLASS
)
1719 res
= gfc_trans_class_init_assign (code
);
1721 res
= gfc_trans_init_assign (code
);
1729 res
= gfc_trans_critical (code
);
1733 res
= gfc_trans_cycle (code
);
1737 res
= gfc_trans_exit (code
);
1741 res
= gfc_trans_goto (code
);
1745 res
= gfc_trans_entry (code
);
1749 res
= gfc_trans_pause (code
);
1753 case EXEC_ERROR_STOP
:
1754 res
= gfc_trans_stop (code
, code
->op
== EXEC_ERROR_STOP
);
1758 /* For MVBITS we've got the special exception that we need a
1759 dependency check, too. */
1761 bool is_mvbits
= false;
1763 if (code
->resolved_isym
)
1765 res
= gfc_conv_intrinsic_subroutine (code
);
1766 if (res
!= NULL_TREE
)
1770 if (code
->resolved_isym
1771 && code
->resolved_isym
->id
== GFC_ISYM_MVBITS
)
1774 res
= gfc_trans_call (code
, is_mvbits
, NULL_TREE
,
1780 res
= gfc_trans_call (code
, false, NULL_TREE
,
1784 case EXEC_ASSIGN_CALL
:
1785 res
= gfc_trans_call (code
, true, NULL_TREE
,
1790 res
= gfc_trans_return (code
);
1794 res
= gfc_trans_if (code
);
1797 case EXEC_ARITHMETIC_IF
:
1798 res
= gfc_trans_arithmetic_if (code
);
1802 res
= gfc_trans_block_construct (code
);
1806 res
= gfc_trans_do (code
, cond
);
1809 case EXEC_DO_CONCURRENT
:
1810 res
= gfc_trans_do_concurrent (code
);
1814 res
= gfc_trans_do_while (code
);
1818 res
= gfc_trans_select (code
);
1821 case EXEC_SELECT_TYPE
:
1822 res
= gfc_trans_select_type (code
);
1826 res
= gfc_trans_flush (code
);
1830 case EXEC_SYNC_IMAGES
:
1831 case EXEC_SYNC_MEMORY
:
1832 res
= gfc_trans_sync (code
, code
->op
);
1837 res
= gfc_trans_lock_unlock (code
, code
->op
);
1840 case EXEC_EVENT_POST
:
1841 case EXEC_EVENT_WAIT
:
1842 res
= gfc_trans_event_post_wait (code
, code
->op
);
1846 res
= gfc_trans_forall (code
);
1850 res
= gfc_trans_where (code
);
1854 res
= gfc_trans_allocate (code
);
1857 case EXEC_DEALLOCATE
:
1858 res
= gfc_trans_deallocate (code
);
1862 res
= gfc_trans_open (code
);
1866 res
= gfc_trans_close (code
);
1870 res
= gfc_trans_read (code
);
1874 res
= gfc_trans_write (code
);
1878 res
= gfc_trans_iolength (code
);
1881 case EXEC_BACKSPACE
:
1882 res
= gfc_trans_backspace (code
);
1886 res
= gfc_trans_endfile (code
);
1890 res
= gfc_trans_inquire (code
);
1894 res
= gfc_trans_wait (code
);
1898 res
= gfc_trans_rewind (code
);
1902 res
= gfc_trans_transfer (code
);
1906 res
= gfc_trans_dt_end (code
);
1909 case EXEC_OMP_ATOMIC
:
1910 case EXEC_OMP_BARRIER
:
1911 case EXEC_OMP_CANCEL
:
1912 case EXEC_OMP_CANCELLATION_POINT
:
1913 case EXEC_OMP_CRITICAL
:
1914 case EXEC_OMP_DISTRIBUTE
:
1915 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
1916 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
1917 case EXEC_OMP_DISTRIBUTE_SIMD
:
1919 case EXEC_OMP_DO_SIMD
:
1920 case EXEC_OMP_FLUSH
:
1921 case EXEC_OMP_MASTER
:
1922 case EXEC_OMP_ORDERED
:
1923 case EXEC_OMP_PARALLEL
:
1924 case EXEC_OMP_PARALLEL_DO
:
1925 case EXEC_OMP_PARALLEL_DO_SIMD
:
1926 case EXEC_OMP_PARALLEL_SECTIONS
:
1927 case EXEC_OMP_PARALLEL_WORKSHARE
:
1928 case EXEC_OMP_SECTIONS
:
1930 case EXEC_OMP_SINGLE
:
1931 case EXEC_OMP_TARGET
:
1932 case EXEC_OMP_TARGET_DATA
:
1933 case EXEC_OMP_TARGET_TEAMS
:
1934 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
1935 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
1936 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
1937 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
1938 case EXEC_OMP_TARGET_UPDATE
:
1940 case EXEC_OMP_TASKGROUP
:
1941 case EXEC_OMP_TASKWAIT
:
1942 case EXEC_OMP_TASKYIELD
:
1943 case EXEC_OMP_TEAMS
:
1944 case EXEC_OMP_TEAMS_DISTRIBUTE
:
1945 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
1946 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
1947 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
1948 case EXEC_OMP_WORKSHARE
:
1949 res
= gfc_trans_omp_directive (code
);
1952 case EXEC_OACC_CACHE
:
1953 case EXEC_OACC_WAIT
:
1954 case EXEC_OACC_UPDATE
:
1955 case EXEC_OACC_LOOP
:
1956 case EXEC_OACC_HOST_DATA
:
1957 case EXEC_OACC_DATA
:
1958 case EXEC_OACC_KERNELS
:
1959 case EXEC_OACC_KERNELS_LOOP
:
1960 case EXEC_OACC_PARALLEL
:
1961 case EXEC_OACC_PARALLEL_LOOP
:
1962 case EXEC_OACC_ENTER_DATA
:
1963 case EXEC_OACC_EXIT_DATA
:
1964 case EXEC_OACC_ATOMIC
:
1965 case EXEC_OACC_DECLARE
:
1966 res
= gfc_trans_oacc_directive (code
);
1970 gfc_internal_error ("gfc_trans_code(): Bad statement code");
1973 gfc_set_backend_locus (&code
->loc
);
1975 if (res
!= NULL_TREE
&& ! IS_EMPTY_STMT (res
))
1977 if (TREE_CODE (res
) != STATEMENT_LIST
)
1978 SET_EXPR_LOCATION (res
, input_location
);
1980 /* Add the new statement to the block. */
1981 gfc_add_expr_to_block (&block
, res
);
1985 /* Return the finished block. */
1986 return gfc_finish_block (&block
);
1990 /* Translate an executable statement with condition, cond. The condition is
1991 used by gfc_trans_do to test for IO result conditions inside implied
1992 DO loops of READ and WRITE statements. See build_dt in trans-io.c. */
1995 gfc_trans_code_cond (gfc_code
* code
, tree cond
)
1997 return trans_code (code
, cond
);
2000 /* Translate an executable statement without condition. */
2003 gfc_trans_code (gfc_code
* code
)
2005 return trans_code (code
, NULL_TREE
);
2009 /* This function is called after a complete program unit has been parsed
2013 gfc_generate_code (gfc_namespace
* ns
)
2016 if (ns
->is_block_data
)
2018 gfc_generate_block_data (ns
);
2022 gfc_generate_function_code (ns
);
2026 /* This function is called after a complete module has been parsed
2030 gfc_generate_module_code (gfc_namespace
* ns
)
2033 struct module_htab_entry
*entry
;
2035 gcc_assert (ns
->proc_name
->backend_decl
== NULL
);
2036 ns
->proc_name
->backend_decl
2037 = build_decl (ns
->proc_name
->declared_at
.lb
->location
,
2038 NAMESPACE_DECL
, get_identifier (ns
->proc_name
->name
),
2040 entry
= gfc_find_module (ns
->proc_name
->name
);
2041 if (entry
->namespace_decl
)
2042 /* Buggy sourcecode, using a module before defining it? */
2043 entry
->decls
->empty ();
2044 entry
->namespace_decl
= ns
->proc_name
->backend_decl
;
2046 gfc_generate_module_vars (ns
);
2048 /* We need to generate all module function prototypes first, to allow
2050 for (n
= ns
->contained
; n
; n
= n
->sibling
)
2057 gfc_create_function_decl (n
, false);
2058 DECL_CONTEXT (n
->proc_name
->backend_decl
) = ns
->proc_name
->backend_decl
;
2059 gfc_module_add_decl (entry
, n
->proc_name
->backend_decl
);
2060 for (el
= ns
->entries
; el
; el
= el
->next
)
2062 DECL_CONTEXT (el
->sym
->backend_decl
) = ns
->proc_name
->backend_decl
;
2063 gfc_module_add_decl (entry
, el
->sym
->backend_decl
);
2067 for (n
= ns
->contained
; n
; n
= n
->sibling
)
2072 gfc_generate_function_code (n
);
2077 /* Initialize an init/cleanup block with existing code. */
2080 gfc_start_wrapped_block (gfc_wrapped_block
* block
, tree code
)
2084 block
->init
= NULL_TREE
;
2086 block
->cleanup
= NULL_TREE
;
2090 /* Add a new pair of initializers/clean-up code. */
2093 gfc_add_init_cleanup (gfc_wrapped_block
* block
, tree init
, tree cleanup
)
2097 /* The new pair of init/cleanup should be "wrapped around" the existing
2098 block of code, thus the initialization is added to the front and the
2099 cleanup to the back. */
2100 add_expr_to_chain (&block
->init
, init
, true);
2101 add_expr_to_chain (&block
->cleanup
, cleanup
, false);
2105 /* Finish up a wrapped block by building a corresponding try-finally expr. */
2108 gfc_finish_wrapped_block (gfc_wrapped_block
* block
)
2114 /* Build the final expression. For this, just add init and body together,
2115 and put clean-up with that into a TRY_FINALLY_EXPR. */
2116 result
= block
->init
;
2117 add_expr_to_chain (&result
, block
->code
, false);
2119 result
= build2_loc (input_location
, TRY_FINALLY_EXPR
, void_type_node
,
2120 result
, block
->cleanup
);
2122 /* Clear the block. */
2123 block
->init
= NULL_TREE
;
2124 block
->code
= NULL_TREE
;
2125 block
->cleanup
= NULL_TREE
;
2131 /* Helper function for marking a boolean expression tree as unlikely. */
2134 gfc_unlikely (tree cond
, enum br_predictor predictor
)
2140 cond
= fold_convert (long_integer_type_node
, cond
);
2141 tmp
= build_zero_cst (long_integer_type_node
);
2142 cond
= build_call_expr_loc (input_location
,
2143 builtin_decl_explicit (BUILT_IN_EXPECT
),
2145 build_int_cst (integer_type_node
,
2148 cond
= fold_convert (boolean_type_node
, cond
);
2153 /* Helper function for marking a boolean expression tree as likely. */
2156 gfc_likely (tree cond
, enum br_predictor predictor
)
2162 cond
= fold_convert (long_integer_type_node
, cond
);
2163 tmp
= build_one_cst (long_integer_type_node
);
2164 cond
= build_call_expr_loc (input_location
,
2165 builtin_decl_explicit (BUILT_IN_EXPECT
),
2167 build_int_cst (integer_type_node
,
2170 cond
= fold_convert (boolean_type_node
, cond
);
2175 /* Get the string length for a deferred character length component. */
2178 gfc_deferred_strlen (gfc_component
*c
, tree
*decl
)
2180 char name
[GFC_MAX_SYMBOL_LEN
+9];
2181 gfc_component
*strlen
;
2182 if (!(c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
))
2184 sprintf (name
, "_%s_length", c
->name
);
2185 for (strlen
= c
; strlen
; strlen
= strlen
->next
)
2186 if (strcmp (strlen
->name
, name
) == 0)
2188 *decl
= strlen
? strlen
->backend_decl
: NULL_TREE
;
2189 return strlen
!= NULL
;