1 /* Code translation -- generate GCC trees from gfc_code.
2 Copyright (C) 2002-2013 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"
25 #include "gimple-expr.h" /* For create_tmp_var_raw. */
26 #include "stringpool.h"
27 #include "tree-iterator.h"
28 #include "diagnostic-core.h" /* For internal_error. */
32 #include "trans-stmt.h"
33 #include "trans-array.h"
34 #include "trans-types.h"
35 #include "trans-const.h"
37 /* Naming convention for backend interface code:
39 gfc_trans_* translate gfc_code into STMT trees.
41 gfc_conv_* expression conversion
43 gfc_get_* get a backend tree representation of a decl or type */
45 static gfc_file
*gfc_current_backend_file
;
47 const char gfc_msg_fault
[] = N_("Array reference out of bounds");
48 const char gfc_msg_wrong_return
[] = N_("Incorrect function return value");
51 /* Advance along TREE_CHAIN n times. */
54 gfc_advance_chain (tree t
, int n
)
58 gcc_assert (t
!= NULL_TREE
);
65 /* Strip off a legitimate source ending from the input
66 string NAME of length LEN. */
69 remove_suffix (char *name
, int len
)
73 for (i
= 2; i
< 8 && len
> i
; i
++)
75 if (name
[len
- i
] == '.')
84 /* Creates a variable declaration with a given TYPE. */
87 gfc_create_var_np (tree type
, const char *prefix
)
91 t
= create_tmp_var_raw (type
, prefix
);
93 /* No warnings for anonymous variables. */
95 TREE_NO_WARNING (t
) = 1;
101 /* Like above, but also adds it to the current scope. */
104 gfc_create_var (tree type
, const char *prefix
)
108 tmp
= gfc_create_var_np (type
, prefix
);
116 /* If the expression is not constant, evaluate it now. We assign the
117 result of the expression to an artificially created variable VAR, and
118 return a pointer to the VAR_DECL node for this variable. */
121 gfc_evaluate_now_loc (location_t loc
, tree expr
, stmtblock_t
* pblock
)
125 if (CONSTANT_CLASS_P (expr
))
128 var
= gfc_create_var (TREE_TYPE (expr
), NULL
);
129 gfc_add_modify_loc (loc
, pblock
, var
, expr
);
136 gfc_evaluate_now (tree expr
, stmtblock_t
* pblock
)
138 return gfc_evaluate_now_loc (input_location
, expr
, pblock
);
142 /* Build a MODIFY_EXPR node and add it to a given statement block PBLOCK.
143 A MODIFY_EXPR is an assignment:
147 gfc_add_modify_loc (location_t loc
, stmtblock_t
* pblock
, tree lhs
, tree rhs
)
151 #ifdef ENABLE_CHECKING
153 t1
= TREE_TYPE (rhs
);
154 t2
= TREE_TYPE (lhs
);
155 /* Make sure that the types of the rhs and the lhs are the same
156 for scalar assignments. We should probably have something
157 similar for aggregates, but right now removing that check just
158 breaks everything. */
160 || AGGREGATE_TYPE_P (TREE_TYPE (lhs
)));
163 tmp
= fold_build2_loc (loc
, MODIFY_EXPR
, void_type_node
, lhs
,
165 gfc_add_expr_to_block (pblock
, tmp
);
170 gfc_add_modify (stmtblock_t
* pblock
, tree lhs
, tree rhs
)
172 gfc_add_modify_loc (input_location
, pblock
, lhs
, rhs
);
176 /* Create a new scope/binding level and initialize a block. Care must be
177 taken when translating expressions as any temporaries will be placed in
178 the innermost scope. */
181 gfc_start_block (stmtblock_t
* block
)
183 /* Start a new binding level. */
185 block
->has_scope
= 1;
187 /* The block is empty. */
188 block
->head
= NULL_TREE
;
192 /* Initialize a block without creating a new scope. */
195 gfc_init_block (stmtblock_t
* block
)
197 block
->head
= NULL_TREE
;
198 block
->has_scope
= 0;
202 /* Sometimes we create a scope but it turns out that we don't actually
203 need it. This function merges the scope of BLOCK with its parent.
204 Only variable decls will be merged, you still need to add the code. */
207 gfc_merge_block_scope (stmtblock_t
* block
)
212 gcc_assert (block
->has_scope
);
213 block
->has_scope
= 0;
215 /* Remember the decls in this scope. */
219 /* Add them to the parent scope. */
220 while (decl
!= NULL_TREE
)
222 next
= DECL_CHAIN (decl
);
223 DECL_CHAIN (decl
) = NULL_TREE
;
231 /* Finish a scope containing a block of statements. */
234 gfc_finish_block (stmtblock_t
* stmtblock
)
240 expr
= stmtblock
->head
;
242 expr
= build_empty_stmt (input_location
);
244 stmtblock
->head
= NULL_TREE
;
246 if (stmtblock
->has_scope
)
252 block
= poplevel (1, 0);
253 expr
= build3_v (BIND_EXPR
, decl
, expr
, block
);
263 /* Build an ADDR_EXPR and cast the result to TYPE. If TYPE is NULL, the
264 natural type is used. */
267 gfc_build_addr_expr (tree type
, tree t
)
269 tree base_type
= TREE_TYPE (t
);
272 if (type
&& POINTER_TYPE_P (type
)
273 && TREE_CODE (base_type
) == ARRAY_TYPE
274 && TYPE_MAIN_VARIANT (TREE_TYPE (type
))
275 == TYPE_MAIN_VARIANT (TREE_TYPE (base_type
)))
277 tree min_val
= size_zero_node
;
278 tree type_domain
= TYPE_DOMAIN (base_type
);
279 if (type_domain
&& TYPE_MIN_VALUE (type_domain
))
280 min_val
= TYPE_MIN_VALUE (type_domain
);
281 t
= fold (build4_loc (input_location
, ARRAY_REF
, TREE_TYPE (type
),
282 t
, min_val
, NULL_TREE
, NULL_TREE
));
286 natural_type
= build_pointer_type (base_type
);
288 if (TREE_CODE (t
) == INDIRECT_REF
)
292 t
= TREE_OPERAND (t
, 0);
293 natural_type
= TREE_TYPE (t
);
297 tree base
= get_base_address (t
);
298 if (base
&& DECL_P (base
))
299 TREE_ADDRESSABLE (base
) = 1;
300 t
= fold_build1_loc (input_location
, ADDR_EXPR
, natural_type
, t
);
303 if (type
&& natural_type
!= type
)
304 t
= convert (type
, t
);
310 /* Build an ARRAY_REF with its natural type. */
313 gfc_build_array_ref (tree base
, tree offset
, tree decl
)
315 tree type
= TREE_TYPE (base
);
319 if (GFC_ARRAY_TYPE_P (type
) && GFC_TYPE_ARRAY_RANK (type
) == 0)
321 gcc_assert (GFC_TYPE_ARRAY_CORANK (type
) > 0);
323 return fold_convert (TYPE_MAIN_VARIANT (type
), base
);
326 /* Scalar coarray, there is nothing to do. */
327 if (TREE_CODE (type
) != ARRAY_TYPE
)
329 gcc_assert (decl
== NULL_TREE
);
330 gcc_assert (integer_zerop (offset
));
334 type
= TREE_TYPE (type
);
337 TREE_ADDRESSABLE (base
) = 1;
339 /* Strip NON_LVALUE_EXPR nodes. */
340 STRIP_TYPE_NOPS (offset
);
342 /* If the array reference is to a pointer, whose target contains a
343 subreference, use the span that is stored with the backend decl
344 and reference the element with pointer arithmetic. */
345 if (decl
&& (TREE_CODE (decl
) == FIELD_DECL
346 || TREE_CODE (decl
) == VAR_DECL
347 || TREE_CODE (decl
) == PARM_DECL
)
348 && ((GFC_DECL_SUBREF_ARRAY_P (decl
)
349 && !integer_zerop (GFC_DECL_SPAN(decl
)))
350 || GFC_DECL_CLASS (decl
)))
352 if (GFC_DECL_CLASS (decl
))
354 /* Allow for dummy arguments and other good things. */
355 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
356 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
358 /* Check if '_data' is an array descriptor. If it is not,
359 the array must be one of the components of the class object,
360 so return a normal array reference. */
361 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_class_data_get (decl
))))
362 return build4_loc (input_location
, ARRAY_REF
, type
, base
,
363 offset
, NULL_TREE
, NULL_TREE
);
365 span
= gfc_vtable_size_get (decl
);
367 else if (GFC_DECL_SUBREF_ARRAY_P (decl
))
368 span
= GFC_DECL_SPAN(decl
);
372 offset
= fold_build2_loc (input_location
, MULT_EXPR
,
373 gfc_array_index_type
,
375 tmp
= gfc_build_addr_expr (pvoid_type_node
, base
);
376 tmp
= fold_build_pointer_plus_loc (input_location
, tmp
, offset
);
377 tmp
= fold_convert (build_pointer_type (type
), tmp
);
378 if (!TYPE_STRING_FLAG (type
))
379 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
383 /* Otherwise use a straightforward array reference. */
384 return build4_loc (input_location
, ARRAY_REF
, type
, base
, offset
,
385 NULL_TREE
, NULL_TREE
);
389 /* Generate a call to print a runtime error possibly including multiple
390 arguments and a locus. */
393 trans_runtime_error_vararg (bool error
, locus
* where
, const char* msgid
,
406 /* Compute the number of extra arguments from the format string. */
407 for (p
= msgid
, nargs
= 0; *p
; p
++)
415 /* The code to generate the error. */
416 gfc_start_block (&block
);
420 line
= LOCATION_LINE (where
->lb
->location
);
421 asprintf (&message
, "At line %d of file %s", line
,
422 where
->lb
->file
->filename
);
425 asprintf (&message
, "In file '%s', around line %d",
426 gfc_source_file
, LOCATION_LINE (input_location
) + 1);
428 arg
= gfc_build_addr_expr (pchar_type_node
,
429 gfc_build_localized_cstring_const (message
));
432 asprintf (&message
, "%s", _(msgid
));
433 arg2
= gfc_build_addr_expr (pchar_type_node
,
434 gfc_build_localized_cstring_const (message
));
437 /* Build the argument array. */
438 argarray
= XALLOCAVEC (tree
, nargs
+ 2);
441 for (i
= 0; i
< nargs
; i
++)
442 argarray
[2 + i
] = va_arg (ap
, tree
);
444 /* Build the function call to runtime_(warning,error)_at; because of the
445 variable number of arguments, we can't use build_call_expr_loc dinput_location,
448 fntype
= TREE_TYPE (gfor_fndecl_runtime_error_at
);
450 fntype
= TREE_TYPE (gfor_fndecl_runtime_warning_at
);
452 loc
= where
? where
->lb
->location
: input_location
;
453 tmp
= fold_builtin_call_array (loc
, TREE_TYPE (fntype
),
454 fold_build1_loc (loc
, ADDR_EXPR
,
455 build_pointer_type (fntype
),
457 ? gfor_fndecl_runtime_error_at
458 : gfor_fndecl_runtime_warning_at
),
459 nargs
+ 2, argarray
);
460 gfc_add_expr_to_block (&block
, tmp
);
462 return gfc_finish_block (&block
);
467 gfc_trans_runtime_error (bool error
, locus
* where
, const char* msgid
, ...)
472 va_start (ap
, msgid
);
473 result
= trans_runtime_error_vararg (error
, where
, msgid
, ap
);
479 /* Generate a runtime error if COND is true. */
482 gfc_trans_runtime_check (bool error
, bool once
, tree cond
, stmtblock_t
* pblock
,
483 locus
* where
, const char * msgid
, ...)
491 if (integer_zerop (cond
))
496 tmpvar
= gfc_create_var (boolean_type_node
, "print_warning");
497 TREE_STATIC (tmpvar
) = 1;
498 DECL_INITIAL (tmpvar
) = boolean_true_node
;
499 gfc_add_expr_to_block (pblock
, tmpvar
);
502 gfc_start_block (&block
);
504 /* The code to generate the error. */
505 va_start (ap
, msgid
);
506 gfc_add_expr_to_block (&block
,
507 trans_runtime_error_vararg (error
, where
,
512 gfc_add_modify (&block
, tmpvar
, boolean_false_node
);
514 body
= gfc_finish_block (&block
);
516 if (integer_onep (cond
))
518 gfc_add_expr_to_block (pblock
, body
);
522 /* Tell the compiler that this isn't likely. */
524 cond
= fold_build2_loc (where
->lb
->location
, TRUTH_AND_EXPR
,
525 long_integer_type_node
, tmpvar
, cond
);
527 cond
= fold_convert (long_integer_type_node
, cond
);
529 cond
= gfc_unlikely (cond
);
530 tmp
= fold_build3_loc (where
->lb
->location
, COND_EXPR
, void_type_node
,
532 build_empty_stmt (where
->lb
->location
));
533 gfc_add_expr_to_block (pblock
, tmp
);
538 /* Call malloc to allocate size bytes of memory, with special conditions:
539 + if size == 0, return a malloced area of size 1,
540 + if malloc returns NULL, issue a runtime error. */
542 gfc_call_malloc (stmtblock_t
* block
, tree type
, tree size
)
544 tree tmp
, msg
, malloc_result
, null_result
, res
, malloc_tree
;
547 size
= gfc_evaluate_now (size
, block
);
549 if (TREE_TYPE (size
) != TREE_TYPE (size_type_node
))
550 size
= fold_convert (size_type_node
, size
);
552 /* Create a variable to hold the result. */
553 res
= gfc_create_var (prvoid_type_node
, NULL
);
556 gfc_start_block (&block2
);
558 size
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
, size
,
559 build_int_cst (size_type_node
, 1));
561 malloc_tree
= builtin_decl_explicit (BUILT_IN_MALLOC
);
562 gfc_add_modify (&block2
, res
,
563 fold_convert (prvoid_type_node
,
564 build_call_expr_loc (input_location
,
565 malloc_tree
, 1, size
)));
567 /* Optionally check whether malloc was successful. */
568 if (gfc_option
.rtcheck
& GFC_RTCHECK_MEM
)
570 null_result
= fold_build2_loc (input_location
, EQ_EXPR
,
571 boolean_type_node
, res
,
572 build_int_cst (pvoid_type_node
, 0));
573 msg
= gfc_build_addr_expr (pchar_type_node
,
574 gfc_build_localized_cstring_const ("Memory allocation failed"));
575 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
577 build_call_expr_loc (input_location
,
578 gfor_fndecl_os_error
, 1, msg
),
579 build_empty_stmt (input_location
));
580 gfc_add_expr_to_block (&block2
, tmp
);
583 malloc_result
= gfc_finish_block (&block2
);
585 gfc_add_expr_to_block (block
, malloc_result
);
588 res
= fold_convert (type
, res
);
593 /* Allocate memory, using an optional status argument.
595 This function follows the following pseudo-code:
598 allocate (size_t size, integer_type stat)
605 newmem = malloc (MAX (size, 1));
609 *stat = LIBERROR_ALLOCATION;
611 runtime_error ("Allocation would exceed memory limit");
616 gfc_allocate_using_malloc (stmtblock_t
* block
, tree pointer
,
617 tree size
, tree status
)
619 tree tmp
, on_error
, error_cond
;
620 tree status_type
= status
? TREE_TYPE (status
) : NULL_TREE
;
622 /* Evaluate size only once, and make sure it has the right type. */
623 size
= gfc_evaluate_now (size
, block
);
624 if (TREE_TYPE (size
) != TREE_TYPE (size_type_node
))
625 size
= fold_convert (size_type_node
, size
);
627 /* If successful and stat= is given, set status to 0. */
628 if (status
!= NULL_TREE
)
629 gfc_add_expr_to_block (block
,
630 fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
631 status
, build_int_cst (status_type
, 0)));
633 /* The allocation itself. */
634 gfc_add_modify (block
, pointer
,
635 fold_convert (TREE_TYPE (pointer
),
636 build_call_expr_loc (input_location
,
637 builtin_decl_explicit (BUILT_IN_MALLOC
), 1,
638 fold_build2_loc (input_location
,
639 MAX_EXPR
, size_type_node
, size
,
640 build_int_cst (size_type_node
, 1)))));
642 /* What to do in case of error. */
643 if (status
!= NULL_TREE
)
644 on_error
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
645 status
, build_int_cst (status_type
, LIBERROR_ALLOCATION
));
647 on_error
= build_call_expr_loc (input_location
, gfor_fndecl_os_error
, 1,
648 gfc_build_addr_expr (pchar_type_node
,
649 gfc_build_localized_cstring_const
650 ("Allocation would exceed memory limit")));
652 error_cond
= fold_build2_loc (input_location
, EQ_EXPR
,
653 boolean_type_node
, pointer
,
654 build_int_cst (prvoid_type_node
, 0));
655 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
656 gfc_unlikely (error_cond
), on_error
,
657 build_empty_stmt (input_location
));
659 gfc_add_expr_to_block (block
, tmp
);
663 /* Allocate memory, using an optional status argument.
665 This function follows the following pseudo-code:
668 allocate (size_t size, void** token, int *stat, char* errmsg, int errlen)
672 newmem = _caf_register (size, regtype, token, &stat, errmsg, errlen);
676 gfc_allocate_using_lib (stmtblock_t
* block
, tree pointer
, tree size
,
677 tree token
, tree status
, tree errmsg
, tree errlen
)
681 gcc_assert (token
!= NULL_TREE
);
683 /* Evaluate size only once, and make sure it has the right type. */
684 size
= gfc_evaluate_now (size
, block
);
685 if (TREE_TYPE (size
) != TREE_TYPE (size_type_node
))
686 size
= fold_convert (size_type_node
, size
);
688 /* The allocation itself. */
689 if (status
== NULL_TREE
)
690 pstat
= null_pointer_node
;
692 pstat
= gfc_build_addr_expr (NULL_TREE
, status
);
694 if (errmsg
== NULL_TREE
)
696 gcc_assert(errlen
== NULL_TREE
);
697 errmsg
= null_pointer_node
;
698 errlen
= build_int_cst (integer_type_node
, 0);
701 tmp
= build_call_expr_loc (input_location
,
702 gfor_fndecl_caf_register
, 6,
703 fold_build2_loc (input_location
,
704 MAX_EXPR
, size_type_node
, size
,
705 build_int_cst (size_type_node
, 1)),
706 build_int_cst (integer_type_node
,
707 GFC_CAF_COARRAY_ALLOC
),
708 token
, pstat
, errmsg
, errlen
);
710 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
711 TREE_TYPE (pointer
), pointer
,
712 fold_convert ( TREE_TYPE (pointer
), tmp
));
713 gfc_add_expr_to_block (block
, tmp
);
717 /* Generate code for an ALLOCATE statement when the argument is an
718 allocatable variable. If the variable is currently allocated, it is an
719 error to allocate it again.
721 This function follows the following pseudo-code:
724 allocate_allocatable (void *mem, size_t size, integer_type stat)
727 return allocate (size, stat);
731 stat = LIBERROR_ALLOCATION;
733 runtime_error ("Attempting to allocate already allocated variable");
737 expr must be set to the original expression being allocated for its locus
738 and variable name in case a runtime error has to be printed. */
740 gfc_allocate_allocatable (stmtblock_t
* block
, tree mem
, tree size
, tree token
,
741 tree status
, tree errmsg
, tree errlen
, tree label_finish
,
744 stmtblock_t alloc_block
;
745 tree tmp
, null_mem
, alloc
, error
;
746 tree type
= TREE_TYPE (mem
);
748 if (TREE_TYPE (size
) != TREE_TYPE (size_type_node
))
749 size
= fold_convert (size_type_node
, size
);
751 null_mem
= gfc_unlikely (fold_build2_loc (input_location
, NE_EXPR
,
752 boolean_type_node
, mem
,
753 build_int_cst (type
, 0)));
755 /* If mem is NULL, we call gfc_allocate_using_malloc or
756 gfc_allocate_using_lib. */
757 gfc_start_block (&alloc_block
);
759 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
760 && gfc_expr_attr (expr
).codimension
)
764 gfc_allocate_using_lib (&alloc_block
, mem
, size
, token
, status
,
766 if (status
!= NULL_TREE
)
768 TREE_USED (label_finish
) = 1;
769 tmp
= build1_v (GOTO_EXPR
, label_finish
);
770 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
771 status
, build_zero_cst (TREE_TYPE (status
)));
772 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
773 gfc_unlikely (cond
), tmp
,
774 build_empty_stmt (input_location
));
775 gfc_add_expr_to_block (&alloc_block
, tmp
);
779 gfc_allocate_using_malloc (&alloc_block
, mem
, size
, status
);
781 alloc
= gfc_finish_block (&alloc_block
);
783 /* If mem is not NULL, we issue a runtime error or set the
789 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
&& expr
->symtree
);
790 varname
= gfc_build_cstring_const (expr
->symtree
->name
);
791 varname
= gfc_build_addr_expr (pchar_type_node
, varname
);
793 error
= gfc_trans_runtime_error (true, &expr
->where
,
794 "Attempting to allocate already"
795 " allocated variable '%s'",
799 error
= gfc_trans_runtime_error (true, NULL
,
800 "Attempting to allocate already allocated"
803 if (status
!= NULL_TREE
)
805 tree status_type
= TREE_TYPE (status
);
807 error
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
808 status
, build_int_cst (status_type
, LIBERROR_ALLOCATION
));
811 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, null_mem
,
813 gfc_add_expr_to_block (block
, tmp
);
817 /* Free a given variable, if it's not NULL. */
819 gfc_call_free (tree var
)
822 tree tmp
, cond
, call
;
824 if (TREE_TYPE (var
) != TREE_TYPE (pvoid_type_node
))
825 var
= fold_convert (pvoid_type_node
, var
);
827 gfc_start_block (&block
);
828 var
= gfc_evaluate_now (var
, &block
);
829 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, var
,
830 build_int_cst (pvoid_type_node
, 0));
831 call
= build_call_expr_loc (input_location
,
832 builtin_decl_explicit (BUILT_IN_FREE
),
834 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, call
,
835 build_empty_stmt (input_location
));
836 gfc_add_expr_to_block (&block
, tmp
);
838 return gfc_finish_block (&block
);
842 /* Build a call to a FINAL procedure, which finalizes "var". */
845 gfc_build_final_call (gfc_typespec ts
, gfc_expr
*final_wrapper
, gfc_expr
*var
,
846 bool fini_coarray
, gfc_expr
*class_size
)
850 tree final_fndecl
, array
, size
, tmp
;
851 symbol_attribute attr
;
853 gcc_assert (final_wrapper
->expr_type
== EXPR_VARIABLE
);
856 gfc_start_block (&block
);
857 gfc_init_se (&se
, NULL
);
858 gfc_conv_expr (&se
, final_wrapper
);
859 final_fndecl
= se
.expr
;
860 if (POINTER_TYPE_P (TREE_TYPE (final_fndecl
)))
861 final_fndecl
= build_fold_indirect_ref_loc (input_location
, final_fndecl
);
863 if (ts
.type
== BT_DERIVED
)
867 gcc_assert (!class_size
);
868 elem_size
= gfc_typenode_for_spec (&ts
);
869 elem_size
= TYPE_SIZE_UNIT (elem_size
);
870 size
= fold_convert (gfc_array_index_type
, elem_size
);
872 gfc_init_se (&se
, NULL
);
876 se
.descriptor_only
= 1;
877 gfc_conv_expr_descriptor (&se
, var
);
882 gfc_conv_expr (&se
, var
);
883 gcc_assert (se
.pre
.head
== NULL_TREE
&& se
.post
.head
== NULL_TREE
);
886 /* No copy back needed, hence set attr's allocatable/pointer
888 gfc_clear_attr (&attr
);
889 gfc_init_se (&se
, NULL
);
890 array
= gfc_conv_scalar_to_descriptor (&se
, array
, attr
);
891 gcc_assert (se
.post
.head
== NULL_TREE
);
896 gfc_expr
*array_expr
;
897 gcc_assert (class_size
);
898 gfc_init_se (&se
, NULL
);
899 gfc_conv_expr (&se
, class_size
);
900 gfc_add_block_to_block (&block
, &se
.pre
);
901 gcc_assert (se
.post
.head
== NULL_TREE
);
904 array_expr
= gfc_copy_expr (var
);
905 gfc_init_se (&se
, NULL
);
907 if (array_expr
->rank
)
909 gfc_add_class_array_ref (array_expr
);
910 se
.descriptor_only
= 1;
911 gfc_conv_expr_descriptor (&se
, array_expr
);
916 gfc_add_data_component (array_expr
);
917 gfc_conv_expr (&se
, array_expr
);
918 gfc_add_block_to_block (&block
, &se
.pre
);
919 gcc_assert (se
.post
.head
== NULL_TREE
);
921 if (TREE_CODE (array
) == ADDR_EXPR
922 && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (array
, 0))))
923 tmp
= TREE_OPERAND (array
, 0);
925 if (!gfc_is_coarray (array_expr
))
927 /* No copy back needed, hence set attr's allocatable/pointer
929 gfc_clear_attr (&attr
);
930 gfc_init_se (&se
, NULL
);
931 array
= gfc_conv_scalar_to_descriptor (&se
, array
, attr
);
933 gcc_assert (se
.post
.head
== NULL_TREE
);
935 gfc_free_expr (array_expr
);
938 if (!POINTER_TYPE_P (TREE_TYPE (array
)))
939 array
= gfc_build_addr_expr (NULL
, array
);
941 gfc_add_block_to_block (&block
, &se
.pre
);
942 tmp
= build_call_expr_loc (input_location
,
943 final_fndecl
, 3, array
,
944 size
, fini_coarray
? boolean_true_node
945 : boolean_false_node
);
946 gfc_add_block_to_block (&block
, &se
.post
);
947 gfc_add_expr_to_block (&block
, tmp
);
948 return gfc_finish_block (&block
);
953 gfc_add_comp_finalizer_call (stmtblock_t
*block
, tree decl
, gfc_component
*comp
,
958 tree final_fndecl
, size
, array
, tmp
, cond
;
959 symbol_attribute attr
;
960 gfc_expr
*final_expr
= NULL
;
962 if (comp
->ts
.type
!= BT_DERIVED
&& comp
->ts
.type
!= BT_CLASS
)
965 gfc_init_block (&block2
);
967 if (comp
->ts
.type
== BT_DERIVED
)
969 if (comp
->attr
.pointer
)
972 gfc_is_finalizable (comp
->ts
.u
.derived
, &final_expr
);
976 gfc_init_se (&se
, NULL
);
977 gfc_conv_expr (&se
, final_expr
);
978 final_fndecl
= se
.expr
;
979 size
= gfc_typenode_for_spec (&comp
->ts
);
980 size
= TYPE_SIZE_UNIT (size
);
981 size
= fold_convert (gfc_array_index_type
, size
);
985 else /* comp->ts.type == BT_CLASS. */
987 if (CLASS_DATA (comp
)->attr
.class_pointer
)
990 gfc_is_finalizable (CLASS_DATA (comp
)->ts
.u
.derived
, &final_expr
);
991 final_fndecl
= gfc_vtable_final_get (decl
);
992 size
= gfc_vtable_size_get (decl
);
993 array
= gfc_class_data_get (decl
);
996 if (comp
->attr
.allocatable
997 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)->attr
.allocatable
))
999 tmp
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array
))
1000 ? gfc_conv_descriptor_data_get (array
) : array
;
1001 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1002 tmp
, fold_convert (TREE_TYPE (tmp
),
1003 null_pointer_node
));
1006 cond
= boolean_true_node
;
1008 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array
)))
1010 gfc_clear_attr (&attr
);
1011 gfc_init_se (&se
, NULL
);
1012 array
= gfc_conv_scalar_to_descriptor (&se
, array
, attr
);
1013 gfc_add_block_to_block (&block2
, &se
.pre
);
1014 gcc_assert (se
.post
.head
== NULL_TREE
);
1017 if (!POINTER_TYPE_P (TREE_TYPE (array
)))
1018 array
= gfc_build_addr_expr (NULL
, array
);
1022 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1024 fold_convert (TREE_TYPE (final_fndecl
),
1025 null_pointer_node
));
1026 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1027 boolean_type_node
, cond
, tmp
);
1030 if (POINTER_TYPE_P (TREE_TYPE (final_fndecl
)))
1031 final_fndecl
= build_fold_indirect_ref_loc (input_location
, final_fndecl
);
1033 tmp
= build_call_expr_loc (input_location
,
1034 final_fndecl
, 3, array
,
1035 size
, fini_coarray
? boolean_true_node
1036 : boolean_false_node
);
1037 gfc_add_expr_to_block (&block2
, tmp
);
1038 tmp
= gfc_finish_block (&block2
);
1040 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
1041 build_empty_stmt (input_location
));
1042 gfc_add_expr_to_block (block
, tmp
);
1048 /* Add a call to the finalizer, using the passed *expr. Returns
1049 true when a finalizer call has been inserted. */
1052 gfc_add_finalizer_call (stmtblock_t
*block
, gfc_expr
*expr2
)
1057 gfc_expr
*final_expr
= NULL
;
1058 gfc_expr
*elem_size
= NULL
;
1059 bool has_finalizer
= false;
1061 if (!expr2
|| (expr2
->ts
.type
!= BT_DERIVED
&& expr2
->ts
.type
!= BT_CLASS
))
1064 if (expr2
->ts
.type
== BT_DERIVED
)
1066 gfc_is_finalizable (expr2
->ts
.u
.derived
, &final_expr
);
1071 /* If we have a class array, we need go back to the class
1073 expr
= gfc_copy_expr (expr2
);
1075 if (expr
->ref
&& expr
->ref
->next
&& !expr
->ref
->next
->next
1076 && expr
->ref
->next
->type
== REF_ARRAY
1077 && expr
->ref
->type
== REF_COMPONENT
1078 && strcmp (expr
->ref
->u
.c
.component
->name
, "_data") == 0)
1080 gfc_free_ref_list (expr
->ref
);
1084 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1085 if (ref
->next
&& ref
->next
->next
&& !ref
->next
->next
->next
1086 && ref
->next
->next
->type
== REF_ARRAY
1087 && ref
->next
->type
== REF_COMPONENT
1088 && strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0)
1090 gfc_free_ref_list (ref
->next
);
1094 if (expr
->ts
.type
== BT_CLASS
)
1096 has_finalizer
= gfc_is_finalizable (expr
->ts
.u
.derived
, NULL
);
1098 if (!expr2
->rank
&& !expr2
->ref
&& CLASS_DATA (expr2
->symtree
->n
.sym
)->as
)
1099 expr
->rank
= CLASS_DATA (expr2
->symtree
->n
.sym
)->as
->rank
;
1101 final_expr
= gfc_copy_expr (expr
);
1102 gfc_add_vptr_component (final_expr
);
1103 gfc_add_component_ref (final_expr
, "_final");
1105 elem_size
= gfc_copy_expr (expr
);
1106 gfc_add_vptr_component (elem_size
);
1107 gfc_add_component_ref (elem_size
, "_size");
1110 gcc_assert (final_expr
->expr_type
== EXPR_VARIABLE
);
1112 tmp
= gfc_build_final_call (expr
->ts
, final_expr
, expr
,
1115 if (expr
->ts
.type
== BT_CLASS
&& !has_finalizer
)
1120 gfc_init_se (&se
, NULL
);
1121 se
.want_pointer
= 1;
1122 gfc_conv_expr (&se
, final_expr
);
1123 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1124 se
.expr
, build_int_cst (TREE_TYPE (se
.expr
), 0));
1126 /* For CLASS(*) not only sym->_vtab->_final can be NULL
1127 but already sym->_vtab itself. */
1128 if (UNLIMITED_POLY (expr
))
1131 gfc_expr
*vptr_expr
;
1133 vptr_expr
= gfc_copy_expr (expr
);
1134 gfc_add_vptr_component (vptr_expr
);
1136 gfc_init_se (&se
, NULL
);
1137 se
.want_pointer
= 1;
1138 gfc_conv_expr (&se
, vptr_expr
);
1139 gfc_free_expr (vptr_expr
);
1141 cond2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1143 build_int_cst (TREE_TYPE (se
.expr
), 0));
1144 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1145 boolean_type_node
, cond2
, cond
);
1148 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1149 cond
, tmp
, build_empty_stmt (input_location
));
1152 gfc_add_expr_to_block (block
, tmp
);
1158 /* User-deallocate; we emit the code directly from the front-end, and the
1159 logic is the same as the previous library function:
1162 deallocate (void *pointer, GFC_INTEGER_4 * stat)
1169 runtime_error ("Attempt to DEALLOCATE unallocated memory.");
1179 In this front-end version, status doesn't have to be GFC_INTEGER_4.
1180 Moreover, if CAN_FAIL is true, then we will not emit a runtime error,
1181 even when no status variable is passed to us (this is used for
1182 unconditional deallocation generated by the front-end at end of
1185 If a runtime-message is possible, `expr' must point to the original
1186 expression being deallocated for its locus and variable name.
1188 For coarrays, "pointer" must be the array descriptor and not its
1189 "data" component. */
1191 gfc_deallocate_with_status (tree pointer
, tree status
, tree errmsg
,
1192 tree errlen
, tree label_finish
,
1193 bool can_fail
, gfc_expr
* expr
, bool coarray
)
1195 stmtblock_t null
, non_null
;
1196 tree cond
, tmp
, error
;
1197 tree status_type
= NULL_TREE
;
1198 tree caf_decl
= NULL_TREE
;
1202 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer
)));
1204 pointer
= gfc_conv_descriptor_data_get (caf_decl
);
1205 STRIP_NOPS (pointer
);
1208 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, pointer
,
1209 build_int_cst (TREE_TYPE (pointer
), 0));
1211 /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
1212 we emit a runtime error. */
1213 gfc_start_block (&null
);
1218 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
&& expr
->symtree
);
1220 varname
= gfc_build_cstring_const (expr
->symtree
->name
);
1221 varname
= gfc_build_addr_expr (pchar_type_node
, varname
);
1223 error
= gfc_trans_runtime_error (true, &expr
->where
,
1224 "Attempt to DEALLOCATE unallocated '%s'",
1228 error
= build_empty_stmt (input_location
);
1230 if (status
!= NULL_TREE
&& !integer_zerop (status
))
1234 status_type
= TREE_TYPE (TREE_TYPE (status
));
1235 cond2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1236 status
, build_int_cst (TREE_TYPE (status
), 0));
1237 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
1238 fold_build1_loc (input_location
, INDIRECT_REF
,
1239 status_type
, status
),
1240 build_int_cst (status_type
, 1));
1241 error
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1245 gfc_add_expr_to_block (&null
, error
);
1247 /* When POINTER is not NULL, we free it. */
1248 gfc_start_block (&non_null
);
1249 gfc_add_finalizer_call (&non_null
, expr
);
1250 if (!coarray
|| gfc_option
.coarray
!= GFC_FCOARRAY_LIB
)
1252 tmp
= build_call_expr_loc (input_location
,
1253 builtin_decl_explicit (BUILT_IN_FREE
), 1,
1254 fold_convert (pvoid_type_node
, pointer
));
1255 gfc_add_expr_to_block (&non_null
, tmp
);
1257 if (status
!= NULL_TREE
&& !integer_zerop (status
))
1259 /* We set STATUS to zero if it is present. */
1260 tree status_type
= TREE_TYPE (TREE_TYPE (status
));
1263 cond2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1265 build_int_cst (TREE_TYPE (status
), 0));
1266 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
1267 fold_build1_loc (input_location
, INDIRECT_REF
,
1268 status_type
, status
),
1269 build_int_cst (status_type
, 0));
1270 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1271 gfc_unlikely (cond2
), tmp
,
1272 build_empty_stmt (input_location
));
1273 gfc_add_expr_to_block (&non_null
, tmp
);
1278 tree caf_type
, token
, cond2
;
1279 tree pstat
= null_pointer_node
;
1281 if (errmsg
== NULL_TREE
)
1283 gcc_assert (errlen
== NULL_TREE
);
1284 errmsg
= null_pointer_node
;
1285 errlen
= build_zero_cst (integer_type_node
);
1289 gcc_assert (errlen
!= NULL_TREE
);
1290 if (!POINTER_TYPE_P (TREE_TYPE (errmsg
)))
1291 errmsg
= gfc_build_addr_expr (NULL_TREE
, errmsg
);
1294 caf_type
= TREE_TYPE (caf_decl
);
1296 if (status
!= NULL_TREE
&& !integer_zerop (status
))
1298 gcc_assert (status_type
== integer_type_node
);
1302 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
1303 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
1304 token
= gfc_conv_descriptor_token (caf_decl
);
1305 else if (DECL_LANG_SPECIFIC (caf_decl
)
1306 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
1307 token
= GFC_DECL_TOKEN (caf_decl
);
1310 gcc_assert (GFC_ARRAY_TYPE_P (caf_type
)
1311 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) != NULL_TREE
);
1312 token
= GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
);
1315 token
= gfc_build_addr_expr (NULL_TREE
, token
);
1316 tmp
= build_call_expr_loc (input_location
,
1317 gfor_fndecl_caf_deregister
, 4,
1318 token
, pstat
, errmsg
, errlen
);
1319 gfc_add_expr_to_block (&non_null
, tmp
);
1321 if (status
!= NULL_TREE
)
1323 tree stat
= build_fold_indirect_ref_loc (input_location
, status
);
1325 TREE_USED (label_finish
) = 1;
1326 tmp
= build1_v (GOTO_EXPR
, label_finish
);
1327 cond2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1328 stat
, build_zero_cst (TREE_TYPE (stat
)));
1329 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1330 gfc_unlikely (cond2
), tmp
,
1331 build_empty_stmt (input_location
));
1332 gfc_add_expr_to_block (&non_null
, tmp
);
1336 return fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
1337 gfc_finish_block (&null
),
1338 gfc_finish_block (&non_null
));
1342 /* Generate code for deallocation of allocatable scalars (variables or
1343 components). Before the object itself is freed, any allocatable
1344 subcomponents are being deallocated. */
1347 gfc_deallocate_scalar_with_status (tree pointer
, tree status
, bool can_fail
,
1348 gfc_expr
* expr
, gfc_typespec ts
)
1350 stmtblock_t null
, non_null
;
1351 tree cond
, tmp
, error
;
1354 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, pointer
,
1355 build_int_cst (TREE_TYPE (pointer
), 0));
1357 /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
1358 we emit a runtime error. */
1359 gfc_start_block (&null
);
1364 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
&& expr
->symtree
);
1366 varname
= gfc_build_cstring_const (expr
->symtree
->name
);
1367 varname
= gfc_build_addr_expr (pchar_type_node
, varname
);
1369 error
= gfc_trans_runtime_error (true, &expr
->where
,
1370 "Attempt to DEALLOCATE unallocated '%s'",
1374 error
= build_empty_stmt (input_location
);
1376 if (status
!= NULL_TREE
&& !integer_zerop (status
))
1378 tree status_type
= TREE_TYPE (TREE_TYPE (status
));
1381 cond2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1382 status
, build_int_cst (TREE_TYPE (status
), 0));
1383 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
1384 fold_build1_loc (input_location
, INDIRECT_REF
,
1385 status_type
, status
),
1386 build_int_cst (status_type
, 1));
1387 error
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1391 gfc_add_expr_to_block (&null
, error
);
1393 /* When POINTER is not NULL, we free it. */
1394 gfc_start_block (&non_null
);
1396 /* Free allocatable components. */
1397 finalizable
= gfc_add_finalizer_call (&non_null
, expr
);
1398 if (!finalizable
&& ts
.type
== BT_DERIVED
&& ts
.u
.derived
->attr
.alloc_comp
)
1400 tmp
= build_fold_indirect_ref_loc (input_location
, pointer
);
1401 tmp
= gfc_deallocate_alloc_comp (ts
.u
.derived
, tmp
, 0);
1402 gfc_add_expr_to_block (&non_null
, tmp
);
1405 tmp
= build_call_expr_loc (input_location
,
1406 builtin_decl_explicit (BUILT_IN_FREE
), 1,
1407 fold_convert (pvoid_type_node
, pointer
));
1408 gfc_add_expr_to_block (&non_null
, tmp
);
1410 if (status
!= NULL_TREE
&& !integer_zerop (status
))
1412 /* We set STATUS to zero if it is present. */
1413 tree status_type
= TREE_TYPE (TREE_TYPE (status
));
1416 cond2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1417 status
, build_int_cst (TREE_TYPE (status
), 0));
1418 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
1419 fold_build1_loc (input_location
, INDIRECT_REF
,
1420 status_type
, status
),
1421 build_int_cst (status_type
, 0));
1422 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
1423 tmp
, build_empty_stmt (input_location
));
1424 gfc_add_expr_to_block (&non_null
, tmp
);
1427 return fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
1428 gfc_finish_block (&null
),
1429 gfc_finish_block (&non_null
));
1433 /* Reallocate MEM so it has SIZE bytes of data. This behaves like the
1434 following pseudo-code:
1437 internal_realloc (void *mem, size_t size)
1439 res = realloc (mem, size);
1440 if (!res && size != 0)
1441 _gfortran_os_error ("Allocation would exceed memory limit");
1446 gfc_call_realloc (stmtblock_t
* block
, tree mem
, tree size
)
1448 tree msg
, res
, nonzero
, null_result
, tmp
;
1449 tree type
= TREE_TYPE (mem
);
1451 size
= gfc_evaluate_now (size
, block
);
1453 if (TREE_TYPE (size
) != TREE_TYPE (size_type_node
))
1454 size
= fold_convert (size_type_node
, size
);
1456 /* Create a variable to hold the result. */
1457 res
= gfc_create_var (type
, NULL
);
1459 /* Call realloc and check the result. */
1460 tmp
= build_call_expr_loc (input_location
,
1461 builtin_decl_explicit (BUILT_IN_REALLOC
), 2,
1462 fold_convert (pvoid_type_node
, mem
), size
);
1463 gfc_add_modify (block
, res
, fold_convert (type
, tmp
));
1464 null_result
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1465 res
, build_int_cst (pvoid_type_node
, 0));
1466 nonzero
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, size
,
1467 build_int_cst (size_type_node
, 0));
1468 null_result
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, boolean_type_node
,
1469 null_result
, nonzero
);
1470 msg
= gfc_build_addr_expr (pchar_type_node
, gfc_build_localized_cstring_const
1471 ("Allocation would exceed memory limit"));
1472 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1474 build_call_expr_loc (input_location
,
1475 gfor_fndecl_os_error
, 1, msg
),
1476 build_empty_stmt (input_location
));
1477 gfc_add_expr_to_block (block
, tmp
);
1483 /* Add an expression to another one, either at the front or the back. */
1486 add_expr_to_chain (tree
* chain
, tree expr
, bool front
)
1488 if (expr
== NULL_TREE
|| IS_EMPTY_STMT (expr
))
1493 if (TREE_CODE (*chain
) != STATEMENT_LIST
)
1499 append_to_statement_list (tmp
, chain
);
1504 tree_stmt_iterator i
;
1506 i
= tsi_start (*chain
);
1507 tsi_link_before (&i
, expr
, TSI_CONTINUE_LINKING
);
1510 append_to_statement_list (expr
, chain
);
1517 /* Add a statement at the end of a block. */
1520 gfc_add_expr_to_block (stmtblock_t
* block
, tree expr
)
1523 add_expr_to_chain (&block
->head
, expr
, false);
1527 /* Add a statement at the beginning of a block. */
1530 gfc_prepend_expr_to_block (stmtblock_t
* block
, tree expr
)
1533 add_expr_to_chain (&block
->head
, expr
, true);
1537 /* Add a block the end of a block. */
1540 gfc_add_block_to_block (stmtblock_t
* block
, stmtblock_t
* append
)
1542 gcc_assert (append
);
1543 gcc_assert (!append
->has_scope
);
1545 gfc_add_expr_to_block (block
, append
->head
);
1546 append
->head
= NULL_TREE
;
1550 /* Save the current locus. The structure may not be complete, and should
1551 only be used with gfc_restore_backend_locus. */
1554 gfc_save_backend_locus (locus
* loc
)
1556 loc
->lb
= XCNEW (gfc_linebuf
);
1557 loc
->lb
->location
= input_location
;
1558 loc
->lb
->file
= gfc_current_backend_file
;
1562 /* Set the current locus. */
1565 gfc_set_backend_locus (locus
* loc
)
1567 gfc_current_backend_file
= loc
->lb
->file
;
1568 input_location
= loc
->lb
->location
;
1572 /* Restore the saved locus. Only used in conjunction with
1573 gfc_save_backend_locus, to free the memory when we are done. */
1576 gfc_restore_backend_locus (locus
* loc
)
1578 gfc_set_backend_locus (loc
);
1583 /* Translate an executable statement. The tree cond is used by gfc_trans_do.
1584 This static function is wrapped by gfc_trans_code_cond and
1588 trans_code (gfc_code
* code
, tree cond
)
1594 return build_empty_stmt (input_location
);
1596 gfc_start_block (&block
);
1598 /* Translate statements one by one into GENERIC trees until we reach
1599 the end of this gfc_code branch. */
1600 for (; code
; code
= code
->next
)
1602 if (code
->here
!= 0)
1604 res
= gfc_trans_label_here (code
);
1605 gfc_add_expr_to_block (&block
, res
);
1608 gfc_set_backend_locus (&code
->loc
);
1613 case EXEC_END_BLOCK
:
1614 case EXEC_END_NESTED_BLOCK
:
1615 case EXEC_END_PROCEDURE
:
1620 if (code
->expr1
->ts
.type
== BT_CLASS
)
1621 res
= gfc_trans_class_assign (code
->expr1
, code
->expr2
, code
->op
);
1623 res
= gfc_trans_assign (code
);
1626 case EXEC_LABEL_ASSIGN
:
1627 res
= gfc_trans_label_assign (code
);
1630 case EXEC_POINTER_ASSIGN
:
1631 if (code
->expr1
->ts
.type
== BT_CLASS
)
1632 res
= gfc_trans_class_assign (code
->expr1
, code
->expr2
, code
->op
);
1633 else if (UNLIMITED_POLY (code
->expr2
)
1634 && code
->expr1
->ts
.type
== BT_DERIVED
1635 && (code
->expr1
->ts
.u
.derived
->attr
.sequence
1636 || code
->expr1
->ts
.u
.derived
->attr
.is_bind_c
))
1638 res
= gfc_trans_class_assign (code
->expr1
, code
->expr2
, code
->op
);
1640 res
= gfc_trans_pointer_assign (code
);
1643 case EXEC_INIT_ASSIGN
:
1644 if (code
->expr1
->ts
.type
== BT_CLASS
)
1645 res
= gfc_trans_class_init_assign (code
);
1647 res
= gfc_trans_init_assign (code
);
1655 res
= gfc_trans_critical (code
);
1659 res
= gfc_trans_cycle (code
);
1663 res
= gfc_trans_exit (code
);
1667 res
= gfc_trans_goto (code
);
1671 res
= gfc_trans_entry (code
);
1675 res
= gfc_trans_pause (code
);
1679 case EXEC_ERROR_STOP
:
1680 res
= gfc_trans_stop (code
, code
->op
== EXEC_ERROR_STOP
);
1684 /* For MVBITS we've got the special exception that we need a
1685 dependency check, too. */
1687 bool is_mvbits
= false;
1689 if (code
->resolved_isym
)
1691 res
= gfc_conv_intrinsic_subroutine (code
);
1692 if (res
!= NULL_TREE
)
1696 if (code
->resolved_isym
1697 && code
->resolved_isym
->id
== GFC_ISYM_MVBITS
)
1700 res
= gfc_trans_call (code
, is_mvbits
, NULL_TREE
,
1706 res
= gfc_trans_call (code
, false, NULL_TREE
,
1710 case EXEC_ASSIGN_CALL
:
1711 res
= gfc_trans_call (code
, true, NULL_TREE
,
1716 res
= gfc_trans_return (code
);
1720 res
= gfc_trans_if (code
);
1723 case EXEC_ARITHMETIC_IF
:
1724 res
= gfc_trans_arithmetic_if (code
);
1728 res
= gfc_trans_block_construct (code
);
1732 res
= gfc_trans_do (code
, cond
);
1735 case EXEC_DO_CONCURRENT
:
1736 res
= gfc_trans_do_concurrent (code
);
1740 res
= gfc_trans_do_while (code
);
1744 res
= gfc_trans_select (code
);
1747 case EXEC_SELECT_TYPE
:
1748 /* Do nothing. SELECT TYPE statements should be transformed into
1749 an ordinary SELECT CASE at resolution stage.
1750 TODO: Add an error message here once this is done. */
1755 res
= gfc_trans_flush (code
);
1759 case EXEC_SYNC_IMAGES
:
1760 case EXEC_SYNC_MEMORY
:
1761 res
= gfc_trans_sync (code
, code
->op
);
1766 res
= gfc_trans_lock_unlock (code
, code
->op
);
1770 res
= gfc_trans_forall (code
);
1774 res
= gfc_trans_where (code
);
1778 res
= gfc_trans_allocate (code
);
1781 case EXEC_DEALLOCATE
:
1782 res
= gfc_trans_deallocate (code
);
1786 res
= gfc_trans_open (code
);
1790 res
= gfc_trans_close (code
);
1794 res
= gfc_trans_read (code
);
1798 res
= gfc_trans_write (code
);
1802 res
= gfc_trans_iolength (code
);
1805 case EXEC_BACKSPACE
:
1806 res
= gfc_trans_backspace (code
);
1810 res
= gfc_trans_endfile (code
);
1814 res
= gfc_trans_inquire (code
);
1818 res
= gfc_trans_wait (code
);
1822 res
= gfc_trans_rewind (code
);
1826 res
= gfc_trans_transfer (code
);
1830 res
= gfc_trans_dt_end (code
);
1833 case EXEC_OMP_ATOMIC
:
1834 case EXEC_OMP_BARRIER
:
1835 case EXEC_OMP_CRITICAL
:
1837 case EXEC_OMP_FLUSH
:
1838 case EXEC_OMP_MASTER
:
1839 case EXEC_OMP_ORDERED
:
1840 case EXEC_OMP_PARALLEL
:
1841 case EXEC_OMP_PARALLEL_DO
:
1842 case EXEC_OMP_PARALLEL_SECTIONS
:
1843 case EXEC_OMP_PARALLEL_WORKSHARE
:
1844 case EXEC_OMP_SECTIONS
:
1845 case EXEC_OMP_SINGLE
:
1847 case EXEC_OMP_TASKWAIT
:
1848 case EXEC_OMP_TASKYIELD
:
1849 case EXEC_OMP_WORKSHARE
:
1850 res
= gfc_trans_omp_directive (code
);
1854 internal_error ("gfc_trans_code(): Bad statement code");
1857 gfc_set_backend_locus (&code
->loc
);
1859 if (res
!= NULL_TREE
&& ! IS_EMPTY_STMT (res
))
1861 if (TREE_CODE (res
) != STATEMENT_LIST
)
1862 SET_EXPR_LOCATION (res
, input_location
);
1864 /* Add the new statement to the block. */
1865 gfc_add_expr_to_block (&block
, res
);
1869 /* Return the finished block. */
1870 return gfc_finish_block (&block
);
1874 /* Translate an executable statement with condition, cond. The condition is
1875 used by gfc_trans_do to test for IO result conditions inside implied
1876 DO loops of READ and WRITE statements. See build_dt in trans-io.c. */
1879 gfc_trans_code_cond (gfc_code
* code
, tree cond
)
1881 return trans_code (code
, cond
);
1884 /* Translate an executable statement without condition. */
1887 gfc_trans_code (gfc_code
* code
)
1889 return trans_code (code
, NULL_TREE
);
1893 /* This function is called after a complete program unit has been parsed
1897 gfc_generate_code (gfc_namespace
* ns
)
1900 if (ns
->is_block_data
)
1902 gfc_generate_block_data (ns
);
1906 gfc_generate_function_code (ns
);
1910 /* This function is called after a complete module has been parsed
1914 gfc_generate_module_code (gfc_namespace
* ns
)
1917 struct module_htab_entry
*entry
;
1919 gcc_assert (ns
->proc_name
->backend_decl
== NULL
);
1920 ns
->proc_name
->backend_decl
1921 = build_decl (ns
->proc_name
->declared_at
.lb
->location
,
1922 NAMESPACE_DECL
, get_identifier (ns
->proc_name
->name
),
1924 entry
= gfc_find_module (ns
->proc_name
->name
);
1925 if (entry
->namespace_decl
)
1926 /* Buggy sourcecode, using a module before defining it? */
1927 htab_empty (entry
->decls
);
1928 entry
->namespace_decl
= ns
->proc_name
->backend_decl
;
1930 gfc_generate_module_vars (ns
);
1932 /* We need to generate all module function prototypes first, to allow
1934 for (n
= ns
->contained
; n
; n
= n
->sibling
)
1941 gfc_create_function_decl (n
, false);
1942 DECL_CONTEXT (n
->proc_name
->backend_decl
) = ns
->proc_name
->backend_decl
;
1943 gfc_module_add_decl (entry
, n
->proc_name
->backend_decl
);
1944 for (el
= ns
->entries
; el
; el
= el
->next
)
1946 DECL_CONTEXT (el
->sym
->backend_decl
) = ns
->proc_name
->backend_decl
;
1947 gfc_module_add_decl (entry
, el
->sym
->backend_decl
);
1951 for (n
= ns
->contained
; n
; n
= n
->sibling
)
1956 gfc_generate_function_code (n
);
1961 /* Initialize an init/cleanup block with existing code. */
1964 gfc_start_wrapped_block (gfc_wrapped_block
* block
, tree code
)
1968 block
->init
= NULL_TREE
;
1970 block
->cleanup
= NULL_TREE
;
1974 /* Add a new pair of initializers/clean-up code. */
1977 gfc_add_init_cleanup (gfc_wrapped_block
* block
, tree init
, tree cleanup
)
1981 /* The new pair of init/cleanup should be "wrapped around" the existing
1982 block of code, thus the initialization is added to the front and the
1983 cleanup to the back. */
1984 add_expr_to_chain (&block
->init
, init
, true);
1985 add_expr_to_chain (&block
->cleanup
, cleanup
, false);
1989 /* Finish up a wrapped block by building a corresponding try-finally expr. */
1992 gfc_finish_wrapped_block (gfc_wrapped_block
* block
)
1998 /* Build the final expression. For this, just add init and body together,
1999 and put clean-up with that into a TRY_FINALLY_EXPR. */
2000 result
= block
->init
;
2001 add_expr_to_chain (&result
, block
->code
, false);
2003 result
= build2_loc (input_location
, TRY_FINALLY_EXPR
, void_type_node
,
2004 result
, block
->cleanup
);
2006 /* Clear the block. */
2007 block
->init
= NULL_TREE
;
2008 block
->code
= NULL_TREE
;
2009 block
->cleanup
= NULL_TREE
;
2015 /* Helper function for marking a boolean expression tree as unlikely. */
2018 gfc_unlikely (tree cond
)
2022 cond
= fold_convert (long_integer_type_node
, cond
);
2023 tmp
= build_zero_cst (long_integer_type_node
);
2024 cond
= build_call_expr_loc (input_location
,
2025 builtin_decl_explicit (BUILT_IN_EXPECT
),
2027 cond
= fold_convert (boolean_type_node
, cond
);
2032 /* Helper function for marking a boolean expression tree as likely. */
2035 gfc_likely (tree cond
)
2039 cond
= fold_convert (long_integer_type_node
, cond
);
2040 tmp
= build_one_cst (long_integer_type_node
);
2041 cond
= build_call_expr_loc (input_location
,
2042 builtin_decl_explicit (BUILT_IN_EXPECT
),
2044 cond
= fold_convert (boolean_type_node
, cond
);