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"
28 #include "fold-const.h"
29 #include "gimple-expr.h" /* For create_tmp_var_raw. */
30 #include "stringpool.h"
31 #include "tree-iterator.h"
32 #include "diagnostic-core.h" /* For internal_error. */
35 #include "trans-stmt.h"
36 #include "trans-array.h"
37 #include "trans-types.h"
38 #include "trans-const.h"
40 /* Naming convention for backend interface code:
42 gfc_trans_* translate gfc_code into STMT trees.
44 gfc_conv_* expression conversion
46 gfc_get_* get a backend tree representation of a decl or type */
48 static gfc_file
*gfc_current_backend_file
;
50 const char gfc_msg_fault
[] = N_("Array reference out of bounds");
51 const char gfc_msg_wrong_return
[] = N_("Incorrect function return value");
54 /* Advance along TREE_CHAIN n times. */
57 gfc_advance_chain (tree t
, int n
)
61 gcc_assert (t
!= NULL_TREE
);
68 /* Strip off a legitimate source ending from the input
69 string NAME of length LEN. */
72 remove_suffix (char *name
, int len
)
76 for (i
= 2; i
< 8 && len
> i
; i
++)
78 if (name
[len
- i
] == '.')
87 /* Creates a variable declaration with a given TYPE. */
90 gfc_create_var_np (tree type
, const char *prefix
)
94 t
= create_tmp_var_raw (type
, prefix
);
96 /* No warnings for anonymous variables. */
98 TREE_NO_WARNING (t
) = 1;
104 /* Like above, but also adds it to the current scope. */
107 gfc_create_var (tree type
, const char *prefix
)
111 tmp
= gfc_create_var_np (type
, prefix
);
119 /* If the expression is not constant, evaluate it now. We assign the
120 result of the expression to an artificially created variable VAR, and
121 return a pointer to the VAR_DECL node for this variable. */
124 gfc_evaluate_now_loc (location_t loc
, tree expr
, stmtblock_t
* pblock
)
128 if (CONSTANT_CLASS_P (expr
))
131 var
= gfc_create_var (TREE_TYPE (expr
), NULL
);
132 gfc_add_modify_loc (loc
, pblock
, var
, expr
);
139 gfc_evaluate_now (tree expr
, stmtblock_t
* pblock
)
141 return gfc_evaluate_now_loc (input_location
, expr
, pblock
);
145 /* Build a MODIFY_EXPR node and add it to a given statement block PBLOCK.
146 A MODIFY_EXPR is an assignment:
150 gfc_add_modify_loc (location_t loc
, stmtblock_t
* pblock
, tree lhs
, tree rhs
)
154 #ifdef ENABLE_CHECKING
156 t1
= TREE_TYPE (rhs
);
157 t2
= TREE_TYPE (lhs
);
158 /* Make sure that the types of the rhs and the lhs are the same
159 for scalar assignments. We should probably have something
160 similar for aggregates, but right now removing that check just
161 breaks everything. */
163 || AGGREGATE_TYPE_P (TREE_TYPE (lhs
)));
166 tmp
= fold_build2_loc (loc
, MODIFY_EXPR
, void_type_node
, lhs
,
168 gfc_add_expr_to_block (pblock
, tmp
);
173 gfc_add_modify (stmtblock_t
* pblock
, tree lhs
, tree rhs
)
175 gfc_add_modify_loc (input_location
, pblock
, lhs
, rhs
);
179 /* Create a new scope/binding level and initialize a block. Care must be
180 taken when translating expressions as any temporaries will be placed in
181 the innermost scope. */
184 gfc_start_block (stmtblock_t
* block
)
186 /* Start a new binding level. */
188 block
->has_scope
= 1;
190 /* The block is empty. */
191 block
->head
= NULL_TREE
;
195 /* Initialize a block without creating a new scope. */
198 gfc_init_block (stmtblock_t
* block
)
200 block
->head
= NULL_TREE
;
201 block
->has_scope
= 0;
205 /* Sometimes we create a scope but it turns out that we don't actually
206 need it. This function merges the scope of BLOCK with its parent.
207 Only variable decls will be merged, you still need to add the code. */
210 gfc_merge_block_scope (stmtblock_t
* block
)
215 gcc_assert (block
->has_scope
);
216 block
->has_scope
= 0;
218 /* Remember the decls in this scope. */
222 /* Add them to the parent scope. */
223 while (decl
!= NULL_TREE
)
225 next
= DECL_CHAIN (decl
);
226 DECL_CHAIN (decl
) = NULL_TREE
;
234 /* Finish a scope containing a block of statements. */
237 gfc_finish_block (stmtblock_t
* stmtblock
)
243 expr
= stmtblock
->head
;
245 expr
= build_empty_stmt (input_location
);
247 stmtblock
->head
= NULL_TREE
;
249 if (stmtblock
->has_scope
)
255 block
= poplevel (1, 0);
256 expr
= build3_v (BIND_EXPR
, decl
, expr
, block
);
266 /* Build an ADDR_EXPR and cast the result to TYPE. If TYPE is NULL, the
267 natural type is used. */
270 gfc_build_addr_expr (tree type
, tree t
)
272 tree base_type
= TREE_TYPE (t
);
275 if (type
&& POINTER_TYPE_P (type
)
276 && TREE_CODE (base_type
) == ARRAY_TYPE
277 && TYPE_MAIN_VARIANT (TREE_TYPE (type
))
278 == TYPE_MAIN_VARIANT (TREE_TYPE (base_type
)))
280 tree min_val
= size_zero_node
;
281 tree type_domain
= TYPE_DOMAIN (base_type
);
282 if (type_domain
&& TYPE_MIN_VALUE (type_domain
))
283 min_val
= TYPE_MIN_VALUE (type_domain
);
284 t
= fold (build4_loc (input_location
, ARRAY_REF
, TREE_TYPE (type
),
285 t
, min_val
, NULL_TREE
, NULL_TREE
));
289 natural_type
= build_pointer_type (base_type
);
291 if (TREE_CODE (t
) == INDIRECT_REF
)
295 t
= TREE_OPERAND (t
, 0);
296 natural_type
= TREE_TYPE (t
);
300 tree base
= get_base_address (t
);
301 if (base
&& DECL_P (base
))
302 TREE_ADDRESSABLE (base
) = 1;
303 t
= fold_build1_loc (input_location
, ADDR_EXPR
, natural_type
, t
);
306 if (type
&& natural_type
!= type
)
307 t
= convert (type
, t
);
313 /* Build an ARRAY_REF with its natural type. */
316 gfc_build_array_ref (tree base
, tree offset
, tree decl
, tree vptr
)
318 tree type
= TREE_TYPE (base
);
322 if (GFC_ARRAY_TYPE_P (type
) && GFC_TYPE_ARRAY_RANK (type
) == 0)
324 gcc_assert (GFC_TYPE_ARRAY_CORANK (type
) > 0);
326 return fold_convert (TYPE_MAIN_VARIANT (type
), base
);
329 /* Scalar coarray, there is nothing to do. */
330 if (TREE_CODE (type
) != ARRAY_TYPE
)
332 gcc_assert (decl
== NULL_TREE
);
333 gcc_assert (integer_zerop (offset
));
337 type
= TREE_TYPE (type
);
340 TREE_ADDRESSABLE (base
) = 1;
342 /* Strip NON_LVALUE_EXPR nodes. */
343 STRIP_TYPE_NOPS (offset
);
345 /* If the array reference is to a pointer, whose target contains a
346 subreference, use the span that is stored with the backend decl
347 and reference the element with pointer arithmetic. */
348 if ((decl
&& (TREE_CODE (decl
) == FIELD_DECL
349 || TREE_CODE (decl
) == VAR_DECL
350 || TREE_CODE (decl
) == PARM_DECL
)
351 && ((GFC_DECL_SUBREF_ARRAY_P (decl
)
352 && !integer_zerop (GFC_DECL_SPAN (decl
)))
353 || GFC_DECL_CLASS (decl
)))
358 if (GFC_DECL_CLASS (decl
))
360 /* When a temporary is in place for the class array, then the
361 original class' declaration is stored in the saved
363 if (DECL_LANG_SPECIFIC (decl
) && GFC_DECL_SAVED_DESCRIPTOR (decl
))
364 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
367 /* Allow for dummy arguments and other good things. */
368 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
369 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
371 /* Check if '_data' is an array descriptor. If it is not,
372 the array must be one of the components of the class
373 object, so return a normal array reference. */
374 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (
375 gfc_class_data_get (decl
))))
376 return build4_loc (input_location
, ARRAY_REF
, type
, base
,
377 offset
, NULL_TREE
, NULL_TREE
);
380 span
= gfc_class_vtab_size_get (decl
);
382 else if (GFC_DECL_SUBREF_ARRAY_P (decl
))
383 span
= GFC_DECL_SPAN (decl
);
388 span
= gfc_vptr_size_get (vptr
);
392 offset
= fold_build2_loc (input_location
, MULT_EXPR
,
393 gfc_array_index_type
,
395 tmp
= gfc_build_addr_expr (pvoid_type_node
, base
);
396 tmp
= fold_build_pointer_plus_loc (input_location
, tmp
, offset
);
397 tmp
= fold_convert (build_pointer_type (type
), tmp
);
398 if (!TYPE_STRING_FLAG (type
))
399 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
403 /* Otherwise use a straightforward array reference. */
404 return build4_loc (input_location
, ARRAY_REF
, type
, base
, offset
,
405 NULL_TREE
, NULL_TREE
);
409 /* Generate a call to print a runtime error possibly including multiple
410 arguments and a locus. */
413 trans_runtime_error_vararg (bool error
, locus
* where
, const char* msgid
,
426 /* Compute the number of extra arguments from the format string. */
427 for (p
= msgid
, nargs
= 0; *p
; p
++)
435 /* The code to generate the error. */
436 gfc_start_block (&block
);
440 line
= LOCATION_LINE (where
->lb
->location
);
441 message
= xasprintf ("At line %d of file %s", line
,
442 where
->lb
->file
->filename
);
445 message
= xasprintf ("In file '%s', around line %d",
446 gfc_source_file
, LOCATION_LINE (input_location
) + 1);
448 arg
= gfc_build_addr_expr (pchar_type_node
,
449 gfc_build_localized_cstring_const (message
));
452 message
= xasprintf ("%s", _(msgid
));
453 arg2
= gfc_build_addr_expr (pchar_type_node
,
454 gfc_build_localized_cstring_const (message
));
457 /* Build the argument array. */
458 argarray
= XALLOCAVEC (tree
, nargs
+ 2);
461 for (i
= 0; i
< nargs
; i
++)
462 argarray
[2 + i
] = va_arg (ap
, tree
);
464 /* Build the function call to runtime_(warning,error)_at; because of the
465 variable number of arguments, we can't use build_call_expr_loc dinput_location,
468 fntype
= TREE_TYPE (gfor_fndecl_runtime_error_at
);
470 fntype
= TREE_TYPE (gfor_fndecl_runtime_warning_at
);
472 loc
= where
? where
->lb
->location
: input_location
;
473 tmp
= fold_build_call_array_loc (loc
, TREE_TYPE (fntype
),
474 fold_build1_loc (loc
, ADDR_EXPR
,
475 build_pointer_type (fntype
),
477 ? gfor_fndecl_runtime_error_at
478 : gfor_fndecl_runtime_warning_at
),
479 nargs
+ 2, argarray
);
480 gfc_add_expr_to_block (&block
, tmp
);
482 return gfc_finish_block (&block
);
487 gfc_trans_runtime_error (bool error
, locus
* where
, const char* msgid
, ...)
492 va_start (ap
, msgid
);
493 result
= trans_runtime_error_vararg (error
, where
, msgid
, ap
);
499 /* Generate a runtime error if COND is true. */
502 gfc_trans_runtime_check (bool error
, bool once
, tree cond
, stmtblock_t
* pblock
,
503 locus
* where
, const char * msgid
, ...)
511 if (integer_zerop (cond
))
516 tmpvar
= gfc_create_var (boolean_type_node
, "print_warning");
517 TREE_STATIC (tmpvar
) = 1;
518 DECL_INITIAL (tmpvar
) = boolean_true_node
;
519 gfc_add_expr_to_block (pblock
, tmpvar
);
522 gfc_start_block (&block
);
524 /* For error, runtime_error_at already implies PRED_NORETURN. */
526 gfc_add_expr_to_block (&block
, build_predict_expr (PRED_FORTRAN_WARN_ONCE
,
529 /* The code to generate the error. */
530 va_start (ap
, msgid
);
531 gfc_add_expr_to_block (&block
,
532 trans_runtime_error_vararg (error
, where
,
537 gfc_add_modify (&block
, tmpvar
, boolean_false_node
);
539 body
= gfc_finish_block (&block
);
541 if (integer_onep (cond
))
543 gfc_add_expr_to_block (pblock
, body
);
548 cond
= fold_build2_loc (where
->lb
->location
, TRUTH_AND_EXPR
,
549 long_integer_type_node
, tmpvar
, cond
);
551 cond
= fold_convert (long_integer_type_node
, cond
);
553 tmp
= fold_build3_loc (where
->lb
->location
, COND_EXPR
, void_type_node
,
555 build_empty_stmt (where
->lb
->location
));
556 gfc_add_expr_to_block (pblock
, tmp
);
561 /* Call malloc to allocate size bytes of memory, with special conditions:
562 + if size == 0, return a malloced area of size 1,
563 + if malloc returns NULL, issue a runtime error. */
565 gfc_call_malloc (stmtblock_t
* block
, tree type
, tree size
)
567 tree tmp
, msg
, malloc_result
, null_result
, res
, malloc_tree
;
570 /* Create a variable to hold the result. */
571 res
= gfc_create_var (prvoid_type_node
, NULL
);
574 gfc_start_block (&block2
);
576 size
= fold_convert (size_type_node
, size
);
577 size
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
, size
,
578 build_int_cst (size_type_node
, 1));
580 malloc_tree
= builtin_decl_explicit (BUILT_IN_MALLOC
);
581 gfc_add_modify (&block2
, res
,
582 fold_convert (prvoid_type_node
,
583 build_call_expr_loc (input_location
,
584 malloc_tree
, 1, size
)));
586 /* Optionally check whether malloc was successful. */
587 if (gfc_option
.rtcheck
& GFC_RTCHECK_MEM
)
589 null_result
= fold_build2_loc (input_location
, EQ_EXPR
,
590 boolean_type_node
, res
,
591 build_int_cst (pvoid_type_node
, 0));
592 msg
= gfc_build_addr_expr (pchar_type_node
,
593 gfc_build_localized_cstring_const ("Memory allocation failed"));
594 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
596 build_call_expr_loc (input_location
,
597 gfor_fndecl_os_error
, 1, msg
),
598 build_empty_stmt (input_location
));
599 gfc_add_expr_to_block (&block2
, tmp
);
602 malloc_result
= gfc_finish_block (&block2
);
603 gfc_add_expr_to_block (block
, malloc_result
);
606 res
= fold_convert (type
, res
);
611 /* Allocate memory, using an optional status argument.
613 This function follows the following pseudo-code:
616 allocate (size_t size, integer_type stat)
623 newmem = malloc (MAX (size, 1));
627 *stat = LIBERROR_ALLOCATION;
629 runtime_error ("Allocation would exceed memory limit");
634 gfc_allocate_using_malloc (stmtblock_t
* block
, tree pointer
,
635 tree size
, tree status
)
637 tree tmp
, error_cond
;
638 stmtblock_t on_error
;
639 tree status_type
= status
? TREE_TYPE (status
) : NULL_TREE
;
641 /* If successful and stat= is given, set status to 0. */
642 if (status
!= NULL_TREE
)
643 gfc_add_expr_to_block (block
,
644 fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
645 status
, build_int_cst (status_type
, 0)));
647 /* The allocation itself. */
648 size
= fold_convert (size_type_node
, size
);
649 gfc_add_modify (block
, pointer
,
650 fold_convert (TREE_TYPE (pointer
),
651 build_call_expr_loc (input_location
,
652 builtin_decl_explicit (BUILT_IN_MALLOC
), 1,
653 fold_build2_loc (input_location
,
654 MAX_EXPR
, size_type_node
, size
,
655 build_int_cst (size_type_node
, 1)))));
657 /* What to do in case of error. */
658 gfc_start_block (&on_error
);
659 if (status
!= NULL_TREE
)
661 gfc_add_expr_to_block (&on_error
,
662 build_predict_expr (PRED_FORTRAN_FAIL_ALLOC
,
664 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
, status
,
665 build_int_cst (status_type
, LIBERROR_ALLOCATION
));
666 gfc_add_expr_to_block (&on_error
, tmp
);
670 /* Here, os_error already implies PRED_NORETURN. */
671 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_os_error
, 1,
672 gfc_build_addr_expr (pchar_type_node
,
673 gfc_build_localized_cstring_const
674 ("Allocation would exceed memory limit")));
675 gfc_add_expr_to_block (&on_error
, tmp
);
678 error_cond
= fold_build2_loc (input_location
, EQ_EXPR
,
679 boolean_type_node
, pointer
,
680 build_int_cst (prvoid_type_node
, 0));
681 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
682 error_cond
, gfc_finish_block (&on_error
),
683 build_empty_stmt (input_location
));
685 gfc_add_expr_to_block (block
, tmp
);
689 /* Allocate memory, using an optional status argument.
691 This function follows the following pseudo-code:
694 allocate (size_t size, void** token, int *stat, char* errmsg, int errlen)
698 newmem = _caf_register (size, regtype, token, &stat, errmsg, errlen);
702 gfc_allocate_using_lib (stmtblock_t
* block
, tree pointer
, tree size
,
703 tree token
, tree status
, tree errmsg
, tree errlen
,
708 gcc_assert (token
!= NULL_TREE
);
710 /* The allocation itself. */
711 if (status
== NULL_TREE
)
712 pstat
= null_pointer_node
;
714 pstat
= gfc_build_addr_expr (NULL_TREE
, status
);
716 if (errmsg
== NULL_TREE
)
718 gcc_assert(errlen
== NULL_TREE
);
719 errmsg
= null_pointer_node
;
720 errlen
= build_int_cst (integer_type_node
, 0);
723 size
= fold_convert (size_type_node
, size
);
724 tmp
= build_call_expr_loc (input_location
,
725 gfor_fndecl_caf_register
, 6,
726 fold_build2_loc (input_location
,
727 MAX_EXPR
, size_type_node
, size
,
728 build_int_cst (size_type_node
, 1)),
729 build_int_cst (integer_type_node
,
730 lock_var
? GFC_CAF_LOCK_ALLOC
731 : GFC_CAF_COARRAY_ALLOC
),
732 token
, pstat
, errmsg
, errlen
);
734 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
735 TREE_TYPE (pointer
), pointer
,
736 fold_convert ( TREE_TYPE (pointer
), tmp
));
737 gfc_add_expr_to_block (block
, tmp
);
741 /* Generate code for an ALLOCATE statement when the argument is an
742 allocatable variable. If the variable is currently allocated, it is an
743 error to allocate it again.
745 This function follows the following pseudo-code:
748 allocate_allocatable (void *mem, size_t size, integer_type stat)
751 return allocate (size, stat);
755 stat = LIBERROR_ALLOCATION;
757 runtime_error ("Attempting to allocate already allocated variable");
761 expr must be set to the original expression being allocated for its locus
762 and variable name in case a runtime error has to be printed. */
764 gfc_allocate_allocatable (stmtblock_t
* block
, tree mem
, tree size
, tree token
,
765 tree status
, tree errmsg
, tree errlen
, tree label_finish
,
768 stmtblock_t alloc_block
;
769 tree tmp
, null_mem
, alloc
, error
;
770 tree type
= TREE_TYPE (mem
);
772 size
= fold_convert (size_type_node
, size
);
773 null_mem
= gfc_unlikely (fold_build2_loc (input_location
, NE_EXPR
,
774 boolean_type_node
, mem
,
775 build_int_cst (type
, 0)),
776 PRED_FORTRAN_FAIL_ALLOC
);
778 /* If mem is NULL, we call gfc_allocate_using_malloc or
779 gfc_allocate_using_lib. */
780 gfc_start_block (&alloc_block
);
782 if (flag_coarray
== GFC_FCOARRAY_LIB
783 && gfc_expr_attr (expr
).codimension
)
786 bool lock_var
= expr
->ts
.type
== BT_DERIVED
787 && expr
->ts
.u
.derived
->from_intmod
788 == INTMOD_ISO_FORTRAN_ENV
789 && expr
->ts
.u
.derived
->intmod_sym_id
790 == ISOFORTRAN_LOCK_TYPE
;
791 /* In the front end, we represent the lock variable as pointer. However,
792 the FE only passes the pointer around and leaves the actual
793 representation to the library. Hence, we have to convert back to the
794 number of elements. */
796 size
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, size_type_node
,
797 size
, TYPE_SIZE_UNIT (ptr_type_node
));
799 gfc_allocate_using_lib (&alloc_block
, mem
, size
, token
, status
,
800 errmsg
, errlen
, lock_var
);
802 if (status
!= NULL_TREE
)
804 TREE_USED (label_finish
) = 1;
805 tmp
= build1_v (GOTO_EXPR
, label_finish
);
806 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
807 status
, build_zero_cst (TREE_TYPE (status
)));
808 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
809 gfc_unlikely (cond
, PRED_FORTRAN_FAIL_ALLOC
),
810 tmp
, build_empty_stmt (input_location
));
811 gfc_add_expr_to_block (&alloc_block
, tmp
);
815 gfc_allocate_using_malloc (&alloc_block
, mem
, size
, status
);
817 alloc
= gfc_finish_block (&alloc_block
);
819 /* If mem is not NULL, we issue a runtime error or set the
825 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
&& expr
->symtree
);
826 varname
= gfc_build_cstring_const (expr
->symtree
->name
);
827 varname
= gfc_build_addr_expr (pchar_type_node
, varname
);
829 error
= gfc_trans_runtime_error (true, &expr
->where
,
830 "Attempting to allocate already"
831 " allocated variable '%s'",
835 error
= gfc_trans_runtime_error (true, NULL
,
836 "Attempting to allocate already allocated"
839 if (status
!= NULL_TREE
)
841 tree status_type
= TREE_TYPE (status
);
843 error
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
844 status
, build_int_cst (status_type
, LIBERROR_ALLOCATION
));
847 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, null_mem
,
849 gfc_add_expr_to_block (block
, tmp
);
853 /* Free a given variable, if it's not NULL. */
856 gfc_call_free (tree var
)
860 /* Only evaluate the variable once. */
861 var
= save_expr (fold_convert (pvoid_type_node
, var
));
863 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, var
,
864 build_int_cst (pvoid_type_node
, 0));
865 call
= build_call_expr_loc (input_location
,
866 builtin_decl_explicit (BUILT_IN_FREE
),
868 return fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
869 cond
, call
, build_empty_stmt (input_location
));
873 /* Build a call to a FINAL procedure, which finalizes "var". */
876 gfc_build_final_call (gfc_typespec ts
, gfc_expr
*final_wrapper
, gfc_expr
*var
,
877 bool fini_coarray
, gfc_expr
*class_size
)
881 tree final_fndecl
, array
, size
, tmp
;
882 symbol_attribute attr
;
884 gcc_assert (final_wrapper
->expr_type
== EXPR_VARIABLE
);
887 gfc_start_block (&block
);
888 gfc_init_se (&se
, NULL
);
889 gfc_conv_expr (&se
, final_wrapper
);
890 final_fndecl
= se
.expr
;
891 if (POINTER_TYPE_P (TREE_TYPE (final_fndecl
)))
892 final_fndecl
= build_fold_indirect_ref_loc (input_location
, final_fndecl
);
894 if (ts
.type
== BT_DERIVED
)
898 gcc_assert (!class_size
);
899 elem_size
= gfc_typenode_for_spec (&ts
);
900 elem_size
= TYPE_SIZE_UNIT (elem_size
);
901 size
= fold_convert (gfc_array_index_type
, elem_size
);
903 gfc_init_se (&se
, NULL
);
907 se
.descriptor_only
= 1;
908 gfc_conv_expr_descriptor (&se
, var
);
913 gfc_conv_expr (&se
, var
);
914 gcc_assert (se
.pre
.head
== NULL_TREE
&& se
.post
.head
== NULL_TREE
);
917 /* No copy back needed, hence set attr's allocatable/pointer
919 gfc_clear_attr (&attr
);
920 gfc_init_se (&se
, NULL
);
921 array
= gfc_conv_scalar_to_descriptor (&se
, array
, attr
);
922 gcc_assert (se
.post
.head
== NULL_TREE
);
927 gfc_expr
*array_expr
;
928 gcc_assert (class_size
);
929 gfc_init_se (&se
, NULL
);
930 gfc_conv_expr (&se
, class_size
);
931 gfc_add_block_to_block (&block
, &se
.pre
);
932 gcc_assert (se
.post
.head
== NULL_TREE
);
935 array_expr
= gfc_copy_expr (var
);
936 gfc_init_se (&se
, NULL
);
938 if (array_expr
->rank
)
940 gfc_add_class_array_ref (array_expr
);
941 se
.descriptor_only
= 1;
942 gfc_conv_expr_descriptor (&se
, array_expr
);
947 gfc_add_data_component (array_expr
);
948 gfc_conv_expr (&se
, array_expr
);
949 gfc_add_block_to_block (&block
, &se
.pre
);
950 gcc_assert (se
.post
.head
== NULL_TREE
);
952 if (TREE_CODE (array
) == ADDR_EXPR
953 && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (array
, 0))))
954 tmp
= TREE_OPERAND (array
, 0);
956 if (!gfc_is_coarray (array_expr
))
958 /* No copy back needed, hence set attr's allocatable/pointer
960 gfc_clear_attr (&attr
);
961 gfc_init_se (&se
, NULL
);
962 array
= gfc_conv_scalar_to_descriptor (&se
, array
, attr
);
964 gcc_assert (se
.post
.head
== NULL_TREE
);
966 gfc_free_expr (array_expr
);
969 if (!POINTER_TYPE_P (TREE_TYPE (array
)))
970 array
= gfc_build_addr_expr (NULL
, array
);
972 gfc_add_block_to_block (&block
, &se
.pre
);
973 tmp
= build_call_expr_loc (input_location
,
974 final_fndecl
, 3, array
,
975 size
, fini_coarray
? boolean_true_node
976 : boolean_false_node
);
977 gfc_add_block_to_block (&block
, &se
.post
);
978 gfc_add_expr_to_block (&block
, tmp
);
979 return gfc_finish_block (&block
);
984 gfc_add_comp_finalizer_call (stmtblock_t
*block
, tree decl
, gfc_component
*comp
,
989 tree final_fndecl
, size
, array
, tmp
, cond
;
990 symbol_attribute attr
;
991 gfc_expr
*final_expr
= NULL
;
993 if (comp
->ts
.type
!= BT_DERIVED
&& comp
->ts
.type
!= BT_CLASS
)
996 gfc_init_block (&block2
);
998 if (comp
->ts
.type
== BT_DERIVED
)
1000 if (comp
->attr
.pointer
)
1003 gfc_is_finalizable (comp
->ts
.u
.derived
, &final_expr
);
1007 gfc_init_se (&se
, NULL
);
1008 gfc_conv_expr (&se
, final_expr
);
1009 final_fndecl
= se
.expr
;
1010 size
= gfc_typenode_for_spec (&comp
->ts
);
1011 size
= TYPE_SIZE_UNIT (size
);
1012 size
= fold_convert (gfc_array_index_type
, size
);
1016 else /* comp->ts.type == BT_CLASS. */
1018 if (CLASS_DATA (comp
)->attr
.class_pointer
)
1021 gfc_is_finalizable (CLASS_DATA (comp
)->ts
.u
.derived
, &final_expr
);
1022 final_fndecl
= gfc_class_vtab_final_get (decl
);
1023 size
= gfc_class_vtab_size_get (decl
);
1024 array
= gfc_class_data_get (decl
);
1027 if (comp
->attr
.allocatable
1028 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)->attr
.allocatable
))
1030 tmp
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array
))
1031 ? gfc_conv_descriptor_data_get (array
) : array
;
1032 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1033 tmp
, fold_convert (TREE_TYPE (tmp
),
1034 null_pointer_node
));
1037 cond
= boolean_true_node
;
1039 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array
)))
1041 gfc_clear_attr (&attr
);
1042 gfc_init_se (&se
, NULL
);
1043 array
= gfc_conv_scalar_to_descriptor (&se
, array
, attr
);
1044 gfc_add_block_to_block (&block2
, &se
.pre
);
1045 gcc_assert (se
.post
.head
== NULL_TREE
);
1048 if (!POINTER_TYPE_P (TREE_TYPE (array
)))
1049 array
= gfc_build_addr_expr (NULL
, array
);
1053 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1055 fold_convert (TREE_TYPE (final_fndecl
),
1056 null_pointer_node
));
1057 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1058 boolean_type_node
, cond
, tmp
);
1061 if (POINTER_TYPE_P (TREE_TYPE (final_fndecl
)))
1062 final_fndecl
= build_fold_indirect_ref_loc (input_location
, final_fndecl
);
1064 tmp
= build_call_expr_loc (input_location
,
1065 final_fndecl
, 3, array
,
1066 size
, fini_coarray
? boolean_true_node
1067 : boolean_false_node
);
1068 gfc_add_expr_to_block (&block2
, tmp
);
1069 tmp
= gfc_finish_block (&block2
);
1071 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
1072 build_empty_stmt (input_location
));
1073 gfc_add_expr_to_block (block
, tmp
);
1079 /* Add a call to the finalizer, using the passed *expr. Returns
1080 true when a finalizer call has been inserted. */
1083 gfc_add_finalizer_call (stmtblock_t
*block
, gfc_expr
*expr2
)
1088 gfc_expr
*final_expr
= NULL
;
1089 gfc_expr
*elem_size
= NULL
;
1090 bool has_finalizer
= false;
1092 if (!expr2
|| (expr2
->ts
.type
!= BT_DERIVED
&& expr2
->ts
.type
!= BT_CLASS
))
1095 if (expr2
->ts
.type
== BT_DERIVED
)
1097 gfc_is_finalizable (expr2
->ts
.u
.derived
, &final_expr
);
1102 /* If we have a class array, we need go back to the class
1104 expr
= gfc_copy_expr (expr2
);
1106 if (expr
->ref
&& expr
->ref
->next
&& !expr
->ref
->next
->next
1107 && expr
->ref
->next
->type
== REF_ARRAY
1108 && expr
->ref
->type
== REF_COMPONENT
1109 && strcmp (expr
->ref
->u
.c
.component
->name
, "_data") == 0)
1111 gfc_free_ref_list (expr
->ref
);
1115 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1116 if (ref
->next
&& ref
->next
->next
&& !ref
->next
->next
->next
1117 && ref
->next
->next
->type
== REF_ARRAY
1118 && ref
->next
->type
== REF_COMPONENT
1119 && strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0)
1121 gfc_free_ref_list (ref
->next
);
1125 if (expr
->ts
.type
== BT_CLASS
)
1127 has_finalizer
= gfc_is_finalizable (expr
->ts
.u
.derived
, NULL
);
1129 if (!expr2
->rank
&& !expr2
->ref
&& CLASS_DATA (expr2
->symtree
->n
.sym
)->as
)
1130 expr
->rank
= CLASS_DATA (expr2
->symtree
->n
.sym
)->as
->rank
;
1132 final_expr
= gfc_copy_expr (expr
);
1133 gfc_add_vptr_component (final_expr
);
1134 gfc_add_component_ref (final_expr
, "_final");
1136 elem_size
= gfc_copy_expr (expr
);
1137 gfc_add_vptr_component (elem_size
);
1138 gfc_add_component_ref (elem_size
, "_size");
1141 gcc_assert (final_expr
->expr_type
== EXPR_VARIABLE
);
1143 tmp
= gfc_build_final_call (expr
->ts
, final_expr
, expr
,
1146 if (expr
->ts
.type
== BT_CLASS
&& !has_finalizer
)
1151 gfc_init_se (&se
, NULL
);
1152 se
.want_pointer
= 1;
1153 gfc_conv_expr (&se
, final_expr
);
1154 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1155 se
.expr
, build_int_cst (TREE_TYPE (se
.expr
), 0));
1157 /* For CLASS(*) not only sym->_vtab->_final can be NULL
1158 but already sym->_vtab itself. */
1159 if (UNLIMITED_POLY (expr
))
1162 gfc_expr
*vptr_expr
;
1164 vptr_expr
= gfc_copy_expr (expr
);
1165 gfc_add_vptr_component (vptr_expr
);
1167 gfc_init_se (&se
, NULL
);
1168 se
.want_pointer
= 1;
1169 gfc_conv_expr (&se
, vptr_expr
);
1170 gfc_free_expr (vptr_expr
);
1172 cond2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1174 build_int_cst (TREE_TYPE (se
.expr
), 0));
1175 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1176 boolean_type_node
, cond2
, cond
);
1179 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1180 cond
, tmp
, build_empty_stmt (input_location
));
1183 gfc_add_expr_to_block (block
, tmp
);
1189 /* User-deallocate; we emit the code directly from the front-end, and the
1190 logic is the same as the previous library function:
1193 deallocate (void *pointer, GFC_INTEGER_4 * stat)
1200 runtime_error ("Attempt to DEALLOCATE unallocated memory.");
1210 In this front-end version, status doesn't have to be GFC_INTEGER_4.
1211 Moreover, if CAN_FAIL is true, then we will not emit a runtime error,
1212 even when no status variable is passed to us (this is used for
1213 unconditional deallocation generated by the front-end at end of
1216 If a runtime-message is possible, `expr' must point to the original
1217 expression being deallocated for its locus and variable name.
1219 For coarrays, "pointer" must be the array descriptor and not its
1220 "data" component. */
1222 gfc_deallocate_with_status (tree pointer
, tree status
, tree errmsg
,
1223 tree errlen
, tree label_finish
,
1224 bool can_fail
, gfc_expr
* expr
, bool coarray
)
1226 stmtblock_t null
, non_null
;
1227 tree cond
, tmp
, error
;
1228 tree status_type
= NULL_TREE
;
1229 tree caf_decl
= NULL_TREE
;
1233 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer
)));
1235 pointer
= gfc_conv_descriptor_data_get (caf_decl
);
1236 STRIP_NOPS (pointer
);
1239 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, pointer
,
1240 build_int_cst (TREE_TYPE (pointer
), 0));
1242 /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
1243 we emit a runtime error. */
1244 gfc_start_block (&null
);
1249 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
&& expr
->symtree
);
1251 varname
= gfc_build_cstring_const (expr
->symtree
->name
);
1252 varname
= gfc_build_addr_expr (pchar_type_node
, varname
);
1254 error
= gfc_trans_runtime_error (true, &expr
->where
,
1255 "Attempt to DEALLOCATE unallocated '%s'",
1259 error
= build_empty_stmt (input_location
);
1261 if (status
!= NULL_TREE
&& !integer_zerop (status
))
1265 status_type
= TREE_TYPE (TREE_TYPE (status
));
1266 cond2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1267 status
, build_int_cst (TREE_TYPE (status
), 0));
1268 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
1269 fold_build1_loc (input_location
, INDIRECT_REF
,
1270 status_type
, status
),
1271 build_int_cst (status_type
, 1));
1272 error
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1276 gfc_add_expr_to_block (&null
, error
);
1278 /* When POINTER is not NULL, we free it. */
1279 gfc_start_block (&non_null
);
1280 gfc_add_finalizer_call (&non_null
, expr
);
1281 if (!coarray
|| flag_coarray
!= GFC_FCOARRAY_LIB
)
1283 tmp
= build_call_expr_loc (input_location
,
1284 builtin_decl_explicit (BUILT_IN_FREE
), 1,
1285 fold_convert (pvoid_type_node
, pointer
));
1286 gfc_add_expr_to_block (&non_null
, tmp
);
1288 if (status
!= NULL_TREE
&& !integer_zerop (status
))
1290 /* We set STATUS to zero if it is present. */
1291 tree status_type
= TREE_TYPE (TREE_TYPE (status
));
1294 cond2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1296 build_int_cst (TREE_TYPE (status
), 0));
1297 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
1298 fold_build1_loc (input_location
, INDIRECT_REF
,
1299 status_type
, status
),
1300 build_int_cst (status_type
, 0));
1301 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1302 gfc_unlikely (cond2
, PRED_FORTRAN_FAIL_ALLOC
),
1303 tmp
, build_empty_stmt (input_location
));
1304 gfc_add_expr_to_block (&non_null
, tmp
);
1309 tree caf_type
, token
, cond2
;
1310 tree pstat
= null_pointer_node
;
1312 if (errmsg
== NULL_TREE
)
1314 gcc_assert (errlen
== NULL_TREE
);
1315 errmsg
= null_pointer_node
;
1316 errlen
= build_zero_cst (integer_type_node
);
1320 gcc_assert (errlen
!= NULL_TREE
);
1321 if (!POINTER_TYPE_P (TREE_TYPE (errmsg
)))
1322 errmsg
= gfc_build_addr_expr (NULL_TREE
, errmsg
);
1325 caf_type
= TREE_TYPE (caf_decl
);
1327 if (status
!= NULL_TREE
&& !integer_zerop (status
))
1329 gcc_assert (status_type
== integer_type_node
);
1333 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
1334 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
1335 token
= gfc_conv_descriptor_token (caf_decl
);
1336 else if (DECL_LANG_SPECIFIC (caf_decl
)
1337 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
1338 token
= GFC_DECL_TOKEN (caf_decl
);
1341 gcc_assert (GFC_ARRAY_TYPE_P (caf_type
)
1342 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) != NULL_TREE
);
1343 token
= GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
);
1346 token
= gfc_build_addr_expr (NULL_TREE
, token
);
1347 tmp
= build_call_expr_loc (input_location
,
1348 gfor_fndecl_caf_deregister
, 4,
1349 token
, pstat
, errmsg
, errlen
);
1350 gfc_add_expr_to_block (&non_null
, tmp
);
1352 if (status
!= NULL_TREE
)
1354 tree stat
= build_fold_indirect_ref_loc (input_location
, status
);
1356 TREE_USED (label_finish
) = 1;
1357 tmp
= build1_v (GOTO_EXPR
, label_finish
);
1358 cond2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1359 stat
, build_zero_cst (TREE_TYPE (stat
)));
1360 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1361 gfc_unlikely (cond2
, PRED_FORTRAN_FAIL_ALLOC
),
1362 tmp
, build_empty_stmt (input_location
));
1363 gfc_add_expr_to_block (&non_null
, tmp
);
1367 return fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
1368 gfc_finish_block (&null
),
1369 gfc_finish_block (&non_null
));
1373 /* Generate code for deallocation of allocatable scalars (variables or
1374 components). Before the object itself is freed, any allocatable
1375 subcomponents are being deallocated. */
1378 gfc_deallocate_scalar_with_status (tree pointer
, tree status
, bool can_fail
,
1379 gfc_expr
* expr
, gfc_typespec ts
)
1381 stmtblock_t null
, non_null
;
1382 tree cond
, tmp
, error
;
1385 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, pointer
,
1386 build_int_cst (TREE_TYPE (pointer
), 0));
1388 /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
1389 we emit a runtime error. */
1390 gfc_start_block (&null
);
1395 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
&& expr
->symtree
);
1397 varname
= gfc_build_cstring_const (expr
->symtree
->name
);
1398 varname
= gfc_build_addr_expr (pchar_type_node
, varname
);
1400 error
= gfc_trans_runtime_error (true, &expr
->where
,
1401 "Attempt to DEALLOCATE unallocated '%s'",
1405 error
= build_empty_stmt (input_location
);
1407 if (status
!= NULL_TREE
&& !integer_zerop (status
))
1409 tree status_type
= TREE_TYPE (TREE_TYPE (status
));
1412 cond2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1413 status
, build_int_cst (TREE_TYPE (status
), 0));
1414 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
1415 fold_build1_loc (input_location
, INDIRECT_REF
,
1416 status_type
, status
),
1417 build_int_cst (status_type
, 1));
1418 error
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1422 gfc_add_expr_to_block (&null
, error
);
1424 /* When POINTER is not NULL, we free it. */
1425 gfc_start_block (&non_null
);
1427 /* Free allocatable components. */
1428 finalizable
= gfc_add_finalizer_call (&non_null
, expr
);
1429 if (!finalizable
&& ts
.type
== BT_DERIVED
&& ts
.u
.derived
->attr
.alloc_comp
)
1431 tmp
= build_fold_indirect_ref_loc (input_location
, pointer
);
1432 tmp
= gfc_deallocate_alloc_comp (ts
.u
.derived
, tmp
, 0);
1433 gfc_add_expr_to_block (&non_null
, tmp
);
1436 tmp
= build_call_expr_loc (input_location
,
1437 builtin_decl_explicit (BUILT_IN_FREE
), 1,
1438 fold_convert (pvoid_type_node
, pointer
));
1439 gfc_add_expr_to_block (&non_null
, tmp
);
1441 if (status
!= NULL_TREE
&& !integer_zerop (status
))
1443 /* We set STATUS to zero if it is present. */
1444 tree status_type
= TREE_TYPE (TREE_TYPE (status
));
1447 cond2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1448 status
, build_int_cst (TREE_TYPE (status
), 0));
1449 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
1450 fold_build1_loc (input_location
, INDIRECT_REF
,
1451 status_type
, status
),
1452 build_int_cst (status_type
, 0));
1453 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
1454 tmp
, build_empty_stmt (input_location
));
1455 gfc_add_expr_to_block (&non_null
, tmp
);
1458 return fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
1459 gfc_finish_block (&null
),
1460 gfc_finish_block (&non_null
));
1464 /* Reallocate MEM so it has SIZE bytes of data. This behaves like the
1465 following pseudo-code:
1468 internal_realloc (void *mem, size_t size)
1470 res = realloc (mem, size);
1471 if (!res && size != 0)
1472 _gfortran_os_error ("Allocation would exceed memory limit");
1477 gfc_call_realloc (stmtblock_t
* block
, tree mem
, tree size
)
1479 tree msg
, res
, nonzero
, null_result
, tmp
;
1480 tree type
= TREE_TYPE (mem
);
1482 /* Only evaluate the size once. */
1483 size
= save_expr (fold_convert (size_type_node
, size
));
1485 /* Create a variable to hold the result. */
1486 res
= gfc_create_var (type
, NULL
);
1488 /* Call realloc and check the result. */
1489 tmp
= build_call_expr_loc (input_location
,
1490 builtin_decl_explicit (BUILT_IN_REALLOC
), 2,
1491 fold_convert (pvoid_type_node
, mem
), size
);
1492 gfc_add_modify (block
, res
, fold_convert (type
, tmp
));
1493 null_result
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1494 res
, build_int_cst (pvoid_type_node
, 0));
1495 nonzero
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, size
,
1496 build_int_cst (size_type_node
, 0));
1497 null_result
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, boolean_type_node
,
1498 null_result
, nonzero
);
1499 msg
= gfc_build_addr_expr (pchar_type_node
, gfc_build_localized_cstring_const
1500 ("Allocation would exceed memory limit"));
1501 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1503 build_call_expr_loc (input_location
,
1504 gfor_fndecl_os_error
, 1, msg
),
1505 build_empty_stmt (input_location
));
1506 gfc_add_expr_to_block (block
, tmp
);
1512 /* Add an expression to another one, either at the front or the back. */
1515 add_expr_to_chain (tree
* chain
, tree expr
, bool front
)
1517 if (expr
== NULL_TREE
|| IS_EMPTY_STMT (expr
))
1522 if (TREE_CODE (*chain
) != STATEMENT_LIST
)
1528 append_to_statement_list (tmp
, chain
);
1533 tree_stmt_iterator i
;
1535 i
= tsi_start (*chain
);
1536 tsi_link_before (&i
, expr
, TSI_CONTINUE_LINKING
);
1539 append_to_statement_list (expr
, chain
);
1546 /* Add a statement at the end of a block. */
1549 gfc_add_expr_to_block (stmtblock_t
* block
, tree expr
)
1552 add_expr_to_chain (&block
->head
, expr
, false);
1556 /* Add a statement at the beginning of a block. */
1559 gfc_prepend_expr_to_block (stmtblock_t
* block
, tree expr
)
1562 add_expr_to_chain (&block
->head
, expr
, true);
1566 /* Add a block the end of a block. */
1569 gfc_add_block_to_block (stmtblock_t
* block
, stmtblock_t
* append
)
1571 gcc_assert (append
);
1572 gcc_assert (!append
->has_scope
);
1574 gfc_add_expr_to_block (block
, append
->head
);
1575 append
->head
= NULL_TREE
;
1579 /* Save the current locus. The structure may not be complete, and should
1580 only be used with gfc_restore_backend_locus. */
1583 gfc_save_backend_locus (locus
* loc
)
1585 loc
->lb
= XCNEW (gfc_linebuf
);
1586 loc
->lb
->location
= input_location
;
1587 loc
->lb
->file
= gfc_current_backend_file
;
1591 /* Set the current locus. */
1594 gfc_set_backend_locus (locus
* loc
)
1596 gfc_current_backend_file
= loc
->lb
->file
;
1597 input_location
= loc
->lb
->location
;
1601 /* Restore the saved locus. Only used in conjunction with
1602 gfc_save_backend_locus, to free the memory when we are done. */
1605 gfc_restore_backend_locus (locus
* loc
)
1607 gfc_set_backend_locus (loc
);
1612 /* Translate an executable statement. The tree cond is used by gfc_trans_do.
1613 This static function is wrapped by gfc_trans_code_cond and
1617 trans_code (gfc_code
* code
, tree cond
)
1623 return build_empty_stmt (input_location
);
1625 gfc_start_block (&block
);
1627 /* Translate statements one by one into GENERIC trees until we reach
1628 the end of this gfc_code branch. */
1629 for (; code
; code
= code
->next
)
1631 if (code
->here
!= 0)
1633 res
= gfc_trans_label_here (code
);
1634 gfc_add_expr_to_block (&block
, res
);
1637 gfc_set_backend_locus (&code
->loc
);
1642 case EXEC_END_BLOCK
:
1643 case EXEC_END_NESTED_BLOCK
:
1644 case EXEC_END_PROCEDURE
:
1649 if (code
->expr1
->ts
.type
== BT_CLASS
)
1650 res
= gfc_trans_class_assign (code
->expr1
, code
->expr2
, code
->op
);
1652 res
= gfc_trans_assign (code
);
1655 case EXEC_LABEL_ASSIGN
:
1656 res
= gfc_trans_label_assign (code
);
1659 case EXEC_POINTER_ASSIGN
:
1660 if (code
->expr1
->ts
.type
== BT_CLASS
)
1661 res
= gfc_trans_class_assign (code
->expr1
, code
->expr2
, code
->op
);
1662 else if (UNLIMITED_POLY (code
->expr2
)
1663 && code
->expr1
->ts
.type
== BT_DERIVED
1664 && (code
->expr1
->ts
.u
.derived
->attr
.sequence
1665 || code
->expr1
->ts
.u
.derived
->attr
.is_bind_c
))
1667 res
= gfc_trans_class_assign (code
->expr1
, code
->expr2
, code
->op
);
1669 res
= gfc_trans_pointer_assign (code
);
1672 case EXEC_INIT_ASSIGN
:
1673 if (code
->expr1
->ts
.type
== BT_CLASS
)
1674 res
= gfc_trans_class_init_assign (code
);
1676 res
= gfc_trans_init_assign (code
);
1684 res
= gfc_trans_critical (code
);
1688 res
= gfc_trans_cycle (code
);
1692 res
= gfc_trans_exit (code
);
1696 res
= gfc_trans_goto (code
);
1700 res
= gfc_trans_entry (code
);
1704 res
= gfc_trans_pause (code
);
1708 case EXEC_ERROR_STOP
:
1709 res
= gfc_trans_stop (code
, code
->op
== EXEC_ERROR_STOP
);
1713 /* For MVBITS we've got the special exception that we need a
1714 dependency check, too. */
1716 bool is_mvbits
= false;
1718 if (code
->resolved_isym
)
1720 res
= gfc_conv_intrinsic_subroutine (code
);
1721 if (res
!= NULL_TREE
)
1725 if (code
->resolved_isym
1726 && code
->resolved_isym
->id
== GFC_ISYM_MVBITS
)
1729 res
= gfc_trans_call (code
, is_mvbits
, NULL_TREE
,
1735 res
= gfc_trans_call (code
, false, NULL_TREE
,
1739 case EXEC_ASSIGN_CALL
:
1740 res
= gfc_trans_call (code
, true, NULL_TREE
,
1745 res
= gfc_trans_return (code
);
1749 res
= gfc_trans_if (code
);
1752 case EXEC_ARITHMETIC_IF
:
1753 res
= gfc_trans_arithmetic_if (code
);
1757 res
= gfc_trans_block_construct (code
);
1761 res
= gfc_trans_do (code
, cond
);
1764 case EXEC_DO_CONCURRENT
:
1765 res
= gfc_trans_do_concurrent (code
);
1769 res
= gfc_trans_do_while (code
);
1773 res
= gfc_trans_select (code
);
1776 case EXEC_SELECT_TYPE
:
1777 /* Do nothing. SELECT TYPE statements should be transformed into
1778 an ordinary SELECT CASE at resolution stage.
1779 TODO: Add an error message here once this is done. */
1784 res
= gfc_trans_flush (code
);
1788 case EXEC_SYNC_IMAGES
:
1789 case EXEC_SYNC_MEMORY
:
1790 res
= gfc_trans_sync (code
, code
->op
);
1795 res
= gfc_trans_lock_unlock (code
, code
->op
);
1799 res
= gfc_trans_forall (code
);
1803 res
= gfc_trans_where (code
);
1807 res
= gfc_trans_allocate (code
);
1810 case EXEC_DEALLOCATE
:
1811 res
= gfc_trans_deallocate (code
);
1815 res
= gfc_trans_open (code
);
1819 res
= gfc_trans_close (code
);
1823 res
= gfc_trans_read (code
);
1827 res
= gfc_trans_write (code
);
1831 res
= gfc_trans_iolength (code
);
1834 case EXEC_BACKSPACE
:
1835 res
= gfc_trans_backspace (code
);
1839 res
= gfc_trans_endfile (code
);
1843 res
= gfc_trans_inquire (code
);
1847 res
= gfc_trans_wait (code
);
1851 res
= gfc_trans_rewind (code
);
1855 res
= gfc_trans_transfer (code
);
1859 res
= gfc_trans_dt_end (code
);
1862 case EXEC_OMP_ATOMIC
:
1863 case EXEC_OMP_BARRIER
:
1864 case EXEC_OMP_CANCEL
:
1865 case EXEC_OMP_CANCELLATION_POINT
:
1866 case EXEC_OMP_CRITICAL
:
1867 case EXEC_OMP_DISTRIBUTE
:
1868 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
1869 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
1870 case EXEC_OMP_DISTRIBUTE_SIMD
:
1872 case EXEC_OMP_DO_SIMD
:
1873 case EXEC_OMP_FLUSH
:
1874 case EXEC_OMP_MASTER
:
1875 case EXEC_OMP_ORDERED
:
1876 case EXEC_OMP_PARALLEL
:
1877 case EXEC_OMP_PARALLEL_DO
:
1878 case EXEC_OMP_PARALLEL_DO_SIMD
:
1879 case EXEC_OMP_PARALLEL_SECTIONS
:
1880 case EXEC_OMP_PARALLEL_WORKSHARE
:
1881 case EXEC_OMP_SECTIONS
:
1883 case EXEC_OMP_SINGLE
:
1884 case EXEC_OMP_TARGET
:
1885 case EXEC_OMP_TARGET_DATA
:
1886 case EXEC_OMP_TARGET_TEAMS
:
1887 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
1888 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
1889 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
1890 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
1891 case EXEC_OMP_TARGET_UPDATE
:
1893 case EXEC_OMP_TASKGROUP
:
1894 case EXEC_OMP_TASKWAIT
:
1895 case EXEC_OMP_TASKYIELD
:
1896 case EXEC_OMP_TEAMS
:
1897 case EXEC_OMP_TEAMS_DISTRIBUTE
:
1898 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
1899 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
1900 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
1901 case EXEC_OMP_WORKSHARE
:
1902 res
= gfc_trans_omp_directive (code
);
1905 case EXEC_OACC_CACHE
:
1906 case EXEC_OACC_WAIT
:
1907 case EXEC_OACC_UPDATE
:
1908 case EXEC_OACC_LOOP
:
1909 case EXEC_OACC_HOST_DATA
:
1910 case EXEC_OACC_DATA
:
1911 case EXEC_OACC_KERNELS
:
1912 case EXEC_OACC_KERNELS_LOOP
:
1913 case EXEC_OACC_PARALLEL
:
1914 case EXEC_OACC_PARALLEL_LOOP
:
1915 case EXEC_OACC_ENTER_DATA
:
1916 case EXEC_OACC_EXIT_DATA
:
1917 res
= gfc_trans_oacc_directive (code
);
1921 gfc_internal_error ("gfc_trans_code(): Bad statement code");
1924 gfc_set_backend_locus (&code
->loc
);
1926 if (res
!= NULL_TREE
&& ! IS_EMPTY_STMT (res
))
1928 if (TREE_CODE (res
) != STATEMENT_LIST
)
1929 SET_EXPR_LOCATION (res
, input_location
);
1931 /* Add the new statement to the block. */
1932 gfc_add_expr_to_block (&block
, res
);
1936 /* Return the finished block. */
1937 return gfc_finish_block (&block
);
1941 /* Translate an executable statement with condition, cond. The condition is
1942 used by gfc_trans_do to test for IO result conditions inside implied
1943 DO loops of READ and WRITE statements. See build_dt in trans-io.c. */
1946 gfc_trans_code_cond (gfc_code
* code
, tree cond
)
1948 return trans_code (code
, cond
);
1951 /* Translate an executable statement without condition. */
1954 gfc_trans_code (gfc_code
* code
)
1956 return trans_code (code
, NULL_TREE
);
1960 /* This function is called after a complete program unit has been parsed
1964 gfc_generate_code (gfc_namespace
* ns
)
1967 if (ns
->is_block_data
)
1969 gfc_generate_block_data (ns
);
1973 gfc_generate_function_code (ns
);
1977 /* This function is called after a complete module has been parsed
1981 gfc_generate_module_code (gfc_namespace
* ns
)
1984 struct module_htab_entry
*entry
;
1986 gcc_assert (ns
->proc_name
->backend_decl
== NULL
);
1987 ns
->proc_name
->backend_decl
1988 = build_decl (ns
->proc_name
->declared_at
.lb
->location
,
1989 NAMESPACE_DECL
, get_identifier (ns
->proc_name
->name
),
1991 entry
= gfc_find_module (ns
->proc_name
->name
);
1992 if (entry
->namespace_decl
)
1993 /* Buggy sourcecode, using a module before defining it? */
1994 entry
->decls
->empty ();
1995 entry
->namespace_decl
= ns
->proc_name
->backend_decl
;
1997 gfc_generate_module_vars (ns
);
1999 /* We need to generate all module function prototypes first, to allow
2001 for (n
= ns
->contained
; n
; n
= n
->sibling
)
2008 gfc_create_function_decl (n
, false);
2009 DECL_CONTEXT (n
->proc_name
->backend_decl
) = ns
->proc_name
->backend_decl
;
2010 gfc_module_add_decl (entry
, n
->proc_name
->backend_decl
);
2011 for (el
= ns
->entries
; el
; el
= el
->next
)
2013 DECL_CONTEXT (el
->sym
->backend_decl
) = ns
->proc_name
->backend_decl
;
2014 gfc_module_add_decl (entry
, el
->sym
->backend_decl
);
2018 for (n
= ns
->contained
; n
; n
= n
->sibling
)
2023 gfc_generate_function_code (n
);
2028 /* Initialize an init/cleanup block with existing code. */
2031 gfc_start_wrapped_block (gfc_wrapped_block
* block
, tree code
)
2035 block
->init
= NULL_TREE
;
2037 block
->cleanup
= NULL_TREE
;
2041 /* Add a new pair of initializers/clean-up code. */
2044 gfc_add_init_cleanup (gfc_wrapped_block
* block
, tree init
, tree cleanup
)
2048 /* The new pair of init/cleanup should be "wrapped around" the existing
2049 block of code, thus the initialization is added to the front and the
2050 cleanup to the back. */
2051 add_expr_to_chain (&block
->init
, init
, true);
2052 add_expr_to_chain (&block
->cleanup
, cleanup
, false);
2056 /* Finish up a wrapped block by building a corresponding try-finally expr. */
2059 gfc_finish_wrapped_block (gfc_wrapped_block
* block
)
2065 /* Build the final expression. For this, just add init and body together,
2066 and put clean-up with that into a TRY_FINALLY_EXPR. */
2067 result
= block
->init
;
2068 add_expr_to_chain (&result
, block
->code
, false);
2070 result
= build2_loc (input_location
, TRY_FINALLY_EXPR
, void_type_node
,
2071 result
, block
->cleanup
);
2073 /* Clear the block. */
2074 block
->init
= NULL_TREE
;
2075 block
->code
= NULL_TREE
;
2076 block
->cleanup
= NULL_TREE
;
2082 /* Helper function for marking a boolean expression tree as unlikely. */
2085 gfc_unlikely (tree cond
, enum br_predictor predictor
)
2091 cond
= fold_convert (long_integer_type_node
, cond
);
2092 tmp
= build_zero_cst (long_integer_type_node
);
2093 cond
= build_call_expr_loc (input_location
,
2094 builtin_decl_explicit (BUILT_IN_EXPECT
),
2096 build_int_cst (integer_type_node
,
2099 cond
= fold_convert (boolean_type_node
, cond
);
2104 /* Helper function for marking a boolean expression tree as likely. */
2107 gfc_likely (tree cond
, enum br_predictor predictor
)
2113 cond
= fold_convert (long_integer_type_node
, cond
);
2114 tmp
= build_one_cst (long_integer_type_node
);
2115 cond
= build_call_expr_loc (input_location
,
2116 builtin_decl_explicit (BUILT_IN_EXPECT
),
2118 build_int_cst (integer_type_node
,
2121 cond
= fold_convert (boolean_type_node
, cond
);
2126 /* Get the string length for a deferred character length component. */
2129 gfc_deferred_strlen (gfc_component
*c
, tree
*decl
)
2131 char name
[GFC_MAX_SYMBOL_LEN
+9];
2132 gfc_component
*strlen
;
2133 if (!(c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
))
2135 sprintf (name
, "_%s_length", c
->name
);
2136 for (strlen
= c
; strlen
; strlen
= strlen
->next
)
2137 if (strcmp (strlen
->name
, name
) == 0)
2139 *decl
= strlen
? strlen
->backend_decl
: NULL_TREE
;
2140 return strlen
!= NULL
;