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"
33 #include "fold-const.h"
34 #include "gimple-expr.h" /* For create_tmp_var_raw. */
35 #include "stringpool.h"
36 #include "tree-iterator.h"
37 #include "diagnostic-core.h" /* For internal_error. */
40 #include "trans-stmt.h"
41 #include "trans-array.h"
42 #include "trans-types.h"
43 #include "trans-const.h"
45 /* Naming convention for backend interface code:
47 gfc_trans_* translate gfc_code into STMT trees.
49 gfc_conv_* expression conversion
51 gfc_get_* get a backend tree representation of a decl or type */
53 static gfc_file
*gfc_current_backend_file
;
55 const char gfc_msg_fault
[] = N_("Array reference out of bounds");
56 const char gfc_msg_wrong_return
[] = N_("Incorrect function return value");
59 /* Advance along TREE_CHAIN n times. */
62 gfc_advance_chain (tree t
, int n
)
66 gcc_assert (t
!= NULL_TREE
);
73 /* Strip off a legitimate source ending from the input
74 string NAME of length LEN. */
77 remove_suffix (char *name
, int len
)
81 for (i
= 2; i
< 8 && len
> i
; i
++)
83 if (name
[len
- i
] == '.')
92 /* Creates a variable declaration with a given TYPE. */
95 gfc_create_var_np (tree type
, const char *prefix
)
99 t
= create_tmp_var_raw (type
, prefix
);
101 /* No warnings for anonymous variables. */
103 TREE_NO_WARNING (t
) = 1;
109 /* Like above, but also adds it to the current scope. */
112 gfc_create_var (tree type
, const char *prefix
)
116 tmp
= gfc_create_var_np (type
, prefix
);
124 /* If the expression is not constant, evaluate it now. We assign the
125 result of the expression to an artificially created variable VAR, and
126 return a pointer to the VAR_DECL node for this variable. */
129 gfc_evaluate_now_loc (location_t loc
, tree expr
, stmtblock_t
* pblock
)
133 if (CONSTANT_CLASS_P (expr
))
136 var
= gfc_create_var (TREE_TYPE (expr
), NULL
);
137 gfc_add_modify_loc (loc
, pblock
, var
, expr
);
144 gfc_evaluate_now (tree expr
, stmtblock_t
* pblock
)
146 return gfc_evaluate_now_loc (input_location
, expr
, pblock
);
150 /* Build a MODIFY_EXPR node and add it to a given statement block PBLOCK.
151 A MODIFY_EXPR is an assignment:
155 gfc_add_modify_loc (location_t loc
, stmtblock_t
* pblock
, tree lhs
, tree rhs
)
159 #ifdef ENABLE_CHECKING
161 t1
= TREE_TYPE (rhs
);
162 t2
= TREE_TYPE (lhs
);
163 /* Make sure that the types of the rhs and the lhs are the same
164 for scalar assignments. We should probably have something
165 similar for aggregates, but right now removing that check just
166 breaks everything. */
168 || AGGREGATE_TYPE_P (TREE_TYPE (lhs
)));
171 tmp
= fold_build2_loc (loc
, MODIFY_EXPR
, void_type_node
, lhs
,
173 gfc_add_expr_to_block (pblock
, tmp
);
178 gfc_add_modify (stmtblock_t
* pblock
, tree lhs
, tree rhs
)
180 gfc_add_modify_loc (input_location
, pblock
, lhs
, rhs
);
184 /* Create a new scope/binding level and initialize a block. Care must be
185 taken when translating expressions as any temporaries will be placed in
186 the innermost scope. */
189 gfc_start_block (stmtblock_t
* block
)
191 /* Start a new binding level. */
193 block
->has_scope
= 1;
195 /* The block is empty. */
196 block
->head
= NULL_TREE
;
200 /* Initialize a block without creating a new scope. */
203 gfc_init_block (stmtblock_t
* block
)
205 block
->head
= NULL_TREE
;
206 block
->has_scope
= 0;
210 /* Sometimes we create a scope but it turns out that we don't actually
211 need it. This function merges the scope of BLOCK with its parent.
212 Only variable decls will be merged, you still need to add the code. */
215 gfc_merge_block_scope (stmtblock_t
* block
)
220 gcc_assert (block
->has_scope
);
221 block
->has_scope
= 0;
223 /* Remember the decls in this scope. */
227 /* Add them to the parent scope. */
228 while (decl
!= NULL_TREE
)
230 next
= DECL_CHAIN (decl
);
231 DECL_CHAIN (decl
) = NULL_TREE
;
239 /* Finish a scope containing a block of statements. */
242 gfc_finish_block (stmtblock_t
* stmtblock
)
248 expr
= stmtblock
->head
;
250 expr
= build_empty_stmt (input_location
);
252 stmtblock
->head
= NULL_TREE
;
254 if (stmtblock
->has_scope
)
260 block
= poplevel (1, 0);
261 expr
= build3_v (BIND_EXPR
, decl
, expr
, block
);
271 /* Build an ADDR_EXPR and cast the result to TYPE. If TYPE is NULL, the
272 natural type is used. */
275 gfc_build_addr_expr (tree type
, tree t
)
277 tree base_type
= TREE_TYPE (t
);
280 if (type
&& POINTER_TYPE_P (type
)
281 && TREE_CODE (base_type
) == ARRAY_TYPE
282 && TYPE_MAIN_VARIANT (TREE_TYPE (type
))
283 == TYPE_MAIN_VARIANT (TREE_TYPE (base_type
)))
285 tree min_val
= size_zero_node
;
286 tree type_domain
= TYPE_DOMAIN (base_type
);
287 if (type_domain
&& TYPE_MIN_VALUE (type_domain
))
288 min_val
= TYPE_MIN_VALUE (type_domain
);
289 t
= fold (build4_loc (input_location
, ARRAY_REF
, TREE_TYPE (type
),
290 t
, min_val
, NULL_TREE
, NULL_TREE
));
294 natural_type
= build_pointer_type (base_type
);
296 if (TREE_CODE (t
) == INDIRECT_REF
)
300 t
= TREE_OPERAND (t
, 0);
301 natural_type
= TREE_TYPE (t
);
305 tree base
= get_base_address (t
);
306 if (base
&& DECL_P (base
))
307 TREE_ADDRESSABLE (base
) = 1;
308 t
= fold_build1_loc (input_location
, ADDR_EXPR
, natural_type
, t
);
311 if (type
&& natural_type
!= type
)
312 t
= convert (type
, t
);
318 /* Build an ARRAY_REF with its natural type. */
321 gfc_build_array_ref (tree base
, tree offset
, tree decl
, tree vptr
)
323 tree type
= TREE_TYPE (base
);
327 if (GFC_ARRAY_TYPE_P (type
) && GFC_TYPE_ARRAY_RANK (type
) == 0)
329 gcc_assert (GFC_TYPE_ARRAY_CORANK (type
) > 0);
331 return fold_convert (TYPE_MAIN_VARIANT (type
), base
);
334 /* Scalar coarray, there is nothing to do. */
335 if (TREE_CODE (type
) != ARRAY_TYPE
)
337 gcc_assert (decl
== NULL_TREE
);
338 gcc_assert (integer_zerop (offset
));
342 type
= TREE_TYPE (type
);
345 TREE_ADDRESSABLE (base
) = 1;
347 /* Strip NON_LVALUE_EXPR nodes. */
348 STRIP_TYPE_NOPS (offset
);
350 /* If the array reference is to a pointer, whose target contains a
351 subreference, use the span that is stored with the backend decl
352 and reference the element with pointer arithmetic. */
353 if ((decl
&& (TREE_CODE (decl
) == FIELD_DECL
354 || TREE_CODE (decl
) == VAR_DECL
355 || TREE_CODE (decl
) == PARM_DECL
)
356 && ((GFC_DECL_SUBREF_ARRAY_P (decl
)
357 && !integer_zerop (GFC_DECL_SPAN (decl
)))
358 || GFC_DECL_CLASS (decl
)))
363 if (GFC_DECL_CLASS (decl
))
365 /* When a temporary is in place for the class array, then the
366 original class' declaration is stored in the saved
368 if (DECL_LANG_SPECIFIC (decl
) && GFC_DECL_SAVED_DESCRIPTOR (decl
))
369 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
372 /* Allow for dummy arguments and other good things. */
373 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
374 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
376 /* Check if '_data' is an array descriptor. If it is not,
377 the array must be one of the components of the class
378 object, so return a normal array reference. */
379 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (
380 gfc_class_data_get (decl
))))
381 return build4_loc (input_location
, ARRAY_REF
, type
, base
,
382 offset
, NULL_TREE
, NULL_TREE
);
385 span
= gfc_class_vtab_size_get (decl
);
387 else if (GFC_DECL_SUBREF_ARRAY_P (decl
))
388 span
= GFC_DECL_SPAN (decl
);
393 span
= gfc_vptr_size_get (vptr
);
397 offset
= fold_build2_loc (input_location
, MULT_EXPR
,
398 gfc_array_index_type
,
400 tmp
= gfc_build_addr_expr (pvoid_type_node
, base
);
401 tmp
= fold_build_pointer_plus_loc (input_location
, tmp
, offset
);
402 tmp
= fold_convert (build_pointer_type (type
), tmp
);
403 if (!TYPE_STRING_FLAG (type
))
404 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
408 /* Otherwise use a straightforward array reference. */
409 return build4_loc (input_location
, ARRAY_REF
, type
, base
, offset
,
410 NULL_TREE
, NULL_TREE
);
414 /* Generate a call to print a runtime error possibly including multiple
415 arguments and a locus. */
418 trans_runtime_error_vararg (bool error
, locus
* where
, const char* msgid
,
431 /* Compute the number of extra arguments from the format string. */
432 for (p
= msgid
, nargs
= 0; *p
; p
++)
440 /* The code to generate the error. */
441 gfc_start_block (&block
);
445 line
= LOCATION_LINE (where
->lb
->location
);
446 message
= xasprintf ("At line %d of file %s", line
,
447 where
->lb
->file
->filename
);
450 message
= xasprintf ("In file '%s', around line %d",
451 gfc_source_file
, LOCATION_LINE (input_location
) + 1);
453 arg
= gfc_build_addr_expr (pchar_type_node
,
454 gfc_build_localized_cstring_const (message
));
457 message
= xasprintf ("%s", _(msgid
));
458 arg2
= gfc_build_addr_expr (pchar_type_node
,
459 gfc_build_localized_cstring_const (message
));
462 /* Build the argument array. */
463 argarray
= XALLOCAVEC (tree
, nargs
+ 2);
466 for (i
= 0; i
< nargs
; i
++)
467 argarray
[2 + i
] = va_arg (ap
, tree
);
469 /* Build the function call to runtime_(warning,error)_at; because of the
470 variable number of arguments, we can't use build_call_expr_loc dinput_location,
473 fntype
= TREE_TYPE (gfor_fndecl_runtime_error_at
);
475 fntype
= TREE_TYPE (gfor_fndecl_runtime_warning_at
);
477 loc
= where
? where
->lb
->location
: input_location
;
478 tmp
= fold_build_call_array_loc (loc
, TREE_TYPE (fntype
),
479 fold_build1_loc (loc
, ADDR_EXPR
,
480 build_pointer_type (fntype
),
482 ? gfor_fndecl_runtime_error_at
483 : gfor_fndecl_runtime_warning_at
),
484 nargs
+ 2, argarray
);
485 gfc_add_expr_to_block (&block
, tmp
);
487 return gfc_finish_block (&block
);
492 gfc_trans_runtime_error (bool error
, locus
* where
, const char* msgid
, ...)
497 va_start (ap
, msgid
);
498 result
= trans_runtime_error_vararg (error
, where
, msgid
, ap
);
504 /* Generate a runtime error if COND is true. */
507 gfc_trans_runtime_check (bool error
, bool once
, tree cond
, stmtblock_t
* pblock
,
508 locus
* where
, const char * msgid
, ...)
516 if (integer_zerop (cond
))
521 tmpvar
= gfc_create_var (boolean_type_node
, "print_warning");
522 TREE_STATIC (tmpvar
) = 1;
523 DECL_INITIAL (tmpvar
) = boolean_true_node
;
524 gfc_add_expr_to_block (pblock
, tmpvar
);
527 gfc_start_block (&block
);
529 /* For error, runtime_error_at already implies PRED_NORETURN. */
531 gfc_add_expr_to_block (&block
, build_predict_expr (PRED_FORTRAN_WARN_ONCE
,
534 /* The code to generate the error. */
535 va_start (ap
, msgid
);
536 gfc_add_expr_to_block (&block
,
537 trans_runtime_error_vararg (error
, where
,
542 gfc_add_modify (&block
, tmpvar
, boolean_false_node
);
544 body
= gfc_finish_block (&block
);
546 if (integer_onep (cond
))
548 gfc_add_expr_to_block (pblock
, body
);
553 cond
= fold_build2_loc (where
->lb
->location
, TRUTH_AND_EXPR
,
554 long_integer_type_node
, tmpvar
, cond
);
556 cond
= fold_convert (long_integer_type_node
, cond
);
558 tmp
= fold_build3_loc (where
->lb
->location
, COND_EXPR
, void_type_node
,
560 build_empty_stmt (where
->lb
->location
));
561 gfc_add_expr_to_block (pblock
, tmp
);
566 /* Call malloc to allocate size bytes of memory, with special conditions:
567 + if size == 0, return a malloced area of size 1,
568 + if malloc returns NULL, issue a runtime error. */
570 gfc_call_malloc (stmtblock_t
* block
, tree type
, tree size
)
572 tree tmp
, msg
, malloc_result
, null_result
, res
, malloc_tree
;
575 size
= gfc_evaluate_now (size
, block
);
577 if (TREE_TYPE (size
) != TREE_TYPE (size_type_node
))
578 size
= fold_convert (size_type_node
, size
);
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_build2_loc (input_location
, MAX_EXPR
, size_type_node
, size
,
587 build_int_cst (size_type_node
, 1));
589 malloc_tree
= builtin_decl_explicit (BUILT_IN_MALLOC
);
590 gfc_add_modify (&block2
, res
,
591 fold_convert (prvoid_type_node
,
592 build_call_expr_loc (input_location
,
593 malloc_tree
, 1, size
)));
595 /* Optionally check whether malloc was successful. */
596 if (gfc_option
.rtcheck
& GFC_RTCHECK_MEM
)
598 null_result
= fold_build2_loc (input_location
, EQ_EXPR
,
599 boolean_type_node
, res
,
600 build_int_cst (pvoid_type_node
, 0));
601 msg
= gfc_build_addr_expr (pchar_type_node
,
602 gfc_build_localized_cstring_const ("Memory allocation failed"));
603 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
605 build_call_expr_loc (input_location
,
606 gfor_fndecl_os_error
, 1, msg
),
607 build_empty_stmt (input_location
));
608 gfc_add_expr_to_block (&block2
, tmp
);
611 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 /* Evaluate size only once, and make sure it has the right type. */
652 size
= gfc_evaluate_now (size
, block
);
653 if (TREE_TYPE (size
) != TREE_TYPE (size_type_node
))
654 size
= fold_convert (size_type_node
, size
);
656 /* If successful and stat= is given, set status to 0. */
657 if (status
!= NULL_TREE
)
658 gfc_add_expr_to_block (block
,
659 fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
660 status
, build_int_cst (status_type
, 0)));
662 /* The allocation itself. */
663 gfc_add_modify (block
, pointer
,
664 fold_convert (TREE_TYPE (pointer
),
665 build_call_expr_loc (input_location
,
666 builtin_decl_explicit (BUILT_IN_MALLOC
), 1,
667 fold_build2_loc (input_location
,
668 MAX_EXPR
, size_type_node
, size
,
669 build_int_cst (size_type_node
, 1)))));
671 /* What to do in case of error. */
672 gfc_start_block (&on_error
);
673 if (status
!= NULL_TREE
)
675 gfc_add_expr_to_block (&on_error
,
676 build_predict_expr (PRED_FORTRAN_FAIL_ALLOC
,
678 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
, status
,
679 build_int_cst (status_type
, LIBERROR_ALLOCATION
));
680 gfc_add_expr_to_block (&on_error
, tmp
);
684 /* Here, os_error already implies PRED_NORETURN. */
685 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_os_error
, 1,
686 gfc_build_addr_expr (pchar_type_node
,
687 gfc_build_localized_cstring_const
688 ("Allocation would exceed memory limit")));
689 gfc_add_expr_to_block (&on_error
, tmp
);
692 error_cond
= fold_build2_loc (input_location
, EQ_EXPR
,
693 boolean_type_node
, pointer
,
694 build_int_cst (prvoid_type_node
, 0));
695 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
696 error_cond
, gfc_finish_block (&on_error
),
697 build_empty_stmt (input_location
));
699 gfc_add_expr_to_block (block
, tmp
);
703 /* Allocate memory, using an optional status argument.
705 This function follows the following pseudo-code:
708 allocate (size_t size, void** token, int *stat, char* errmsg, int errlen)
712 newmem = _caf_register (size, regtype, token, &stat, errmsg, errlen);
716 gfc_allocate_using_lib (stmtblock_t
* block
, tree pointer
, tree size
,
717 tree token
, tree status
, tree errmsg
, tree errlen
,
722 gcc_assert (token
!= NULL_TREE
);
724 /* Evaluate size only once, and make sure it has the right type. */
725 size
= gfc_evaluate_now (size
, block
);
726 if (TREE_TYPE (size
) != TREE_TYPE (size_type_node
))
727 size
= fold_convert (size_type_node
, size
);
729 /* The allocation itself. */
730 if (status
== NULL_TREE
)
731 pstat
= null_pointer_node
;
733 pstat
= gfc_build_addr_expr (NULL_TREE
, status
);
735 if (errmsg
== NULL_TREE
)
737 gcc_assert(errlen
== NULL_TREE
);
738 errmsg
= null_pointer_node
;
739 errlen
= build_int_cst (integer_type_node
, 0);
742 tmp
= build_call_expr_loc (input_location
,
743 gfor_fndecl_caf_register
, 6,
744 fold_build2_loc (input_location
,
745 MAX_EXPR
, size_type_node
, size
,
746 build_int_cst (size_type_node
, 1)),
747 build_int_cst (integer_type_node
,
748 lock_var
? GFC_CAF_LOCK_ALLOC
749 : GFC_CAF_COARRAY_ALLOC
),
750 token
, pstat
, errmsg
, errlen
);
752 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
753 TREE_TYPE (pointer
), pointer
,
754 fold_convert ( TREE_TYPE (pointer
), tmp
));
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
, tree token
,
783 tree status
, tree errmsg
, tree errlen
, tree label_finish
,
786 stmtblock_t alloc_block
;
787 tree tmp
, null_mem
, alloc
, error
;
788 tree type
= TREE_TYPE (mem
);
790 if (TREE_TYPE (size
) != TREE_TYPE (size_type_node
))
791 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_FAIL_ALLOC
);
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 && gfc_expr_attr (expr
).codimension
)
806 bool lock_var
= expr
->ts
.type
== BT_DERIVED
807 && expr
->ts
.u
.derived
->from_intmod
808 == INTMOD_ISO_FORTRAN_ENV
809 && expr
->ts
.u
.derived
->intmod_sym_id
810 == ISOFORTRAN_LOCK_TYPE
;
811 /* In the front end, we represent the lock variable as pointer. However,
812 the FE only passes the pointer around and leaves the actual
813 representation to the library. Hence, we have to convert back to the
814 number of elements. */
816 size
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, size_type_node
,
817 size
, TYPE_SIZE_UNIT (ptr_type_node
));
819 gfc_allocate_using_lib (&alloc_block
, mem
, size
, token
, status
,
820 errmsg
, errlen
, lock_var
);
822 if (status
!= NULL_TREE
)
824 TREE_USED (label_finish
) = 1;
825 tmp
= build1_v (GOTO_EXPR
, label_finish
);
826 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
827 status
, build_zero_cst (TREE_TYPE (status
)));
828 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
829 gfc_unlikely (cond
, PRED_FORTRAN_FAIL_ALLOC
),
830 tmp
, build_empty_stmt (input_location
));
831 gfc_add_expr_to_block (&alloc_block
, tmp
);
835 gfc_allocate_using_malloc (&alloc_block
, mem
, size
, status
);
837 alloc
= gfc_finish_block (&alloc_block
);
839 /* If mem is not NULL, we issue a runtime error or set the
845 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
&& expr
->symtree
);
846 varname
= gfc_build_cstring_const (expr
->symtree
->name
);
847 varname
= gfc_build_addr_expr (pchar_type_node
, varname
);
849 error
= gfc_trans_runtime_error (true, &expr
->where
,
850 "Attempting to allocate already"
851 " allocated variable '%s'",
855 error
= gfc_trans_runtime_error (true, NULL
,
856 "Attempting to allocate already allocated"
859 if (status
!= NULL_TREE
)
861 tree status_type
= TREE_TYPE (status
);
863 error
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
864 status
, build_int_cst (status_type
, LIBERROR_ALLOCATION
));
867 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, null_mem
,
869 gfc_add_expr_to_block (block
, tmp
);
873 /* Free a given variable, if it's not NULL. */
875 gfc_call_free (tree var
)
878 tree tmp
, cond
, call
;
880 if (TREE_TYPE (var
) != TREE_TYPE (pvoid_type_node
))
881 var
= fold_convert (pvoid_type_node
, var
);
883 gfc_start_block (&block
);
884 var
= gfc_evaluate_now (var
, &block
);
885 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, var
,
886 build_int_cst (pvoid_type_node
, 0));
887 call
= build_call_expr_loc (input_location
,
888 builtin_decl_explicit (BUILT_IN_FREE
),
890 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, call
,
891 build_empty_stmt (input_location
));
892 gfc_add_expr_to_block (&block
, tmp
);
894 return gfc_finish_block (&block
);
898 /* Build a call to a FINAL procedure, which finalizes "var". */
901 gfc_build_final_call (gfc_typespec ts
, gfc_expr
*final_wrapper
, gfc_expr
*var
,
902 bool fini_coarray
, gfc_expr
*class_size
)
906 tree final_fndecl
, array
, size
, tmp
;
907 symbol_attribute attr
;
909 gcc_assert (final_wrapper
->expr_type
== EXPR_VARIABLE
);
912 gfc_start_block (&block
);
913 gfc_init_se (&se
, NULL
);
914 gfc_conv_expr (&se
, final_wrapper
);
915 final_fndecl
= se
.expr
;
916 if (POINTER_TYPE_P (TREE_TYPE (final_fndecl
)))
917 final_fndecl
= build_fold_indirect_ref_loc (input_location
, final_fndecl
);
919 if (ts
.type
== BT_DERIVED
)
923 gcc_assert (!class_size
);
924 elem_size
= gfc_typenode_for_spec (&ts
);
925 elem_size
= TYPE_SIZE_UNIT (elem_size
);
926 size
= fold_convert (gfc_array_index_type
, elem_size
);
928 gfc_init_se (&se
, NULL
);
932 se
.descriptor_only
= 1;
933 gfc_conv_expr_descriptor (&se
, var
);
938 gfc_conv_expr (&se
, var
);
939 gcc_assert (se
.pre
.head
== NULL_TREE
&& se
.post
.head
== NULL_TREE
);
942 /* No copy back needed, hence set attr's allocatable/pointer
944 gfc_clear_attr (&attr
);
945 gfc_init_se (&se
, NULL
);
946 array
= gfc_conv_scalar_to_descriptor (&se
, array
, attr
);
947 gcc_assert (se
.post
.head
== NULL_TREE
);
952 gfc_expr
*array_expr
;
953 gcc_assert (class_size
);
954 gfc_init_se (&se
, NULL
);
955 gfc_conv_expr (&se
, class_size
);
956 gfc_add_block_to_block (&block
, &se
.pre
);
957 gcc_assert (se
.post
.head
== NULL_TREE
);
960 array_expr
= gfc_copy_expr (var
);
961 gfc_init_se (&se
, NULL
);
963 if (array_expr
->rank
)
965 gfc_add_class_array_ref (array_expr
);
966 se
.descriptor_only
= 1;
967 gfc_conv_expr_descriptor (&se
, array_expr
);
972 gfc_add_data_component (array_expr
);
973 gfc_conv_expr (&se
, array_expr
);
974 gfc_add_block_to_block (&block
, &se
.pre
);
975 gcc_assert (se
.post
.head
== NULL_TREE
);
977 if (TREE_CODE (array
) == ADDR_EXPR
978 && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (array
, 0))))
979 tmp
= TREE_OPERAND (array
, 0);
981 if (!gfc_is_coarray (array_expr
))
983 /* No copy back needed, hence set attr's allocatable/pointer
985 gfc_clear_attr (&attr
);
986 gfc_init_se (&se
, NULL
);
987 array
= gfc_conv_scalar_to_descriptor (&se
, array
, attr
);
989 gcc_assert (se
.post
.head
== NULL_TREE
);
991 gfc_free_expr (array_expr
);
994 if (!POINTER_TYPE_P (TREE_TYPE (array
)))
995 array
= gfc_build_addr_expr (NULL
, array
);
997 gfc_add_block_to_block (&block
, &se
.pre
);
998 tmp
= build_call_expr_loc (input_location
,
999 final_fndecl
, 3, array
,
1000 size
, fini_coarray
? boolean_true_node
1001 : boolean_false_node
);
1002 gfc_add_block_to_block (&block
, &se
.post
);
1003 gfc_add_expr_to_block (&block
, tmp
);
1004 return gfc_finish_block (&block
);
1009 gfc_add_comp_finalizer_call (stmtblock_t
*block
, tree decl
, gfc_component
*comp
,
1014 tree final_fndecl
, size
, array
, tmp
, cond
;
1015 symbol_attribute attr
;
1016 gfc_expr
*final_expr
= NULL
;
1018 if (comp
->ts
.type
!= BT_DERIVED
&& comp
->ts
.type
!= BT_CLASS
)
1021 gfc_init_block (&block2
);
1023 if (comp
->ts
.type
== BT_DERIVED
)
1025 if (comp
->attr
.pointer
)
1028 gfc_is_finalizable (comp
->ts
.u
.derived
, &final_expr
);
1032 gfc_init_se (&se
, NULL
);
1033 gfc_conv_expr (&se
, final_expr
);
1034 final_fndecl
= se
.expr
;
1035 size
= gfc_typenode_for_spec (&comp
->ts
);
1036 size
= TYPE_SIZE_UNIT (size
);
1037 size
= fold_convert (gfc_array_index_type
, size
);
1041 else /* comp->ts.type == BT_CLASS. */
1043 if (CLASS_DATA (comp
)->attr
.class_pointer
)
1046 gfc_is_finalizable (CLASS_DATA (comp
)->ts
.u
.derived
, &final_expr
);
1047 final_fndecl
= gfc_class_vtab_final_get (decl
);
1048 size
= gfc_class_vtab_size_get (decl
);
1049 array
= gfc_class_data_get (decl
);
1052 if (comp
->attr
.allocatable
1053 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)->attr
.allocatable
))
1055 tmp
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array
))
1056 ? gfc_conv_descriptor_data_get (array
) : array
;
1057 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1058 tmp
, fold_convert (TREE_TYPE (tmp
),
1059 null_pointer_node
));
1062 cond
= boolean_true_node
;
1064 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array
)))
1066 gfc_clear_attr (&attr
);
1067 gfc_init_se (&se
, NULL
);
1068 array
= gfc_conv_scalar_to_descriptor (&se
, array
, attr
);
1069 gfc_add_block_to_block (&block2
, &se
.pre
);
1070 gcc_assert (se
.post
.head
== NULL_TREE
);
1073 if (!POINTER_TYPE_P (TREE_TYPE (array
)))
1074 array
= gfc_build_addr_expr (NULL
, array
);
1078 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1080 fold_convert (TREE_TYPE (final_fndecl
),
1081 null_pointer_node
));
1082 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1083 boolean_type_node
, cond
, tmp
);
1086 if (POINTER_TYPE_P (TREE_TYPE (final_fndecl
)))
1087 final_fndecl
= build_fold_indirect_ref_loc (input_location
, final_fndecl
);
1089 tmp
= build_call_expr_loc (input_location
,
1090 final_fndecl
, 3, array
,
1091 size
, fini_coarray
? boolean_true_node
1092 : boolean_false_node
);
1093 gfc_add_expr_to_block (&block2
, tmp
);
1094 tmp
= gfc_finish_block (&block2
);
1096 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
1097 build_empty_stmt (input_location
));
1098 gfc_add_expr_to_block (block
, tmp
);
1104 /* Add a call to the finalizer, using the passed *expr. Returns
1105 true when a finalizer call has been inserted. */
1108 gfc_add_finalizer_call (stmtblock_t
*block
, gfc_expr
*expr2
)
1113 gfc_expr
*final_expr
= NULL
;
1114 gfc_expr
*elem_size
= NULL
;
1115 bool has_finalizer
= false;
1117 if (!expr2
|| (expr2
->ts
.type
!= BT_DERIVED
&& expr2
->ts
.type
!= BT_CLASS
))
1120 if (expr2
->ts
.type
== BT_DERIVED
)
1122 gfc_is_finalizable (expr2
->ts
.u
.derived
, &final_expr
);
1127 /* If we have a class array, we need go back to the class
1129 expr
= gfc_copy_expr (expr2
);
1131 if (expr
->ref
&& expr
->ref
->next
&& !expr
->ref
->next
->next
1132 && expr
->ref
->next
->type
== REF_ARRAY
1133 && expr
->ref
->type
== REF_COMPONENT
1134 && strcmp (expr
->ref
->u
.c
.component
->name
, "_data") == 0)
1136 gfc_free_ref_list (expr
->ref
);
1140 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1141 if (ref
->next
&& ref
->next
->next
&& !ref
->next
->next
->next
1142 && ref
->next
->next
->type
== REF_ARRAY
1143 && ref
->next
->type
== REF_COMPONENT
1144 && strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0)
1146 gfc_free_ref_list (ref
->next
);
1150 if (expr
->ts
.type
== BT_CLASS
)
1152 has_finalizer
= gfc_is_finalizable (expr
->ts
.u
.derived
, NULL
);
1154 if (!expr2
->rank
&& !expr2
->ref
&& CLASS_DATA (expr2
->symtree
->n
.sym
)->as
)
1155 expr
->rank
= CLASS_DATA (expr2
->symtree
->n
.sym
)->as
->rank
;
1157 final_expr
= gfc_copy_expr (expr
);
1158 gfc_add_vptr_component (final_expr
);
1159 gfc_add_component_ref (final_expr
, "_final");
1161 elem_size
= gfc_copy_expr (expr
);
1162 gfc_add_vptr_component (elem_size
);
1163 gfc_add_component_ref (elem_size
, "_size");
1166 gcc_assert (final_expr
->expr_type
== EXPR_VARIABLE
);
1168 tmp
= gfc_build_final_call (expr
->ts
, final_expr
, expr
,
1171 if (expr
->ts
.type
== BT_CLASS
&& !has_finalizer
)
1176 gfc_init_se (&se
, NULL
);
1177 se
.want_pointer
= 1;
1178 gfc_conv_expr (&se
, final_expr
);
1179 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1180 se
.expr
, build_int_cst (TREE_TYPE (se
.expr
), 0));
1182 /* For CLASS(*) not only sym->_vtab->_final can be NULL
1183 but already sym->_vtab itself. */
1184 if (UNLIMITED_POLY (expr
))
1187 gfc_expr
*vptr_expr
;
1189 vptr_expr
= gfc_copy_expr (expr
);
1190 gfc_add_vptr_component (vptr_expr
);
1192 gfc_init_se (&se
, NULL
);
1193 se
.want_pointer
= 1;
1194 gfc_conv_expr (&se
, vptr_expr
);
1195 gfc_free_expr (vptr_expr
);
1197 cond2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1199 build_int_cst (TREE_TYPE (se
.expr
), 0));
1200 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1201 boolean_type_node
, cond2
, cond
);
1204 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1205 cond
, tmp
, build_empty_stmt (input_location
));
1208 gfc_add_expr_to_block (block
, tmp
);
1214 /* User-deallocate; we emit the code directly from the front-end, and the
1215 logic is the same as the previous library function:
1218 deallocate (void *pointer, GFC_INTEGER_4 * stat)
1225 runtime_error ("Attempt to DEALLOCATE unallocated memory.");
1235 In this front-end version, status doesn't have to be GFC_INTEGER_4.
1236 Moreover, if CAN_FAIL is true, then we will not emit a runtime error,
1237 even when no status variable is passed to us (this is used for
1238 unconditional deallocation generated by the front-end at end of
1241 If a runtime-message is possible, `expr' must point to the original
1242 expression being deallocated for its locus and variable name.
1244 For coarrays, "pointer" must be the array descriptor and not its
1245 "data" component. */
1247 gfc_deallocate_with_status (tree pointer
, tree status
, tree errmsg
,
1248 tree errlen
, tree label_finish
,
1249 bool can_fail
, gfc_expr
* expr
, bool coarray
)
1251 stmtblock_t null
, non_null
;
1252 tree cond
, tmp
, error
;
1253 tree status_type
= NULL_TREE
;
1254 tree caf_decl
= NULL_TREE
;
1258 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer
)));
1260 pointer
= gfc_conv_descriptor_data_get (caf_decl
);
1261 STRIP_NOPS (pointer
);
1264 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, pointer
,
1265 build_int_cst (TREE_TYPE (pointer
), 0));
1267 /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
1268 we emit a runtime error. */
1269 gfc_start_block (&null
);
1274 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
&& expr
->symtree
);
1276 varname
= gfc_build_cstring_const (expr
->symtree
->name
);
1277 varname
= gfc_build_addr_expr (pchar_type_node
, varname
);
1279 error
= gfc_trans_runtime_error (true, &expr
->where
,
1280 "Attempt to DEALLOCATE unallocated '%s'",
1284 error
= build_empty_stmt (input_location
);
1286 if (status
!= NULL_TREE
&& !integer_zerop (status
))
1290 status_type
= TREE_TYPE (TREE_TYPE (status
));
1291 cond2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1292 status
, build_int_cst (TREE_TYPE (status
), 0));
1293 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
1294 fold_build1_loc (input_location
, INDIRECT_REF
,
1295 status_type
, status
),
1296 build_int_cst (status_type
, 1));
1297 error
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1301 gfc_add_expr_to_block (&null
, error
);
1303 /* When POINTER is not NULL, we free it. */
1304 gfc_start_block (&non_null
);
1305 gfc_add_finalizer_call (&non_null
, expr
);
1306 if (!coarray
|| flag_coarray
!= GFC_FCOARRAY_LIB
)
1308 tmp
= build_call_expr_loc (input_location
,
1309 builtin_decl_explicit (BUILT_IN_FREE
), 1,
1310 fold_convert (pvoid_type_node
, pointer
));
1311 gfc_add_expr_to_block (&non_null
, tmp
);
1313 if (status
!= NULL_TREE
&& !integer_zerop (status
))
1315 /* We set STATUS to zero if it is present. */
1316 tree status_type
= TREE_TYPE (TREE_TYPE (status
));
1319 cond2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1321 build_int_cst (TREE_TYPE (status
), 0));
1322 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
1323 fold_build1_loc (input_location
, INDIRECT_REF
,
1324 status_type
, status
),
1325 build_int_cst (status_type
, 0));
1326 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1327 gfc_unlikely (cond2
, PRED_FORTRAN_FAIL_ALLOC
),
1328 tmp
, build_empty_stmt (input_location
));
1329 gfc_add_expr_to_block (&non_null
, tmp
);
1334 tree caf_type
, token
, cond2
;
1335 tree pstat
= null_pointer_node
;
1337 if (errmsg
== NULL_TREE
)
1339 gcc_assert (errlen
== NULL_TREE
);
1340 errmsg
= null_pointer_node
;
1341 errlen
= build_zero_cst (integer_type_node
);
1345 gcc_assert (errlen
!= NULL_TREE
);
1346 if (!POINTER_TYPE_P (TREE_TYPE (errmsg
)))
1347 errmsg
= gfc_build_addr_expr (NULL_TREE
, errmsg
);
1350 caf_type
= TREE_TYPE (caf_decl
);
1352 if (status
!= NULL_TREE
&& !integer_zerop (status
))
1354 gcc_assert (status_type
== integer_type_node
);
1358 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
1359 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
1360 token
= gfc_conv_descriptor_token (caf_decl
);
1361 else if (DECL_LANG_SPECIFIC (caf_decl
)
1362 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
1363 token
= GFC_DECL_TOKEN (caf_decl
);
1366 gcc_assert (GFC_ARRAY_TYPE_P (caf_type
)
1367 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) != NULL_TREE
);
1368 token
= GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
);
1371 token
= gfc_build_addr_expr (NULL_TREE
, token
);
1372 tmp
= build_call_expr_loc (input_location
,
1373 gfor_fndecl_caf_deregister
, 4,
1374 token
, pstat
, errmsg
, errlen
);
1375 gfc_add_expr_to_block (&non_null
, tmp
);
1377 if (status
!= NULL_TREE
)
1379 tree stat
= build_fold_indirect_ref_loc (input_location
, status
);
1381 TREE_USED (label_finish
) = 1;
1382 tmp
= build1_v (GOTO_EXPR
, label_finish
);
1383 cond2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1384 stat
, build_zero_cst (TREE_TYPE (stat
)));
1385 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1386 gfc_unlikely (cond2
, PRED_FORTRAN_FAIL_ALLOC
),
1387 tmp
, build_empty_stmt (input_location
));
1388 gfc_add_expr_to_block (&non_null
, tmp
);
1392 return fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
1393 gfc_finish_block (&null
),
1394 gfc_finish_block (&non_null
));
1398 /* Generate code for deallocation of allocatable scalars (variables or
1399 components). Before the object itself is freed, any allocatable
1400 subcomponents are being deallocated. */
1403 gfc_deallocate_scalar_with_status (tree pointer
, tree status
, bool can_fail
,
1404 gfc_expr
* expr
, gfc_typespec ts
)
1406 stmtblock_t null
, non_null
;
1407 tree cond
, tmp
, error
;
1410 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, pointer
,
1411 build_int_cst (TREE_TYPE (pointer
), 0));
1413 /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
1414 we emit a runtime error. */
1415 gfc_start_block (&null
);
1420 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
&& expr
->symtree
);
1422 varname
= gfc_build_cstring_const (expr
->symtree
->name
);
1423 varname
= gfc_build_addr_expr (pchar_type_node
, varname
);
1425 error
= gfc_trans_runtime_error (true, &expr
->where
,
1426 "Attempt to DEALLOCATE unallocated '%s'",
1430 error
= build_empty_stmt (input_location
);
1432 if (status
!= NULL_TREE
&& !integer_zerop (status
))
1434 tree status_type
= TREE_TYPE (TREE_TYPE (status
));
1437 cond2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1438 status
, build_int_cst (TREE_TYPE (status
), 0));
1439 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
1440 fold_build1_loc (input_location
, INDIRECT_REF
,
1441 status_type
, status
),
1442 build_int_cst (status_type
, 1));
1443 error
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1447 gfc_add_expr_to_block (&null
, error
);
1449 /* When POINTER is not NULL, we free it. */
1450 gfc_start_block (&non_null
);
1452 /* Free allocatable components. */
1453 finalizable
= gfc_add_finalizer_call (&non_null
, expr
);
1454 if (!finalizable
&& ts
.type
== BT_DERIVED
&& ts
.u
.derived
->attr
.alloc_comp
)
1456 tmp
= build_fold_indirect_ref_loc (input_location
, pointer
);
1457 tmp
= gfc_deallocate_alloc_comp (ts
.u
.derived
, tmp
, 0);
1458 gfc_add_expr_to_block (&non_null
, tmp
);
1461 tmp
= build_call_expr_loc (input_location
,
1462 builtin_decl_explicit (BUILT_IN_FREE
), 1,
1463 fold_convert (pvoid_type_node
, pointer
));
1464 gfc_add_expr_to_block (&non_null
, tmp
);
1466 if (status
!= NULL_TREE
&& !integer_zerop (status
))
1468 /* We set STATUS to zero if it is present. */
1469 tree status_type
= TREE_TYPE (TREE_TYPE (status
));
1472 cond2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1473 status
, build_int_cst (TREE_TYPE (status
), 0));
1474 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
1475 fold_build1_loc (input_location
, INDIRECT_REF
,
1476 status_type
, status
),
1477 build_int_cst (status_type
, 0));
1478 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
1479 tmp
, build_empty_stmt (input_location
));
1480 gfc_add_expr_to_block (&non_null
, tmp
);
1483 return fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
1484 gfc_finish_block (&null
),
1485 gfc_finish_block (&non_null
));
1489 /* Reallocate MEM so it has SIZE bytes of data. This behaves like the
1490 following pseudo-code:
1493 internal_realloc (void *mem, size_t size)
1495 res = realloc (mem, size);
1496 if (!res && size != 0)
1497 _gfortran_os_error ("Allocation would exceed memory limit");
1502 gfc_call_realloc (stmtblock_t
* block
, tree mem
, tree size
)
1504 tree msg
, res
, nonzero
, null_result
, tmp
;
1505 tree type
= TREE_TYPE (mem
);
1507 size
= gfc_evaluate_now (size
, block
);
1509 if (TREE_TYPE (size
) != TREE_TYPE (size_type_node
))
1510 size
= fold_convert (size_type_node
, size
);
1512 /* Create a variable to hold the result. */
1513 res
= gfc_create_var (type
, NULL
);
1515 /* Call realloc and check the result. */
1516 tmp
= build_call_expr_loc (input_location
,
1517 builtin_decl_explicit (BUILT_IN_REALLOC
), 2,
1518 fold_convert (pvoid_type_node
, mem
), size
);
1519 gfc_add_modify (block
, res
, fold_convert (type
, tmp
));
1520 null_result
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1521 res
, build_int_cst (pvoid_type_node
, 0));
1522 nonzero
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, size
,
1523 build_int_cst (size_type_node
, 0));
1524 null_result
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, boolean_type_node
,
1525 null_result
, nonzero
);
1526 msg
= gfc_build_addr_expr (pchar_type_node
, gfc_build_localized_cstring_const
1527 ("Allocation would exceed memory limit"));
1528 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1530 build_call_expr_loc (input_location
,
1531 gfor_fndecl_os_error
, 1, msg
),
1532 build_empty_stmt (input_location
));
1533 gfc_add_expr_to_block (block
, tmp
);
1539 /* Add an expression to another one, either at the front or the back. */
1542 add_expr_to_chain (tree
* chain
, tree expr
, bool front
)
1544 if (expr
== NULL_TREE
|| IS_EMPTY_STMT (expr
))
1549 if (TREE_CODE (*chain
) != STATEMENT_LIST
)
1555 append_to_statement_list (tmp
, chain
);
1560 tree_stmt_iterator i
;
1562 i
= tsi_start (*chain
);
1563 tsi_link_before (&i
, expr
, TSI_CONTINUE_LINKING
);
1566 append_to_statement_list (expr
, chain
);
1573 /* Add a statement at the end of a block. */
1576 gfc_add_expr_to_block (stmtblock_t
* block
, tree expr
)
1579 add_expr_to_chain (&block
->head
, expr
, false);
1583 /* Add a statement at the beginning of a block. */
1586 gfc_prepend_expr_to_block (stmtblock_t
* block
, tree expr
)
1589 add_expr_to_chain (&block
->head
, expr
, true);
1593 /* Add a block the end of a block. */
1596 gfc_add_block_to_block (stmtblock_t
* block
, stmtblock_t
* append
)
1598 gcc_assert (append
);
1599 gcc_assert (!append
->has_scope
);
1601 gfc_add_expr_to_block (block
, append
->head
);
1602 append
->head
= NULL_TREE
;
1606 /* Save the current locus. The structure may not be complete, and should
1607 only be used with gfc_restore_backend_locus. */
1610 gfc_save_backend_locus (locus
* loc
)
1612 loc
->lb
= XCNEW (gfc_linebuf
);
1613 loc
->lb
->location
= input_location
;
1614 loc
->lb
->file
= gfc_current_backend_file
;
1618 /* Set the current locus. */
1621 gfc_set_backend_locus (locus
* loc
)
1623 gfc_current_backend_file
= loc
->lb
->file
;
1624 input_location
= loc
->lb
->location
;
1628 /* Restore the saved locus. Only used in conjunction with
1629 gfc_save_backend_locus, to free the memory when we are done. */
1632 gfc_restore_backend_locus (locus
* loc
)
1634 gfc_set_backend_locus (loc
);
1639 /* Translate an executable statement. The tree cond is used by gfc_trans_do.
1640 This static function is wrapped by gfc_trans_code_cond and
1644 trans_code (gfc_code
* code
, tree cond
)
1650 return build_empty_stmt (input_location
);
1652 gfc_start_block (&block
);
1654 /* Translate statements one by one into GENERIC trees until we reach
1655 the end of this gfc_code branch. */
1656 for (; code
; code
= code
->next
)
1658 if (code
->here
!= 0)
1660 res
= gfc_trans_label_here (code
);
1661 gfc_add_expr_to_block (&block
, res
);
1664 gfc_set_backend_locus (&code
->loc
);
1669 case EXEC_END_BLOCK
:
1670 case EXEC_END_NESTED_BLOCK
:
1671 case EXEC_END_PROCEDURE
:
1676 if (code
->expr1
->ts
.type
== BT_CLASS
)
1677 res
= gfc_trans_class_assign (code
->expr1
, code
->expr2
, code
->op
);
1679 res
= gfc_trans_assign (code
);
1682 case EXEC_LABEL_ASSIGN
:
1683 res
= gfc_trans_label_assign (code
);
1686 case EXEC_POINTER_ASSIGN
:
1687 if (code
->expr1
->ts
.type
== BT_CLASS
)
1688 res
= gfc_trans_class_assign (code
->expr1
, code
->expr2
, code
->op
);
1689 else if (UNLIMITED_POLY (code
->expr2
)
1690 && code
->expr1
->ts
.type
== BT_DERIVED
1691 && (code
->expr1
->ts
.u
.derived
->attr
.sequence
1692 || code
->expr1
->ts
.u
.derived
->attr
.is_bind_c
))
1694 res
= gfc_trans_class_assign (code
->expr1
, code
->expr2
, code
->op
);
1696 res
= gfc_trans_pointer_assign (code
);
1699 case EXEC_INIT_ASSIGN
:
1700 if (code
->expr1
->ts
.type
== BT_CLASS
)
1701 res
= gfc_trans_class_init_assign (code
);
1703 res
= gfc_trans_init_assign (code
);
1711 res
= gfc_trans_critical (code
);
1715 res
= gfc_trans_cycle (code
);
1719 res
= gfc_trans_exit (code
);
1723 res
= gfc_trans_goto (code
);
1727 res
= gfc_trans_entry (code
);
1731 res
= gfc_trans_pause (code
);
1735 case EXEC_ERROR_STOP
:
1736 res
= gfc_trans_stop (code
, code
->op
== EXEC_ERROR_STOP
);
1740 /* For MVBITS we've got the special exception that we need a
1741 dependency check, too. */
1743 bool is_mvbits
= false;
1745 if (code
->resolved_isym
)
1747 res
= gfc_conv_intrinsic_subroutine (code
);
1748 if (res
!= NULL_TREE
)
1752 if (code
->resolved_isym
1753 && code
->resolved_isym
->id
== GFC_ISYM_MVBITS
)
1756 res
= gfc_trans_call (code
, is_mvbits
, NULL_TREE
,
1762 res
= gfc_trans_call (code
, false, NULL_TREE
,
1766 case EXEC_ASSIGN_CALL
:
1767 res
= gfc_trans_call (code
, true, NULL_TREE
,
1772 res
= gfc_trans_return (code
);
1776 res
= gfc_trans_if (code
);
1779 case EXEC_ARITHMETIC_IF
:
1780 res
= gfc_trans_arithmetic_if (code
);
1784 res
= gfc_trans_block_construct (code
);
1788 res
= gfc_trans_do (code
, cond
);
1791 case EXEC_DO_CONCURRENT
:
1792 res
= gfc_trans_do_concurrent (code
);
1796 res
= gfc_trans_do_while (code
);
1800 res
= gfc_trans_select (code
);
1803 case EXEC_SELECT_TYPE
:
1804 /* Do nothing. SELECT TYPE statements should be transformed into
1805 an ordinary SELECT CASE at resolution stage.
1806 TODO: Add an error message here once this is done. */
1811 res
= gfc_trans_flush (code
);
1815 case EXEC_SYNC_IMAGES
:
1816 case EXEC_SYNC_MEMORY
:
1817 res
= gfc_trans_sync (code
, code
->op
);
1822 res
= gfc_trans_lock_unlock (code
, code
->op
);
1826 res
= gfc_trans_forall (code
);
1830 res
= gfc_trans_where (code
);
1834 res
= gfc_trans_allocate (code
);
1837 case EXEC_DEALLOCATE
:
1838 res
= gfc_trans_deallocate (code
);
1842 res
= gfc_trans_open (code
);
1846 res
= gfc_trans_close (code
);
1850 res
= gfc_trans_read (code
);
1854 res
= gfc_trans_write (code
);
1858 res
= gfc_trans_iolength (code
);
1861 case EXEC_BACKSPACE
:
1862 res
= gfc_trans_backspace (code
);
1866 res
= gfc_trans_endfile (code
);
1870 res
= gfc_trans_inquire (code
);
1874 res
= gfc_trans_wait (code
);
1878 res
= gfc_trans_rewind (code
);
1882 res
= gfc_trans_transfer (code
);
1886 res
= gfc_trans_dt_end (code
);
1889 case EXEC_OMP_ATOMIC
:
1890 case EXEC_OMP_BARRIER
:
1891 case EXEC_OMP_CANCEL
:
1892 case EXEC_OMP_CANCELLATION_POINT
:
1893 case EXEC_OMP_CRITICAL
:
1894 case EXEC_OMP_DISTRIBUTE
:
1895 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
1896 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
1897 case EXEC_OMP_DISTRIBUTE_SIMD
:
1899 case EXEC_OMP_DO_SIMD
:
1900 case EXEC_OMP_FLUSH
:
1901 case EXEC_OMP_MASTER
:
1902 case EXEC_OMP_ORDERED
:
1903 case EXEC_OMP_PARALLEL
:
1904 case EXEC_OMP_PARALLEL_DO
:
1905 case EXEC_OMP_PARALLEL_DO_SIMD
:
1906 case EXEC_OMP_PARALLEL_SECTIONS
:
1907 case EXEC_OMP_PARALLEL_WORKSHARE
:
1908 case EXEC_OMP_SECTIONS
:
1910 case EXEC_OMP_SINGLE
:
1911 case EXEC_OMP_TARGET
:
1912 case EXEC_OMP_TARGET_DATA
:
1913 case EXEC_OMP_TARGET_TEAMS
:
1914 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
1915 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
1916 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
1917 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
1918 case EXEC_OMP_TARGET_UPDATE
:
1920 case EXEC_OMP_TASKGROUP
:
1921 case EXEC_OMP_TASKWAIT
:
1922 case EXEC_OMP_TASKYIELD
:
1923 case EXEC_OMP_TEAMS
:
1924 case EXEC_OMP_TEAMS_DISTRIBUTE
:
1925 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
1926 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
1927 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
1928 case EXEC_OMP_WORKSHARE
:
1929 res
= gfc_trans_omp_directive (code
);
1932 case EXEC_OACC_CACHE
:
1933 case EXEC_OACC_WAIT
:
1934 case EXEC_OACC_UPDATE
:
1935 case EXEC_OACC_LOOP
:
1936 case EXEC_OACC_HOST_DATA
:
1937 case EXEC_OACC_DATA
:
1938 case EXEC_OACC_KERNELS
:
1939 case EXEC_OACC_KERNELS_LOOP
:
1940 case EXEC_OACC_PARALLEL
:
1941 case EXEC_OACC_PARALLEL_LOOP
:
1942 case EXEC_OACC_ENTER_DATA
:
1943 case EXEC_OACC_EXIT_DATA
:
1944 res
= gfc_trans_oacc_directive (code
);
1948 gfc_internal_error ("gfc_trans_code(): Bad statement code");
1951 gfc_set_backend_locus (&code
->loc
);
1953 if (res
!= NULL_TREE
&& ! IS_EMPTY_STMT (res
))
1955 if (TREE_CODE (res
) != STATEMENT_LIST
)
1956 SET_EXPR_LOCATION (res
, input_location
);
1958 /* Add the new statement to the block. */
1959 gfc_add_expr_to_block (&block
, res
);
1963 /* Return the finished block. */
1964 return gfc_finish_block (&block
);
1968 /* Translate an executable statement with condition, cond. The condition is
1969 used by gfc_trans_do to test for IO result conditions inside implied
1970 DO loops of READ and WRITE statements. See build_dt in trans-io.c. */
1973 gfc_trans_code_cond (gfc_code
* code
, tree cond
)
1975 return trans_code (code
, cond
);
1978 /* Translate an executable statement without condition. */
1981 gfc_trans_code (gfc_code
* code
)
1983 return trans_code (code
, NULL_TREE
);
1987 /* This function is called after a complete program unit has been parsed
1991 gfc_generate_code (gfc_namespace
* ns
)
1994 if (ns
->is_block_data
)
1996 gfc_generate_block_data (ns
);
2000 gfc_generate_function_code (ns
);
2004 /* This function is called after a complete module has been parsed
2008 gfc_generate_module_code (gfc_namespace
* ns
)
2011 struct module_htab_entry
*entry
;
2013 gcc_assert (ns
->proc_name
->backend_decl
== NULL
);
2014 ns
->proc_name
->backend_decl
2015 = build_decl (ns
->proc_name
->declared_at
.lb
->location
,
2016 NAMESPACE_DECL
, get_identifier (ns
->proc_name
->name
),
2018 entry
= gfc_find_module (ns
->proc_name
->name
);
2019 if (entry
->namespace_decl
)
2020 /* Buggy sourcecode, using a module before defining it? */
2021 entry
->decls
->empty ();
2022 entry
->namespace_decl
= ns
->proc_name
->backend_decl
;
2024 gfc_generate_module_vars (ns
);
2026 /* We need to generate all module function prototypes first, to allow
2028 for (n
= ns
->contained
; n
; n
= n
->sibling
)
2035 gfc_create_function_decl (n
, false);
2036 DECL_CONTEXT (n
->proc_name
->backend_decl
) = ns
->proc_name
->backend_decl
;
2037 gfc_module_add_decl (entry
, n
->proc_name
->backend_decl
);
2038 for (el
= ns
->entries
; el
; el
= el
->next
)
2040 DECL_CONTEXT (el
->sym
->backend_decl
) = ns
->proc_name
->backend_decl
;
2041 gfc_module_add_decl (entry
, el
->sym
->backend_decl
);
2045 for (n
= ns
->contained
; n
; n
= n
->sibling
)
2050 gfc_generate_function_code (n
);
2055 /* Initialize an init/cleanup block with existing code. */
2058 gfc_start_wrapped_block (gfc_wrapped_block
* block
, tree code
)
2062 block
->init
= NULL_TREE
;
2064 block
->cleanup
= NULL_TREE
;
2068 /* Add a new pair of initializers/clean-up code. */
2071 gfc_add_init_cleanup (gfc_wrapped_block
* block
, tree init
, tree cleanup
)
2075 /* The new pair of init/cleanup should be "wrapped around" the existing
2076 block of code, thus the initialization is added to the front and the
2077 cleanup to the back. */
2078 add_expr_to_chain (&block
->init
, init
, true);
2079 add_expr_to_chain (&block
->cleanup
, cleanup
, false);
2083 /* Finish up a wrapped block by building a corresponding try-finally expr. */
2086 gfc_finish_wrapped_block (gfc_wrapped_block
* block
)
2092 /* Build the final expression. For this, just add init and body together,
2093 and put clean-up with that into a TRY_FINALLY_EXPR. */
2094 result
= block
->init
;
2095 add_expr_to_chain (&result
, block
->code
, false);
2097 result
= build2_loc (input_location
, TRY_FINALLY_EXPR
, void_type_node
,
2098 result
, block
->cleanup
);
2100 /* Clear the block. */
2101 block
->init
= NULL_TREE
;
2102 block
->code
= NULL_TREE
;
2103 block
->cleanup
= NULL_TREE
;
2109 /* Helper function for marking a boolean expression tree as unlikely. */
2112 gfc_unlikely (tree cond
, enum br_predictor predictor
)
2118 cond
= fold_convert (long_integer_type_node
, cond
);
2119 tmp
= build_zero_cst (long_integer_type_node
);
2120 cond
= build_call_expr_loc (input_location
,
2121 builtin_decl_explicit (BUILT_IN_EXPECT
),
2123 build_int_cst (integer_type_node
,
2126 cond
= fold_convert (boolean_type_node
, cond
);
2131 /* Helper function for marking a boolean expression tree as likely. */
2134 gfc_likely (tree cond
, enum br_predictor predictor
)
2140 cond
= fold_convert (long_integer_type_node
, cond
);
2141 tmp
= build_one_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 /* Get the string length for a deferred character length component. */
2156 gfc_deferred_strlen (gfc_component
*c
, tree
*decl
)
2158 char name
[GFC_MAX_SYMBOL_LEN
+9];
2159 gfc_component
*strlen
;
2160 if (!(c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
))
2162 sprintf (name
, "_%s_length", c
->name
);
2163 for (strlen
= c
; strlen
; strlen
= strlen
->next
)
2164 if (strcmp (strlen
->name
, name
) == 0)
2166 *decl
= strlen
? strlen
->backend_decl
: NULL_TREE
;
2167 return strlen
!= NULL
;