1 /* Code translation -- generate GCC trees from gfc_code.
2 Copyright (C) 2002-2015 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 && TREE_CODE (TYPE_MAXVAL (TYPE_DOMAIN (type
))) == VAR_DECL
340 && DECL_CONTEXT (TYPE_MAXVAL (TYPE_DOMAIN (type
)))
341 == DECL_CONTEXT (decl
))
342 span
= TYPE_MAXVAL (TYPE_DOMAIN (type
));
347 TREE_ADDRESSABLE (base
) = 1;
349 /* Strip NON_LVALUE_EXPR nodes. */
350 STRIP_TYPE_NOPS (offset
);
352 /* If the array reference is to a pointer, whose target contains a
353 subreference, use the span that is stored with the backend decl
354 and reference the element with pointer arithmetic. */
355 if ((decl
&& (TREE_CODE (decl
) == FIELD_DECL
356 || TREE_CODE (decl
) == VAR_DECL
357 || TREE_CODE (decl
) == PARM_DECL
)
358 && ((GFC_DECL_SUBREF_ARRAY_P (decl
)
359 && !integer_zerop (GFC_DECL_SPAN (decl
)))
360 || GFC_DECL_CLASS (decl
)
361 || span
!= NULL_TREE
))
362 || vptr
!= NULL_TREE
)
366 if (GFC_DECL_CLASS (decl
))
368 /* When a temporary is in place for the class array, then the
369 original class' declaration is stored in the saved
371 if (DECL_LANG_SPECIFIC (decl
) && GFC_DECL_SAVED_DESCRIPTOR (decl
))
372 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
375 /* Allow for dummy arguments and other good things. */
376 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
377 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
379 /* Check if '_data' is an array descriptor. If it is not,
380 the array must be one of the components of the class
381 object, so return a normal array reference. */
382 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (
383 gfc_class_data_get (decl
))))
384 return build4_loc (input_location
, ARRAY_REF
, type
, base
,
385 offset
, NULL_TREE
, NULL_TREE
);
388 span
= gfc_class_vtab_size_get (decl
);
390 else if (GFC_DECL_SUBREF_ARRAY_P (decl
))
391 span
= GFC_DECL_SPAN (decl
);
393 span
= fold_convert (gfc_array_index_type
, span
);
398 span
= gfc_vptr_size_get (vptr
);
402 offset
= fold_build2_loc (input_location
, MULT_EXPR
,
403 gfc_array_index_type
,
405 tmp
= gfc_build_addr_expr (pvoid_type_node
, base
);
406 tmp
= fold_build_pointer_plus_loc (input_location
, tmp
, offset
);
407 tmp
= fold_convert (build_pointer_type (type
), tmp
);
408 if (!TYPE_STRING_FLAG (type
))
409 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
413 /* Otherwise use a straightforward array reference. */
414 return build4_loc (input_location
, ARRAY_REF
, type
, base
, offset
,
415 NULL_TREE
, NULL_TREE
);
419 /* Generate a call to print a runtime error possibly including multiple
420 arguments and a locus. */
423 trans_runtime_error_vararg (bool error
, locus
* where
, const char* msgid
,
436 /* Compute the number of extra arguments from the format string. */
437 for (p
= msgid
, nargs
= 0; *p
; p
++)
445 /* The code to generate the error. */
446 gfc_start_block (&block
);
450 line
= LOCATION_LINE (where
->lb
->location
);
451 message
= xasprintf ("At line %d of file %s", line
,
452 where
->lb
->file
->filename
);
455 message
= xasprintf ("In file '%s', around line %d",
456 gfc_source_file
, LOCATION_LINE (input_location
) + 1);
458 arg
= gfc_build_addr_expr (pchar_type_node
,
459 gfc_build_localized_cstring_const (message
));
462 message
= xasprintf ("%s", _(msgid
));
463 arg2
= gfc_build_addr_expr (pchar_type_node
,
464 gfc_build_localized_cstring_const (message
));
467 /* Build the argument array. */
468 argarray
= XALLOCAVEC (tree
, nargs
+ 2);
471 for (i
= 0; i
< nargs
; i
++)
472 argarray
[2 + i
] = va_arg (ap
, tree
);
474 /* Build the function call to runtime_(warning,error)_at; because of the
475 variable number of arguments, we can't use build_call_expr_loc dinput_location,
478 fntype
= TREE_TYPE (gfor_fndecl_runtime_error_at
);
480 fntype
= TREE_TYPE (gfor_fndecl_runtime_warning_at
);
482 loc
= where
? where
->lb
->location
: input_location
;
483 tmp
= fold_build_call_array_loc (loc
, TREE_TYPE (fntype
),
484 fold_build1_loc (loc
, ADDR_EXPR
,
485 build_pointer_type (fntype
),
487 ? gfor_fndecl_runtime_error_at
488 : gfor_fndecl_runtime_warning_at
),
489 nargs
+ 2, argarray
);
490 gfc_add_expr_to_block (&block
, tmp
);
492 return gfc_finish_block (&block
);
497 gfc_trans_runtime_error (bool error
, locus
* where
, const char* msgid
, ...)
502 va_start (ap
, msgid
);
503 result
= trans_runtime_error_vararg (error
, where
, msgid
, ap
);
509 /* Generate a runtime error if COND is true. */
512 gfc_trans_runtime_check (bool error
, bool once
, tree cond
, stmtblock_t
* pblock
,
513 locus
* where
, const char * msgid
, ...)
521 if (integer_zerop (cond
))
526 tmpvar
= gfc_create_var (boolean_type_node
, "print_warning");
527 TREE_STATIC (tmpvar
) = 1;
528 DECL_INITIAL (tmpvar
) = boolean_true_node
;
529 gfc_add_expr_to_block (pblock
, tmpvar
);
532 gfc_start_block (&block
);
534 /* For error, runtime_error_at already implies PRED_NORETURN. */
536 gfc_add_expr_to_block (&block
, build_predict_expr (PRED_FORTRAN_WARN_ONCE
,
539 /* The code to generate the error. */
540 va_start (ap
, msgid
);
541 gfc_add_expr_to_block (&block
,
542 trans_runtime_error_vararg (error
, where
,
547 gfc_add_modify (&block
, tmpvar
, boolean_false_node
);
549 body
= gfc_finish_block (&block
);
551 if (integer_onep (cond
))
553 gfc_add_expr_to_block (pblock
, body
);
558 cond
= fold_build2_loc (where
->lb
->location
, TRUTH_AND_EXPR
,
559 long_integer_type_node
, tmpvar
, cond
);
561 cond
= fold_convert (long_integer_type_node
, cond
);
563 tmp
= fold_build3_loc (where
->lb
->location
, COND_EXPR
, void_type_node
,
565 build_empty_stmt (where
->lb
->location
));
566 gfc_add_expr_to_block (pblock
, tmp
);
571 /* Call malloc to allocate size bytes of memory, with special conditions:
572 + if size == 0, return a malloced area of size 1,
573 + if malloc returns NULL, issue a runtime error. */
575 gfc_call_malloc (stmtblock_t
* block
, tree type
, tree size
)
577 tree tmp
, msg
, malloc_result
, null_result
, res
, malloc_tree
;
580 /* Create a variable to hold the result. */
581 res
= gfc_create_var (prvoid_type_node
, NULL
);
584 gfc_start_block (&block2
);
586 size
= fold_convert (size_type_node
, size
);
587 size
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
, size
,
588 build_int_cst (size_type_node
, 1));
590 malloc_tree
= builtin_decl_explicit (BUILT_IN_MALLOC
);
591 gfc_add_modify (&block2
, res
,
592 fold_convert (prvoid_type_node
,
593 build_call_expr_loc (input_location
,
594 malloc_tree
, 1, size
)));
596 /* Optionally check whether malloc was successful. */
597 if (gfc_option
.rtcheck
& GFC_RTCHECK_MEM
)
599 null_result
= fold_build2_loc (input_location
, EQ_EXPR
,
600 boolean_type_node
, res
,
601 build_int_cst (pvoid_type_node
, 0));
602 msg
= gfc_build_addr_expr (pchar_type_node
,
603 gfc_build_localized_cstring_const ("Memory allocation failed"));
604 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
606 build_call_expr_loc (input_location
,
607 gfor_fndecl_os_error
, 1, msg
),
608 build_empty_stmt (input_location
));
609 gfc_add_expr_to_block (&block2
, tmp
);
612 malloc_result
= gfc_finish_block (&block2
);
613 gfc_add_expr_to_block (block
, malloc_result
);
616 res
= fold_convert (type
, res
);
621 /* Allocate memory, using an optional status argument.
623 This function follows the following pseudo-code:
626 allocate (size_t size, integer_type stat)
633 newmem = malloc (MAX (size, 1));
637 *stat = LIBERROR_ALLOCATION;
639 runtime_error ("Allocation would exceed memory limit");
644 gfc_allocate_using_malloc (stmtblock_t
* block
, tree pointer
,
645 tree size
, tree status
)
647 tree tmp
, error_cond
;
648 stmtblock_t on_error
;
649 tree status_type
= status
? TREE_TYPE (status
) : NULL_TREE
;
651 /* If successful and stat= is given, set status to 0. */
652 if (status
!= NULL_TREE
)
653 gfc_add_expr_to_block (block
,
654 fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
655 status
, build_int_cst (status_type
, 0)));
657 /* The allocation itself. */
658 size
= fold_convert (size_type_node
, size
);
659 gfc_add_modify (block
, pointer
,
660 fold_convert (TREE_TYPE (pointer
),
661 build_call_expr_loc (input_location
,
662 builtin_decl_explicit (BUILT_IN_MALLOC
), 1,
663 fold_build2_loc (input_location
,
664 MAX_EXPR
, size_type_node
, size
,
665 build_int_cst (size_type_node
, 1)))));
667 /* What to do in case of error. */
668 gfc_start_block (&on_error
);
669 if (status
!= NULL_TREE
)
671 gfc_add_expr_to_block (&on_error
,
672 build_predict_expr (PRED_FORTRAN_FAIL_ALLOC
,
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 error_cond
, gfc_finish_block (&on_error
),
693 build_empty_stmt (input_location
));
695 gfc_add_expr_to_block (block
, tmp
);
699 /* Allocate memory, using an optional status argument.
701 This function follows the following pseudo-code:
704 allocate (size_t size, void** token, int *stat, char* errmsg, int errlen)
708 newmem = _caf_register (size, regtype, token, &stat, errmsg, errlen);
712 gfc_allocate_using_lib (stmtblock_t
* block
, tree pointer
, tree size
,
713 tree token
, tree status
, tree errmsg
, tree errlen
,
714 bool lock_var
, bool event_var
)
718 gcc_assert (token
!= NULL_TREE
);
720 /* The allocation itself. */
721 if (status
== NULL_TREE
)
722 pstat
= null_pointer_node
;
724 pstat
= gfc_build_addr_expr (NULL_TREE
, status
);
726 if (errmsg
== NULL_TREE
)
728 gcc_assert(errlen
== NULL_TREE
);
729 errmsg
= null_pointer_node
;
730 errlen
= build_int_cst (integer_type_node
, 0);
733 size
= fold_convert (size_type_node
, size
);
734 tmp
= build_call_expr_loc (input_location
,
735 gfor_fndecl_caf_register
, 6,
736 fold_build2_loc (input_location
,
737 MAX_EXPR
, size_type_node
, size
,
738 build_int_cst (size_type_node
, 1)),
739 build_int_cst (integer_type_node
,
740 lock_var
? GFC_CAF_LOCK_ALLOC
741 : event_var
? GFC_CAF_EVENT_ALLOC
742 : GFC_CAF_COARRAY_ALLOC
),
743 token
, pstat
, errmsg
, errlen
);
745 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
746 TREE_TYPE (pointer
), pointer
,
747 fold_convert ( TREE_TYPE (pointer
), tmp
));
748 gfc_add_expr_to_block (block
, tmp
);
750 /* It guarantees memory consistency within the same segment */
751 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
752 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
753 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
754 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
755 ASM_VOLATILE_P (tmp
) = 1;
756 gfc_add_expr_to_block (block
, tmp
);
760 /* Generate code for an ALLOCATE statement when the argument is an
761 allocatable variable. If the variable is currently allocated, it is an
762 error to allocate it again.
764 This function follows the following pseudo-code:
767 allocate_allocatable (void *mem, size_t size, integer_type stat)
770 return allocate (size, stat);
774 stat = LIBERROR_ALLOCATION;
776 runtime_error ("Attempting to allocate already allocated variable");
780 expr must be set to the original expression being allocated for its locus
781 and variable name in case a runtime error has to be printed. */
783 gfc_allocate_allocatable (stmtblock_t
* block
, tree mem
, tree size
, tree token
,
784 tree status
, tree errmsg
, tree errlen
, tree label_finish
,
787 stmtblock_t alloc_block
;
788 tree tmp
, null_mem
, alloc
, error
;
789 tree type
= TREE_TYPE (mem
);
791 size
= fold_convert (size_type_node
, size
);
792 null_mem
= gfc_unlikely (fold_build2_loc (input_location
, NE_EXPR
,
793 boolean_type_node
, mem
,
794 build_int_cst (type
, 0)),
795 PRED_FORTRAN_FAIL_ALLOC
);
797 /* If mem is NULL, we call gfc_allocate_using_malloc or
798 gfc_allocate_using_lib. */
799 gfc_start_block (&alloc_block
);
801 if (flag_coarray
== GFC_FCOARRAY_LIB
802 && gfc_expr_attr (expr
).codimension
)
805 bool lock_var
= expr
->ts
.type
== BT_DERIVED
806 && expr
->ts
.u
.derived
->from_intmod
807 == INTMOD_ISO_FORTRAN_ENV
808 && expr
->ts
.u
.derived
->intmod_sym_id
809 == ISOFORTRAN_LOCK_TYPE
;
810 bool event_var
= expr
->ts
.type
== BT_DERIVED
811 && expr
->ts
.u
.derived
->from_intmod
812 == INTMOD_ISO_FORTRAN_ENV
813 && expr
->ts
.u
.derived
->intmod_sym_id
814 == ISOFORTRAN_EVENT_TYPE
;
815 /* In the front end, we represent the lock variable as pointer. However,
816 the FE only passes the pointer around and leaves the actual
817 representation to the library. Hence, we have to convert back to the
818 number of elements. */
820 size
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, size_type_node
,
821 size
, TYPE_SIZE_UNIT (ptr_type_node
));
823 gfc_allocate_using_lib (&alloc_block
, mem
, size
, token
, status
,
824 errmsg
, errlen
, lock_var
, event_var
);
826 if (status
!= NULL_TREE
)
828 TREE_USED (label_finish
) = 1;
829 tmp
= build1_v (GOTO_EXPR
, label_finish
);
830 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
831 status
, build_zero_cst (TREE_TYPE (status
)));
832 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
833 gfc_unlikely (cond
, PRED_FORTRAN_FAIL_ALLOC
),
834 tmp
, build_empty_stmt (input_location
));
835 gfc_add_expr_to_block (&alloc_block
, tmp
);
839 gfc_allocate_using_malloc (&alloc_block
, mem
, size
, status
);
841 alloc
= gfc_finish_block (&alloc_block
);
843 /* If mem is not NULL, we issue a runtime error or set the
849 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
&& expr
->symtree
);
850 varname
= gfc_build_cstring_const (expr
->symtree
->name
);
851 varname
= gfc_build_addr_expr (pchar_type_node
, varname
);
853 error
= gfc_trans_runtime_error (true, &expr
->where
,
854 "Attempting to allocate already"
855 " allocated variable '%s'",
859 error
= gfc_trans_runtime_error (true, NULL
,
860 "Attempting to allocate already allocated"
863 if (status
!= NULL_TREE
)
865 tree status_type
= TREE_TYPE (status
);
867 error
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
868 status
, build_int_cst (status_type
, LIBERROR_ALLOCATION
));
871 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, null_mem
,
873 gfc_add_expr_to_block (block
, tmp
);
877 /* Free a given variable. */
880 gfc_call_free (tree var
)
882 return build_call_expr_loc (input_location
,
883 builtin_decl_explicit (BUILT_IN_FREE
),
884 1, fold_convert (pvoid_type_node
, var
));
888 /* Build a call to a FINAL procedure, which finalizes "var". */
891 gfc_build_final_call (gfc_typespec ts
, gfc_expr
*final_wrapper
, gfc_expr
*var
,
892 bool fini_coarray
, gfc_expr
*class_size
)
896 tree final_fndecl
, array
, size
, tmp
;
897 symbol_attribute attr
;
899 gcc_assert (final_wrapper
->expr_type
== EXPR_VARIABLE
);
902 gfc_start_block (&block
);
903 gfc_init_se (&se
, NULL
);
904 gfc_conv_expr (&se
, final_wrapper
);
905 final_fndecl
= se
.expr
;
906 if (POINTER_TYPE_P (TREE_TYPE (final_fndecl
)))
907 final_fndecl
= build_fold_indirect_ref_loc (input_location
, final_fndecl
);
909 if (ts
.type
== BT_DERIVED
)
913 gcc_assert (!class_size
);
914 elem_size
= gfc_typenode_for_spec (&ts
);
915 elem_size
= TYPE_SIZE_UNIT (elem_size
);
916 size
= fold_convert (gfc_array_index_type
, elem_size
);
918 gfc_init_se (&se
, NULL
);
922 se
.descriptor_only
= 1;
923 gfc_conv_expr_descriptor (&se
, var
);
928 gfc_conv_expr (&se
, var
);
929 gcc_assert (se
.pre
.head
== NULL_TREE
&& se
.post
.head
== NULL_TREE
);
932 /* No copy back needed, hence set attr's allocatable/pointer
934 gfc_clear_attr (&attr
);
935 gfc_init_se (&se
, NULL
);
936 array
= gfc_conv_scalar_to_descriptor (&se
, array
, attr
);
937 gcc_assert (se
.post
.head
== NULL_TREE
);
942 gfc_expr
*array_expr
;
943 gcc_assert (class_size
);
944 gfc_init_se (&se
, NULL
);
945 gfc_conv_expr (&se
, class_size
);
946 gfc_add_block_to_block (&block
, &se
.pre
);
947 gcc_assert (se
.post
.head
== NULL_TREE
);
950 array_expr
= gfc_copy_expr (var
);
951 gfc_init_se (&se
, NULL
);
953 if (array_expr
->rank
)
955 gfc_add_class_array_ref (array_expr
);
956 se
.descriptor_only
= 1;
957 gfc_conv_expr_descriptor (&se
, array_expr
);
962 gfc_add_data_component (array_expr
);
963 gfc_conv_expr (&se
, array_expr
);
964 gfc_add_block_to_block (&block
, &se
.pre
);
965 gcc_assert (se
.post
.head
== NULL_TREE
);
967 if (TREE_CODE (array
) == ADDR_EXPR
968 && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (array
, 0))))
969 tmp
= TREE_OPERAND (array
, 0);
971 if (!gfc_is_coarray (array_expr
))
973 /* No copy back needed, hence set attr's allocatable/pointer
975 gfc_clear_attr (&attr
);
976 gfc_init_se (&se
, NULL
);
977 array
= gfc_conv_scalar_to_descriptor (&se
, array
, attr
);
979 gcc_assert (se
.post
.head
== NULL_TREE
);
981 gfc_free_expr (array_expr
);
984 if (!POINTER_TYPE_P (TREE_TYPE (array
)))
985 array
= gfc_build_addr_expr (NULL
, array
);
987 gfc_add_block_to_block (&block
, &se
.pre
);
988 tmp
= build_call_expr_loc (input_location
,
989 final_fndecl
, 3, array
,
990 size
, fini_coarray
? boolean_true_node
991 : boolean_false_node
);
992 gfc_add_block_to_block (&block
, &se
.post
);
993 gfc_add_expr_to_block (&block
, tmp
);
994 return gfc_finish_block (&block
);
999 gfc_add_comp_finalizer_call (stmtblock_t
*block
, tree decl
, gfc_component
*comp
,
1004 tree final_fndecl
, size
, array
, tmp
, cond
;
1005 symbol_attribute attr
;
1006 gfc_expr
*final_expr
= NULL
;
1008 if (comp
->ts
.type
!= BT_DERIVED
&& comp
->ts
.type
!= BT_CLASS
)
1011 gfc_init_block (&block2
);
1013 if (comp
->ts
.type
== BT_DERIVED
)
1015 if (comp
->attr
.pointer
)
1018 gfc_is_finalizable (comp
->ts
.u
.derived
, &final_expr
);
1022 gfc_init_se (&se
, NULL
);
1023 gfc_conv_expr (&se
, final_expr
);
1024 final_fndecl
= se
.expr
;
1025 size
= gfc_typenode_for_spec (&comp
->ts
);
1026 size
= TYPE_SIZE_UNIT (size
);
1027 size
= fold_convert (gfc_array_index_type
, size
);
1031 else /* comp->ts.type == BT_CLASS. */
1033 if (CLASS_DATA (comp
)->attr
.class_pointer
)
1036 gfc_is_finalizable (CLASS_DATA (comp
)->ts
.u
.derived
, &final_expr
);
1037 final_fndecl
= gfc_class_vtab_final_get (decl
);
1038 size
= gfc_class_vtab_size_get (decl
);
1039 array
= gfc_class_data_get (decl
);
1042 if (comp
->attr
.allocatable
1043 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)->attr
.allocatable
))
1045 tmp
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array
))
1046 ? gfc_conv_descriptor_data_get (array
) : array
;
1047 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1048 tmp
, fold_convert (TREE_TYPE (tmp
),
1049 null_pointer_node
));
1052 cond
= boolean_true_node
;
1054 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array
)))
1056 gfc_clear_attr (&attr
);
1057 gfc_init_se (&se
, NULL
);
1058 array
= gfc_conv_scalar_to_descriptor (&se
, array
, attr
);
1059 gfc_add_block_to_block (&block2
, &se
.pre
);
1060 gcc_assert (se
.post
.head
== NULL_TREE
);
1063 if (!POINTER_TYPE_P (TREE_TYPE (array
)))
1064 array
= gfc_build_addr_expr (NULL
, array
);
1068 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1070 fold_convert (TREE_TYPE (final_fndecl
),
1071 null_pointer_node
));
1072 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1073 boolean_type_node
, cond
, tmp
);
1076 if (POINTER_TYPE_P (TREE_TYPE (final_fndecl
)))
1077 final_fndecl
= build_fold_indirect_ref_loc (input_location
, final_fndecl
);
1079 tmp
= build_call_expr_loc (input_location
,
1080 final_fndecl
, 3, array
,
1081 size
, fini_coarray
? boolean_true_node
1082 : boolean_false_node
);
1083 gfc_add_expr_to_block (&block2
, tmp
);
1084 tmp
= gfc_finish_block (&block2
);
1086 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
1087 build_empty_stmt (input_location
));
1088 gfc_add_expr_to_block (block
, tmp
);
1094 /* Add a call to the finalizer, using the passed *expr. Returns
1095 true when a finalizer call has been inserted. */
1098 gfc_add_finalizer_call (stmtblock_t
*block
, gfc_expr
*expr2
)
1103 gfc_expr
*final_expr
= NULL
;
1104 gfc_expr
*elem_size
= NULL
;
1105 bool has_finalizer
= false;
1107 if (!expr2
|| (expr2
->ts
.type
!= BT_DERIVED
&& expr2
->ts
.type
!= BT_CLASS
))
1110 if (expr2
->ts
.type
== BT_DERIVED
)
1112 gfc_is_finalizable (expr2
->ts
.u
.derived
, &final_expr
);
1117 /* If we have a class array, we need go back to the class
1119 expr
= gfc_copy_expr (expr2
);
1121 if (expr
->ref
&& expr
->ref
->next
&& !expr
->ref
->next
->next
1122 && expr
->ref
->next
->type
== REF_ARRAY
1123 && expr
->ref
->type
== REF_COMPONENT
1124 && strcmp (expr
->ref
->u
.c
.component
->name
, "_data") == 0)
1126 gfc_free_ref_list (expr
->ref
);
1130 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1131 if (ref
->next
&& ref
->next
->next
&& !ref
->next
->next
->next
1132 && ref
->next
->next
->type
== REF_ARRAY
1133 && ref
->next
->type
== REF_COMPONENT
1134 && strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0)
1136 gfc_free_ref_list (ref
->next
);
1140 if (expr
->ts
.type
== BT_CLASS
)
1142 has_finalizer
= gfc_is_finalizable (expr
->ts
.u
.derived
, NULL
);
1144 if (!expr2
->rank
&& !expr2
->ref
&& CLASS_DATA (expr2
->symtree
->n
.sym
)->as
)
1145 expr
->rank
= CLASS_DATA (expr2
->symtree
->n
.sym
)->as
->rank
;
1147 final_expr
= gfc_copy_expr (expr
);
1148 gfc_add_vptr_component (final_expr
);
1149 gfc_add_component_ref (final_expr
, "_final");
1151 elem_size
= gfc_copy_expr (expr
);
1152 gfc_add_vptr_component (elem_size
);
1153 gfc_add_component_ref (elem_size
, "_size");
1156 gcc_assert (final_expr
->expr_type
== EXPR_VARIABLE
);
1158 tmp
= gfc_build_final_call (expr
->ts
, final_expr
, expr
,
1161 if (expr
->ts
.type
== BT_CLASS
&& !has_finalizer
)
1166 gfc_init_se (&se
, NULL
);
1167 se
.want_pointer
= 1;
1168 gfc_conv_expr (&se
, final_expr
);
1169 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1170 se
.expr
, build_int_cst (TREE_TYPE (se
.expr
), 0));
1172 /* For CLASS(*) not only sym->_vtab->_final can be NULL
1173 but already sym->_vtab itself. */
1174 if (UNLIMITED_POLY (expr
))
1177 gfc_expr
*vptr_expr
;
1179 vptr_expr
= gfc_copy_expr (expr
);
1180 gfc_add_vptr_component (vptr_expr
);
1182 gfc_init_se (&se
, NULL
);
1183 se
.want_pointer
= 1;
1184 gfc_conv_expr (&se
, vptr_expr
);
1185 gfc_free_expr (vptr_expr
);
1187 cond2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1189 build_int_cst (TREE_TYPE (se
.expr
), 0));
1190 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1191 boolean_type_node
, cond2
, cond
);
1194 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1195 cond
, tmp
, build_empty_stmt (input_location
));
1198 gfc_add_expr_to_block (block
, tmp
);
1204 /* User-deallocate; we emit the code directly from the front-end, and the
1205 logic is the same as the previous library function:
1208 deallocate (void *pointer, GFC_INTEGER_4 * stat)
1215 runtime_error ("Attempt to DEALLOCATE unallocated memory.");
1225 In this front-end version, status doesn't have to be GFC_INTEGER_4.
1226 Moreover, if CAN_FAIL is true, then we will not emit a runtime error,
1227 even when no status variable is passed to us (this is used for
1228 unconditional deallocation generated by the front-end at end of
1231 If a runtime-message is possible, `expr' must point to the original
1232 expression being deallocated for its locus and variable name.
1234 For coarrays, "pointer" must be the array descriptor and not its
1235 "data" component. */
1237 gfc_deallocate_with_status (tree pointer
, tree status
, tree errmsg
,
1238 tree errlen
, tree label_finish
,
1239 bool can_fail
, gfc_expr
* expr
, bool coarray
)
1241 stmtblock_t null
, non_null
;
1242 tree cond
, tmp
, error
;
1243 tree status_type
= NULL_TREE
;
1244 tree caf_decl
= NULL_TREE
;
1248 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer
)));
1250 pointer
= gfc_conv_descriptor_data_get (caf_decl
);
1251 STRIP_NOPS (pointer
);
1254 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, pointer
,
1255 build_int_cst (TREE_TYPE (pointer
), 0));
1257 /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
1258 we emit a runtime error. */
1259 gfc_start_block (&null
);
1264 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
&& expr
->symtree
);
1266 varname
= gfc_build_cstring_const (expr
->symtree
->name
);
1267 varname
= gfc_build_addr_expr (pchar_type_node
, varname
);
1269 error
= gfc_trans_runtime_error (true, &expr
->where
,
1270 "Attempt to DEALLOCATE unallocated '%s'",
1274 error
= build_empty_stmt (input_location
);
1276 if (status
!= NULL_TREE
&& !integer_zerop (status
))
1280 status_type
= TREE_TYPE (TREE_TYPE (status
));
1281 cond2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1282 status
, build_int_cst (TREE_TYPE (status
), 0));
1283 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
1284 fold_build1_loc (input_location
, INDIRECT_REF
,
1285 status_type
, status
),
1286 build_int_cst (status_type
, 1));
1287 error
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1291 gfc_add_expr_to_block (&null
, error
);
1293 /* When POINTER is not NULL, we free it. */
1294 gfc_start_block (&non_null
);
1295 gfc_add_finalizer_call (&non_null
, expr
);
1296 if (!coarray
|| flag_coarray
!= GFC_FCOARRAY_LIB
)
1298 tmp
= build_call_expr_loc (input_location
,
1299 builtin_decl_explicit (BUILT_IN_FREE
), 1,
1300 fold_convert (pvoid_type_node
, pointer
));
1301 gfc_add_expr_to_block (&non_null
, tmp
);
1303 if (status
!= NULL_TREE
&& !integer_zerop (status
))
1305 /* We set STATUS to zero if it is present. */
1306 tree status_type
= TREE_TYPE (TREE_TYPE (status
));
1309 cond2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1311 build_int_cst (TREE_TYPE (status
), 0));
1312 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
1313 fold_build1_loc (input_location
, INDIRECT_REF
,
1314 status_type
, status
),
1315 build_int_cst (status_type
, 0));
1316 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1317 gfc_unlikely (cond2
, PRED_FORTRAN_FAIL_ALLOC
),
1318 tmp
, build_empty_stmt (input_location
));
1319 gfc_add_expr_to_block (&non_null
, tmp
);
1324 tree caf_type
, token
, cond2
;
1325 tree pstat
= null_pointer_node
;
1327 if (errmsg
== NULL_TREE
)
1329 gcc_assert (errlen
== NULL_TREE
);
1330 errmsg
= null_pointer_node
;
1331 errlen
= build_zero_cst (integer_type_node
);
1335 gcc_assert (errlen
!= NULL_TREE
);
1336 if (!POINTER_TYPE_P (TREE_TYPE (errmsg
)))
1337 errmsg
= gfc_build_addr_expr (NULL_TREE
, errmsg
);
1340 caf_type
= TREE_TYPE (caf_decl
);
1342 if (status
!= NULL_TREE
&& !integer_zerop (status
))
1344 gcc_assert (status_type
== integer_type_node
);
1348 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
1349 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
1350 token
= gfc_conv_descriptor_token (caf_decl
);
1351 else if (DECL_LANG_SPECIFIC (caf_decl
)
1352 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
1353 token
= GFC_DECL_TOKEN (caf_decl
);
1356 gcc_assert (GFC_ARRAY_TYPE_P (caf_type
)
1357 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) != NULL_TREE
);
1358 token
= GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
);
1361 token
= gfc_build_addr_expr (NULL_TREE
, token
);
1362 tmp
= build_call_expr_loc (input_location
,
1363 gfor_fndecl_caf_deregister
, 4,
1364 token
, pstat
, errmsg
, errlen
);
1365 gfc_add_expr_to_block (&non_null
, tmp
);
1367 /* It guarantees memory consistency within the same segment */
1368 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
1369 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1370 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
1371 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
1372 ASM_VOLATILE_P (tmp
) = 1;
1373 gfc_add_expr_to_block (&non_null
, tmp
);
1375 if (status
!= NULL_TREE
)
1377 tree stat
= build_fold_indirect_ref_loc (input_location
, status
);
1379 TREE_USED (label_finish
) = 1;
1380 tmp
= build1_v (GOTO_EXPR
, label_finish
);
1381 cond2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1382 stat
, build_zero_cst (TREE_TYPE (stat
)));
1383 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1384 gfc_unlikely (cond2
, PRED_FORTRAN_FAIL_ALLOC
),
1385 tmp
, build_empty_stmt (input_location
));
1386 gfc_add_expr_to_block (&non_null
, tmp
);
1390 return fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
1391 gfc_finish_block (&null
),
1392 gfc_finish_block (&non_null
));
1396 /* Generate code for deallocation of allocatable scalars (variables or
1397 components). Before the object itself is freed, any allocatable
1398 subcomponents are being deallocated. */
1401 gfc_deallocate_scalar_with_status (tree pointer
, tree status
, bool can_fail
,
1402 gfc_expr
* expr
, gfc_typespec ts
)
1404 stmtblock_t null
, non_null
;
1405 tree cond
, tmp
, error
;
1408 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, pointer
,
1409 build_int_cst (TREE_TYPE (pointer
), 0));
1411 /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
1412 we emit a runtime error. */
1413 gfc_start_block (&null
);
1418 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
&& expr
->symtree
);
1420 varname
= gfc_build_cstring_const (expr
->symtree
->name
);
1421 varname
= gfc_build_addr_expr (pchar_type_node
, varname
);
1423 error
= gfc_trans_runtime_error (true, &expr
->where
,
1424 "Attempt to DEALLOCATE unallocated '%s'",
1428 error
= build_empty_stmt (input_location
);
1430 if (status
!= NULL_TREE
&& !integer_zerop (status
))
1432 tree status_type
= TREE_TYPE (TREE_TYPE (status
));
1435 cond2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1436 status
, build_int_cst (TREE_TYPE (status
), 0));
1437 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
1438 fold_build1_loc (input_location
, INDIRECT_REF
,
1439 status_type
, status
),
1440 build_int_cst (status_type
, 1));
1441 error
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1445 gfc_add_expr_to_block (&null
, error
);
1447 /* When POINTER is not NULL, we free it. */
1448 gfc_start_block (&non_null
);
1450 /* Free allocatable components. */
1451 finalizable
= gfc_add_finalizer_call (&non_null
, expr
);
1452 if (!finalizable
&& ts
.type
== BT_DERIVED
&& ts
.u
.derived
->attr
.alloc_comp
)
1454 tmp
= build_fold_indirect_ref_loc (input_location
, pointer
);
1455 tmp
= gfc_deallocate_alloc_comp (ts
.u
.derived
, tmp
, 0);
1456 gfc_add_expr_to_block (&non_null
, tmp
);
1459 tmp
= build_call_expr_loc (input_location
,
1460 builtin_decl_explicit (BUILT_IN_FREE
), 1,
1461 fold_convert (pvoid_type_node
, pointer
));
1462 gfc_add_expr_to_block (&non_null
, tmp
);
1464 if (status
!= NULL_TREE
&& !integer_zerop (status
))
1466 /* We set STATUS to zero if it is present. */
1467 tree status_type
= TREE_TYPE (TREE_TYPE (status
));
1470 cond2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1471 status
, build_int_cst (TREE_TYPE (status
), 0));
1472 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
1473 fold_build1_loc (input_location
, INDIRECT_REF
,
1474 status_type
, status
),
1475 build_int_cst (status_type
, 0));
1476 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
1477 tmp
, build_empty_stmt (input_location
));
1478 gfc_add_expr_to_block (&non_null
, tmp
);
1481 return fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
1482 gfc_finish_block (&null
),
1483 gfc_finish_block (&non_null
));
1487 /* Reallocate MEM so it has SIZE bytes of data. This behaves like the
1488 following pseudo-code:
1491 internal_realloc (void *mem, size_t size)
1493 res = realloc (mem, size);
1494 if (!res && size != 0)
1495 _gfortran_os_error ("Allocation would exceed memory limit");
1500 gfc_call_realloc (stmtblock_t
* block
, tree mem
, tree size
)
1502 tree msg
, res
, nonzero
, null_result
, tmp
;
1503 tree type
= TREE_TYPE (mem
);
1505 /* Only evaluate the size once. */
1506 size
= save_expr (fold_convert (size_type_node
, size
));
1508 /* Create a variable to hold the result. */
1509 res
= gfc_create_var (type
, NULL
);
1511 /* Call realloc and check the result. */
1512 tmp
= build_call_expr_loc (input_location
,
1513 builtin_decl_explicit (BUILT_IN_REALLOC
), 2,
1514 fold_convert (pvoid_type_node
, mem
), size
);
1515 gfc_add_modify (block
, res
, fold_convert (type
, tmp
));
1516 null_result
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1517 res
, build_int_cst (pvoid_type_node
, 0));
1518 nonzero
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, size
,
1519 build_int_cst (size_type_node
, 0));
1520 null_result
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, boolean_type_node
,
1521 null_result
, nonzero
);
1522 msg
= gfc_build_addr_expr (pchar_type_node
, gfc_build_localized_cstring_const
1523 ("Allocation would exceed memory limit"));
1524 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1526 build_call_expr_loc (input_location
,
1527 gfor_fndecl_os_error
, 1, msg
),
1528 build_empty_stmt (input_location
));
1529 gfc_add_expr_to_block (block
, tmp
);
1535 /* Add an expression to another one, either at the front or the back. */
1538 add_expr_to_chain (tree
* chain
, tree expr
, bool front
)
1540 if (expr
== NULL_TREE
|| IS_EMPTY_STMT (expr
))
1545 if (TREE_CODE (*chain
) != STATEMENT_LIST
)
1551 append_to_statement_list (tmp
, chain
);
1556 tree_stmt_iterator i
;
1558 i
= tsi_start (*chain
);
1559 tsi_link_before (&i
, expr
, TSI_CONTINUE_LINKING
);
1562 append_to_statement_list (expr
, chain
);
1569 /* Add a statement at the end of a block. */
1572 gfc_add_expr_to_block (stmtblock_t
* block
, tree expr
)
1575 add_expr_to_chain (&block
->head
, expr
, false);
1579 /* Add a statement at the beginning of a block. */
1582 gfc_prepend_expr_to_block (stmtblock_t
* block
, tree expr
)
1585 add_expr_to_chain (&block
->head
, expr
, true);
1589 /* Add a block the end of a block. */
1592 gfc_add_block_to_block (stmtblock_t
* block
, stmtblock_t
* append
)
1594 gcc_assert (append
);
1595 gcc_assert (!append
->has_scope
);
1597 gfc_add_expr_to_block (block
, append
->head
);
1598 append
->head
= NULL_TREE
;
1602 /* Save the current locus. The structure may not be complete, and should
1603 only be used with gfc_restore_backend_locus. */
1606 gfc_save_backend_locus (locus
* loc
)
1608 loc
->lb
= XCNEW (gfc_linebuf
);
1609 loc
->lb
->location
= input_location
;
1610 loc
->lb
->file
= gfc_current_backend_file
;
1614 /* Set the current locus. */
1617 gfc_set_backend_locus (locus
* loc
)
1619 gfc_current_backend_file
= loc
->lb
->file
;
1620 input_location
= loc
->lb
->location
;
1624 /* Restore the saved locus. Only used in conjunction with
1625 gfc_save_backend_locus, to free the memory when we are done. */
1628 gfc_restore_backend_locus (locus
* loc
)
1630 gfc_set_backend_locus (loc
);
1635 /* Translate an executable statement. The tree cond is used by gfc_trans_do.
1636 This static function is wrapped by gfc_trans_code_cond and
1640 trans_code (gfc_code
* code
, tree cond
)
1646 return build_empty_stmt (input_location
);
1648 gfc_start_block (&block
);
1650 /* Translate statements one by one into GENERIC trees until we reach
1651 the end of this gfc_code branch. */
1652 for (; code
; code
= code
->next
)
1654 if (code
->here
!= 0)
1656 res
= gfc_trans_label_here (code
);
1657 gfc_add_expr_to_block (&block
, res
);
1660 gfc_current_locus
= code
->loc
;
1661 gfc_set_backend_locus (&code
->loc
);
1666 case EXEC_END_BLOCK
:
1667 case EXEC_END_NESTED_BLOCK
:
1668 case EXEC_END_PROCEDURE
:
1673 if (code
->expr1
->ts
.type
== BT_CLASS
)
1674 res
= gfc_trans_class_assign (code
->expr1
, code
->expr2
, code
->op
);
1676 res
= gfc_trans_assign (code
);
1679 case EXEC_LABEL_ASSIGN
:
1680 res
= gfc_trans_label_assign (code
);
1683 case EXEC_POINTER_ASSIGN
:
1684 if (code
->expr1
->ts
.type
== BT_CLASS
)
1685 res
= gfc_trans_class_assign (code
->expr1
, code
->expr2
, code
->op
);
1686 else if (UNLIMITED_POLY (code
->expr2
)
1687 && code
->expr1
->ts
.type
== BT_DERIVED
1688 && (code
->expr1
->ts
.u
.derived
->attr
.sequence
1689 || code
->expr1
->ts
.u
.derived
->attr
.is_bind_c
))
1691 res
= gfc_trans_class_assign (code
->expr1
, code
->expr2
, code
->op
);
1693 res
= gfc_trans_pointer_assign (code
);
1696 case EXEC_INIT_ASSIGN
:
1697 if (code
->expr1
->ts
.type
== BT_CLASS
)
1698 res
= gfc_trans_class_init_assign (code
);
1700 res
= gfc_trans_init_assign (code
);
1708 res
= gfc_trans_critical (code
);
1712 res
= gfc_trans_cycle (code
);
1716 res
= gfc_trans_exit (code
);
1720 res
= gfc_trans_goto (code
);
1724 res
= gfc_trans_entry (code
);
1728 res
= gfc_trans_pause (code
);
1732 case EXEC_ERROR_STOP
:
1733 res
= gfc_trans_stop (code
, code
->op
== EXEC_ERROR_STOP
);
1737 /* For MVBITS we've got the special exception that we need a
1738 dependency check, too. */
1740 bool is_mvbits
= false;
1742 if (code
->resolved_isym
)
1744 res
= gfc_conv_intrinsic_subroutine (code
);
1745 if (res
!= NULL_TREE
)
1749 if (code
->resolved_isym
1750 && code
->resolved_isym
->id
== GFC_ISYM_MVBITS
)
1753 res
= gfc_trans_call (code
, is_mvbits
, NULL_TREE
,
1759 res
= gfc_trans_call (code
, false, NULL_TREE
,
1763 case EXEC_ASSIGN_CALL
:
1764 res
= gfc_trans_call (code
, true, NULL_TREE
,
1769 res
= gfc_trans_return (code
);
1773 res
= gfc_trans_if (code
);
1776 case EXEC_ARITHMETIC_IF
:
1777 res
= gfc_trans_arithmetic_if (code
);
1781 res
= gfc_trans_block_construct (code
);
1785 res
= gfc_trans_do (code
, cond
);
1788 case EXEC_DO_CONCURRENT
:
1789 res
= gfc_trans_do_concurrent (code
);
1793 res
= gfc_trans_do_while (code
);
1797 res
= gfc_trans_select (code
);
1800 case EXEC_SELECT_TYPE
:
1801 /* Do nothing. SELECT TYPE statements should be transformed into
1802 an ordinary SELECT CASE at resolution stage.
1803 TODO: Add an error message here once this is done. */
1808 res
= gfc_trans_flush (code
);
1812 case EXEC_SYNC_IMAGES
:
1813 case EXEC_SYNC_MEMORY
:
1814 res
= gfc_trans_sync (code
, code
->op
);
1819 res
= gfc_trans_lock_unlock (code
, code
->op
);
1822 case EXEC_EVENT_POST
:
1823 case EXEC_EVENT_WAIT
:
1824 res
= gfc_trans_event_post_wait (code
, code
->op
);
1828 res
= gfc_trans_forall (code
);
1832 res
= gfc_trans_where (code
);
1836 res
= gfc_trans_allocate (code
);
1839 case EXEC_DEALLOCATE
:
1840 res
= gfc_trans_deallocate (code
);
1844 res
= gfc_trans_open (code
);
1848 res
= gfc_trans_close (code
);
1852 res
= gfc_trans_read (code
);
1856 res
= gfc_trans_write (code
);
1860 res
= gfc_trans_iolength (code
);
1863 case EXEC_BACKSPACE
:
1864 res
= gfc_trans_backspace (code
);
1868 res
= gfc_trans_endfile (code
);
1872 res
= gfc_trans_inquire (code
);
1876 res
= gfc_trans_wait (code
);
1880 res
= gfc_trans_rewind (code
);
1884 res
= gfc_trans_transfer (code
);
1888 res
= gfc_trans_dt_end (code
);
1891 case EXEC_OMP_ATOMIC
:
1892 case EXEC_OMP_BARRIER
:
1893 case EXEC_OMP_CANCEL
:
1894 case EXEC_OMP_CANCELLATION_POINT
:
1895 case EXEC_OMP_CRITICAL
:
1896 case EXEC_OMP_DISTRIBUTE
:
1897 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
1898 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
1899 case EXEC_OMP_DISTRIBUTE_SIMD
:
1901 case EXEC_OMP_DO_SIMD
:
1902 case EXEC_OMP_FLUSH
:
1903 case EXEC_OMP_MASTER
:
1904 case EXEC_OMP_ORDERED
:
1905 case EXEC_OMP_PARALLEL
:
1906 case EXEC_OMP_PARALLEL_DO
:
1907 case EXEC_OMP_PARALLEL_DO_SIMD
:
1908 case EXEC_OMP_PARALLEL_SECTIONS
:
1909 case EXEC_OMP_PARALLEL_WORKSHARE
:
1910 case EXEC_OMP_SECTIONS
:
1912 case EXEC_OMP_SINGLE
:
1913 case EXEC_OMP_TARGET
:
1914 case EXEC_OMP_TARGET_DATA
:
1915 case EXEC_OMP_TARGET_TEAMS
:
1916 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
1917 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
1918 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
1919 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
1920 case EXEC_OMP_TARGET_UPDATE
:
1922 case EXEC_OMP_TASKGROUP
:
1923 case EXEC_OMP_TASKWAIT
:
1924 case EXEC_OMP_TASKYIELD
:
1925 case EXEC_OMP_TEAMS
:
1926 case EXEC_OMP_TEAMS_DISTRIBUTE
:
1927 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
1928 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
1929 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
1930 case EXEC_OMP_WORKSHARE
:
1931 res
= gfc_trans_omp_directive (code
);
1934 case EXEC_OACC_CACHE
:
1935 case EXEC_OACC_WAIT
:
1936 case EXEC_OACC_UPDATE
:
1937 case EXEC_OACC_LOOP
:
1938 case EXEC_OACC_HOST_DATA
:
1939 case EXEC_OACC_DATA
:
1940 case EXEC_OACC_KERNELS
:
1941 case EXEC_OACC_KERNELS_LOOP
:
1942 case EXEC_OACC_PARALLEL
:
1943 case EXEC_OACC_PARALLEL_LOOP
:
1944 case EXEC_OACC_ENTER_DATA
:
1945 case EXEC_OACC_EXIT_DATA
:
1946 case EXEC_OACC_ATOMIC
:
1947 case EXEC_OACC_DECLARE
:
1948 res
= gfc_trans_oacc_directive (code
);
1952 gfc_internal_error ("gfc_trans_code(): Bad statement code");
1955 gfc_set_backend_locus (&code
->loc
);
1957 if (res
!= NULL_TREE
&& ! IS_EMPTY_STMT (res
))
1959 if (TREE_CODE (res
) != STATEMENT_LIST
)
1960 SET_EXPR_LOCATION (res
, input_location
);
1962 /* Add the new statement to the block. */
1963 gfc_add_expr_to_block (&block
, res
);
1967 /* Return the finished block. */
1968 return gfc_finish_block (&block
);
1972 /* Translate an executable statement with condition, cond. The condition is
1973 used by gfc_trans_do to test for IO result conditions inside implied
1974 DO loops of READ and WRITE statements. See build_dt in trans-io.c. */
1977 gfc_trans_code_cond (gfc_code
* code
, tree cond
)
1979 return trans_code (code
, cond
);
1982 /* Translate an executable statement without condition. */
1985 gfc_trans_code (gfc_code
* code
)
1987 return trans_code (code
, NULL_TREE
);
1991 /* This function is called after a complete program unit has been parsed
1995 gfc_generate_code (gfc_namespace
* ns
)
1998 if (ns
->is_block_data
)
2000 gfc_generate_block_data (ns
);
2004 gfc_generate_function_code (ns
);
2008 /* This function is called after a complete module has been parsed
2012 gfc_generate_module_code (gfc_namespace
* ns
)
2015 struct module_htab_entry
*entry
;
2017 gcc_assert (ns
->proc_name
->backend_decl
== NULL
);
2018 ns
->proc_name
->backend_decl
2019 = build_decl (ns
->proc_name
->declared_at
.lb
->location
,
2020 NAMESPACE_DECL
, get_identifier (ns
->proc_name
->name
),
2022 entry
= gfc_find_module (ns
->proc_name
->name
);
2023 if (entry
->namespace_decl
)
2024 /* Buggy sourcecode, using a module before defining it? */
2025 entry
->decls
->empty ();
2026 entry
->namespace_decl
= ns
->proc_name
->backend_decl
;
2028 gfc_generate_module_vars (ns
);
2030 /* We need to generate all module function prototypes first, to allow
2032 for (n
= ns
->contained
; n
; n
= n
->sibling
)
2039 gfc_create_function_decl (n
, false);
2040 DECL_CONTEXT (n
->proc_name
->backend_decl
) = ns
->proc_name
->backend_decl
;
2041 gfc_module_add_decl (entry
, n
->proc_name
->backend_decl
);
2042 for (el
= ns
->entries
; el
; el
= el
->next
)
2044 DECL_CONTEXT (el
->sym
->backend_decl
) = ns
->proc_name
->backend_decl
;
2045 gfc_module_add_decl (entry
, el
->sym
->backend_decl
);
2049 for (n
= ns
->contained
; n
; n
= n
->sibling
)
2054 gfc_generate_function_code (n
);
2059 /* Initialize an init/cleanup block with existing code. */
2062 gfc_start_wrapped_block (gfc_wrapped_block
* block
, tree code
)
2066 block
->init
= NULL_TREE
;
2068 block
->cleanup
= NULL_TREE
;
2072 /* Add a new pair of initializers/clean-up code. */
2075 gfc_add_init_cleanup (gfc_wrapped_block
* block
, tree init
, tree cleanup
)
2079 /* The new pair of init/cleanup should be "wrapped around" the existing
2080 block of code, thus the initialization is added to the front and the
2081 cleanup to the back. */
2082 add_expr_to_chain (&block
->init
, init
, true);
2083 add_expr_to_chain (&block
->cleanup
, cleanup
, false);
2087 /* Finish up a wrapped block by building a corresponding try-finally expr. */
2090 gfc_finish_wrapped_block (gfc_wrapped_block
* block
)
2096 /* Build the final expression. For this, just add init and body together,
2097 and put clean-up with that into a TRY_FINALLY_EXPR. */
2098 result
= block
->init
;
2099 add_expr_to_chain (&result
, block
->code
, false);
2101 result
= build2_loc (input_location
, TRY_FINALLY_EXPR
, void_type_node
,
2102 result
, block
->cleanup
);
2104 /* Clear the block. */
2105 block
->init
= NULL_TREE
;
2106 block
->code
= NULL_TREE
;
2107 block
->cleanup
= NULL_TREE
;
2113 /* Helper function for marking a boolean expression tree as unlikely. */
2116 gfc_unlikely (tree cond
, enum br_predictor predictor
)
2122 cond
= fold_convert (long_integer_type_node
, cond
);
2123 tmp
= build_zero_cst (long_integer_type_node
);
2124 cond
= build_call_expr_loc (input_location
,
2125 builtin_decl_explicit (BUILT_IN_EXPECT
),
2127 build_int_cst (integer_type_node
,
2130 cond
= fold_convert (boolean_type_node
, cond
);
2135 /* Helper function for marking a boolean expression tree as likely. */
2138 gfc_likely (tree cond
, enum br_predictor predictor
)
2144 cond
= fold_convert (long_integer_type_node
, cond
);
2145 tmp
= build_one_cst (long_integer_type_node
);
2146 cond
= build_call_expr_loc (input_location
,
2147 builtin_decl_explicit (BUILT_IN_EXPECT
),
2149 build_int_cst (integer_type_node
,
2152 cond
= fold_convert (boolean_type_node
, cond
);
2157 /* Get the string length for a deferred character length component. */
2160 gfc_deferred_strlen (gfc_component
*c
, tree
*decl
)
2162 char name
[GFC_MAX_SYMBOL_LEN
+9];
2163 gfc_component
*strlen
;
2164 if (!(c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
))
2166 sprintf (name
, "_%s_length", c
->name
);
2167 for (strlen
= c
; strlen
; strlen
= strlen
->next
)
2168 if (strcmp (strlen
->name
, name
) == 0)
2170 *decl
= strlen
? strlen
->backend_decl
: NULL_TREE
;
2171 return strlen
!= NULL
;