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 "double-int.h"
36 #include "fold-const.h"
37 #include "gimple-expr.h" /* For create_tmp_var_raw. */
38 #include "stringpool.h"
39 #include "tree-iterator.h"
40 #include "diagnostic-core.h" /* For internal_error. */
43 #include "trans-stmt.h"
44 #include "trans-array.h"
45 #include "trans-types.h"
46 #include "trans-const.h"
48 /* Naming convention for backend interface code:
50 gfc_trans_* translate gfc_code into STMT trees.
52 gfc_conv_* expression conversion
54 gfc_get_* get a backend tree representation of a decl or type */
56 static gfc_file
*gfc_current_backend_file
;
58 const char gfc_msg_fault
[] = N_("Array reference out of bounds");
59 const char gfc_msg_wrong_return
[] = N_("Incorrect function return value");
62 /* Advance along TREE_CHAIN n times. */
65 gfc_advance_chain (tree t
, int n
)
69 gcc_assert (t
!= NULL_TREE
);
76 /* Strip off a legitimate source ending from the input
77 string NAME of length LEN. */
80 remove_suffix (char *name
, int len
)
84 for (i
= 2; i
< 8 && len
> i
; i
++)
86 if (name
[len
- i
] == '.')
95 /* Creates a variable declaration with a given TYPE. */
98 gfc_create_var_np (tree type
, const char *prefix
)
102 t
= create_tmp_var_raw (type
, prefix
);
104 /* No warnings for anonymous variables. */
106 TREE_NO_WARNING (t
) = 1;
112 /* Like above, but also adds it to the current scope. */
115 gfc_create_var (tree type
, const char *prefix
)
119 tmp
= gfc_create_var_np (type
, prefix
);
127 /* If the expression is not constant, evaluate it now. We assign the
128 result of the expression to an artificially created variable VAR, and
129 return a pointer to the VAR_DECL node for this variable. */
132 gfc_evaluate_now_loc (location_t loc
, tree expr
, stmtblock_t
* pblock
)
136 if (CONSTANT_CLASS_P (expr
))
139 var
= gfc_create_var (TREE_TYPE (expr
), NULL
);
140 gfc_add_modify_loc (loc
, pblock
, var
, expr
);
147 gfc_evaluate_now (tree expr
, stmtblock_t
* pblock
)
149 return gfc_evaluate_now_loc (input_location
, expr
, pblock
);
153 /* Build a MODIFY_EXPR node and add it to a given statement block PBLOCK.
154 A MODIFY_EXPR is an assignment:
158 gfc_add_modify_loc (location_t loc
, stmtblock_t
* pblock
, tree lhs
, tree rhs
)
162 #ifdef ENABLE_CHECKING
164 t1
= TREE_TYPE (rhs
);
165 t2
= TREE_TYPE (lhs
);
166 /* Make sure that the types of the rhs and the lhs are the same
167 for scalar assignments. We should probably have something
168 similar for aggregates, but right now removing that check just
169 breaks everything. */
171 || AGGREGATE_TYPE_P (TREE_TYPE (lhs
)));
174 tmp
= fold_build2_loc (loc
, MODIFY_EXPR
, void_type_node
, lhs
,
176 gfc_add_expr_to_block (pblock
, tmp
);
181 gfc_add_modify (stmtblock_t
* pblock
, tree lhs
, tree rhs
)
183 gfc_add_modify_loc (input_location
, pblock
, lhs
, rhs
);
187 /* Create a new scope/binding level and initialize a block. Care must be
188 taken when translating expressions as any temporaries will be placed in
189 the innermost scope. */
192 gfc_start_block (stmtblock_t
* block
)
194 /* Start a new binding level. */
196 block
->has_scope
= 1;
198 /* The block is empty. */
199 block
->head
= NULL_TREE
;
203 /* Initialize a block without creating a new scope. */
206 gfc_init_block (stmtblock_t
* block
)
208 block
->head
= NULL_TREE
;
209 block
->has_scope
= 0;
213 /* Sometimes we create a scope but it turns out that we don't actually
214 need it. This function merges the scope of BLOCK with its parent.
215 Only variable decls will be merged, you still need to add the code. */
218 gfc_merge_block_scope (stmtblock_t
* block
)
223 gcc_assert (block
->has_scope
);
224 block
->has_scope
= 0;
226 /* Remember the decls in this scope. */
230 /* Add them to the parent scope. */
231 while (decl
!= NULL_TREE
)
233 next
= DECL_CHAIN (decl
);
234 DECL_CHAIN (decl
) = NULL_TREE
;
242 /* Finish a scope containing a block of statements. */
245 gfc_finish_block (stmtblock_t
* stmtblock
)
251 expr
= stmtblock
->head
;
253 expr
= build_empty_stmt (input_location
);
255 stmtblock
->head
= NULL_TREE
;
257 if (stmtblock
->has_scope
)
263 block
= poplevel (1, 0);
264 expr
= build3_v (BIND_EXPR
, decl
, expr
, block
);
274 /* Build an ADDR_EXPR and cast the result to TYPE. If TYPE is NULL, the
275 natural type is used. */
278 gfc_build_addr_expr (tree type
, tree t
)
280 tree base_type
= TREE_TYPE (t
);
283 if (type
&& POINTER_TYPE_P (type
)
284 && TREE_CODE (base_type
) == ARRAY_TYPE
285 && TYPE_MAIN_VARIANT (TREE_TYPE (type
))
286 == TYPE_MAIN_VARIANT (TREE_TYPE (base_type
)))
288 tree min_val
= size_zero_node
;
289 tree type_domain
= TYPE_DOMAIN (base_type
);
290 if (type_domain
&& TYPE_MIN_VALUE (type_domain
))
291 min_val
= TYPE_MIN_VALUE (type_domain
);
292 t
= fold (build4_loc (input_location
, ARRAY_REF
, TREE_TYPE (type
),
293 t
, min_val
, NULL_TREE
, NULL_TREE
));
297 natural_type
= build_pointer_type (base_type
);
299 if (TREE_CODE (t
) == INDIRECT_REF
)
303 t
= TREE_OPERAND (t
, 0);
304 natural_type
= TREE_TYPE (t
);
308 tree base
= get_base_address (t
);
309 if (base
&& DECL_P (base
))
310 TREE_ADDRESSABLE (base
) = 1;
311 t
= fold_build1_loc (input_location
, ADDR_EXPR
, natural_type
, t
);
314 if (type
&& natural_type
!= type
)
315 t
= convert (type
, t
);
321 /* Build an ARRAY_REF with its natural type. */
324 gfc_build_array_ref (tree base
, tree offset
, tree decl
)
326 tree type
= TREE_TYPE (base
);
330 if (GFC_ARRAY_TYPE_P (type
) && GFC_TYPE_ARRAY_RANK (type
) == 0)
332 gcc_assert (GFC_TYPE_ARRAY_CORANK (type
) > 0);
334 return fold_convert (TYPE_MAIN_VARIANT (type
), base
);
337 /* Scalar coarray, there is nothing to do. */
338 if (TREE_CODE (type
) != ARRAY_TYPE
)
340 gcc_assert (decl
== NULL_TREE
);
341 gcc_assert (integer_zerop (offset
));
345 type
= TREE_TYPE (type
);
348 TREE_ADDRESSABLE (base
) = 1;
350 /* Strip NON_LVALUE_EXPR nodes. */
351 STRIP_TYPE_NOPS (offset
);
353 /* If the array reference is to a pointer, whose target contains a
354 subreference, use the span that is stored with the backend decl
355 and reference the element with pointer arithmetic. */
356 if (decl
&& (TREE_CODE (decl
) == FIELD_DECL
357 || TREE_CODE (decl
) == VAR_DECL
358 || TREE_CODE (decl
) == PARM_DECL
)
359 && ((GFC_DECL_SUBREF_ARRAY_P (decl
)
360 && !integer_zerop (GFC_DECL_SPAN(decl
)))
361 || GFC_DECL_CLASS (decl
)))
363 if (GFC_DECL_CLASS (decl
))
365 /* Allow for dummy arguments and other good things. */
366 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
367 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
369 /* Check if '_data' is an array descriptor. If it is not,
370 the array must be one of the components of the class object,
371 so return a normal array reference. */
372 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_class_data_get (decl
))))
373 return build4_loc (input_location
, ARRAY_REF
, type
, base
,
374 offset
, NULL_TREE
, NULL_TREE
);
376 span
= gfc_class_vtab_size_get (decl
);
378 else if (GFC_DECL_SUBREF_ARRAY_P (decl
))
379 span
= GFC_DECL_SPAN(decl
);
383 offset
= fold_build2_loc (input_location
, MULT_EXPR
,
384 gfc_array_index_type
,
386 tmp
= gfc_build_addr_expr (pvoid_type_node
, base
);
387 tmp
= fold_build_pointer_plus_loc (input_location
, tmp
, offset
);
388 tmp
= fold_convert (build_pointer_type (type
), tmp
);
389 if (!TYPE_STRING_FLAG (type
))
390 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
394 /* Otherwise use a straightforward array reference. */
395 return build4_loc (input_location
, ARRAY_REF
, type
, base
, offset
,
396 NULL_TREE
, NULL_TREE
);
400 /* Generate a call to print a runtime error possibly including multiple
401 arguments and a locus. */
404 trans_runtime_error_vararg (bool error
, locus
* where
, const char* msgid
,
417 /* Compute the number of extra arguments from the format string. */
418 for (p
= msgid
, nargs
= 0; *p
; p
++)
426 /* The code to generate the error. */
427 gfc_start_block (&block
);
431 line
= LOCATION_LINE (where
->lb
->location
);
432 message
= xasprintf ("At line %d of file %s", line
,
433 where
->lb
->file
->filename
);
436 message
= xasprintf ("In file '%s', around line %d",
437 gfc_source_file
, LOCATION_LINE (input_location
) + 1);
439 arg
= gfc_build_addr_expr (pchar_type_node
,
440 gfc_build_localized_cstring_const (message
));
443 message
= xasprintf ("%s", _(msgid
));
444 arg2
= gfc_build_addr_expr (pchar_type_node
,
445 gfc_build_localized_cstring_const (message
));
448 /* Build the argument array. */
449 argarray
= XALLOCAVEC (tree
, nargs
+ 2);
452 for (i
= 0; i
< nargs
; i
++)
453 argarray
[2 + i
] = va_arg (ap
, tree
);
455 /* Build the function call to runtime_(warning,error)_at; because of the
456 variable number of arguments, we can't use build_call_expr_loc dinput_location,
459 fntype
= TREE_TYPE (gfor_fndecl_runtime_error_at
);
461 fntype
= TREE_TYPE (gfor_fndecl_runtime_warning_at
);
463 loc
= where
? where
->lb
->location
: input_location
;
464 tmp
= fold_build_call_array_loc (loc
, TREE_TYPE (fntype
),
465 fold_build1_loc (loc
, ADDR_EXPR
,
466 build_pointer_type (fntype
),
468 ? gfor_fndecl_runtime_error_at
469 : gfor_fndecl_runtime_warning_at
),
470 nargs
+ 2, argarray
);
471 gfc_add_expr_to_block (&block
, tmp
);
473 return gfc_finish_block (&block
);
478 gfc_trans_runtime_error (bool error
, locus
* where
, const char* msgid
, ...)
483 va_start (ap
, msgid
);
484 result
= trans_runtime_error_vararg (error
, where
, msgid
, ap
);
490 /* Generate a runtime error if COND is true. */
493 gfc_trans_runtime_check (bool error
, bool once
, tree cond
, stmtblock_t
* pblock
,
494 locus
* where
, const char * msgid
, ...)
502 if (integer_zerop (cond
))
507 tmpvar
= gfc_create_var (boolean_type_node
, "print_warning");
508 TREE_STATIC (tmpvar
) = 1;
509 DECL_INITIAL (tmpvar
) = boolean_true_node
;
510 gfc_add_expr_to_block (pblock
, tmpvar
);
513 gfc_start_block (&block
);
515 /* For error, runtime_error_at already implies PRED_NORETURN. */
517 gfc_add_expr_to_block (&block
, build_predict_expr (PRED_FORTRAN_WARN_ONCE
,
520 /* The code to generate the error. */
521 va_start (ap
, msgid
);
522 gfc_add_expr_to_block (&block
,
523 trans_runtime_error_vararg (error
, where
,
528 gfc_add_modify (&block
, tmpvar
, boolean_false_node
);
530 body
= gfc_finish_block (&block
);
532 if (integer_onep (cond
))
534 gfc_add_expr_to_block (pblock
, body
);
539 cond
= fold_build2_loc (where
->lb
->location
, TRUTH_AND_EXPR
,
540 long_integer_type_node
, tmpvar
, cond
);
542 cond
= fold_convert (long_integer_type_node
, cond
);
544 tmp
= fold_build3_loc (where
->lb
->location
, COND_EXPR
, void_type_node
,
546 build_empty_stmt (where
->lb
->location
));
547 gfc_add_expr_to_block (pblock
, tmp
);
552 /* Call malloc to allocate size bytes of memory, with special conditions:
553 + if size == 0, return a malloced area of size 1,
554 + if malloc returns NULL, issue a runtime error. */
556 gfc_call_malloc (stmtblock_t
* block
, tree type
, tree size
)
558 tree tmp
, msg
, malloc_result
, null_result
, res
, malloc_tree
;
561 size
= gfc_evaluate_now (size
, block
);
563 if (TREE_TYPE (size
) != TREE_TYPE (size_type_node
))
564 size
= fold_convert (size_type_node
, size
);
566 /* Create a variable to hold the result. */
567 res
= gfc_create_var (prvoid_type_node
, NULL
);
570 gfc_start_block (&block2
);
572 size
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
, size
,
573 build_int_cst (size_type_node
, 1));
575 malloc_tree
= builtin_decl_explicit (BUILT_IN_MALLOC
);
576 gfc_add_modify (&block2
, res
,
577 fold_convert (prvoid_type_node
,
578 build_call_expr_loc (input_location
,
579 malloc_tree
, 1, size
)));
581 /* Optionally check whether malloc was successful. */
582 if (gfc_option
.rtcheck
& GFC_RTCHECK_MEM
)
584 null_result
= fold_build2_loc (input_location
, EQ_EXPR
,
585 boolean_type_node
, res
,
586 build_int_cst (pvoid_type_node
, 0));
587 msg
= gfc_build_addr_expr (pchar_type_node
,
588 gfc_build_localized_cstring_const ("Memory allocation failed"));
589 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
591 build_call_expr_loc (input_location
,
592 gfor_fndecl_os_error
, 1, msg
),
593 build_empty_stmt (input_location
));
594 gfc_add_expr_to_block (&block2
, tmp
);
597 malloc_result
= gfc_finish_block (&block2
);
599 gfc_add_expr_to_block (block
, malloc_result
);
602 res
= fold_convert (type
, res
);
607 /* Allocate memory, using an optional status argument.
609 This function follows the following pseudo-code:
612 allocate (size_t size, integer_type stat)
619 newmem = malloc (MAX (size, 1));
623 *stat = LIBERROR_ALLOCATION;
625 runtime_error ("Allocation would exceed memory limit");
630 gfc_allocate_using_malloc (stmtblock_t
* block
, tree pointer
,
631 tree size
, tree status
)
633 tree tmp
, error_cond
;
634 stmtblock_t on_error
;
635 tree status_type
= status
? TREE_TYPE (status
) : NULL_TREE
;
637 /* Evaluate size only once, and make sure it has the right type. */
638 size
= gfc_evaluate_now (size
, block
);
639 if (TREE_TYPE (size
) != TREE_TYPE (size_type_node
))
640 size
= fold_convert (size_type_node
, size
);
642 /* If successful and stat= is given, set status to 0. */
643 if (status
!= NULL_TREE
)
644 gfc_add_expr_to_block (block
,
645 fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
646 status
, build_int_cst (status_type
, 0)));
648 /* The allocation itself. */
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 /* Evaluate size only once, and make sure it has the right type. */
711 size
= gfc_evaluate_now (size
, block
);
712 if (TREE_TYPE (size
) != TREE_TYPE (size_type_node
))
713 size
= fold_convert (size_type_node
, size
);
715 /* The allocation itself. */
716 if (status
== NULL_TREE
)
717 pstat
= null_pointer_node
;
719 pstat
= gfc_build_addr_expr (NULL_TREE
, status
);
721 if (errmsg
== NULL_TREE
)
723 gcc_assert(errlen
== NULL_TREE
);
724 errmsg
= null_pointer_node
;
725 errlen
= build_int_cst (integer_type_node
, 0);
728 tmp
= build_call_expr_loc (input_location
,
729 gfor_fndecl_caf_register
, 6,
730 fold_build2_loc (input_location
,
731 MAX_EXPR
, size_type_node
, size
,
732 build_int_cst (size_type_node
, 1)),
733 build_int_cst (integer_type_node
,
734 lock_var
? GFC_CAF_LOCK_ALLOC
735 : GFC_CAF_COARRAY_ALLOC
),
736 token
, pstat
, errmsg
, errlen
);
738 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
739 TREE_TYPE (pointer
), pointer
,
740 fold_convert ( TREE_TYPE (pointer
), tmp
));
741 gfc_add_expr_to_block (block
, tmp
);
745 /* Generate code for an ALLOCATE statement when the argument is an
746 allocatable variable. If the variable is currently allocated, it is an
747 error to allocate it again.
749 This function follows the following pseudo-code:
752 allocate_allocatable (void *mem, size_t size, integer_type stat)
755 return allocate (size, stat);
759 stat = LIBERROR_ALLOCATION;
761 runtime_error ("Attempting to allocate already allocated variable");
765 expr must be set to the original expression being allocated for its locus
766 and variable name in case a runtime error has to be printed. */
768 gfc_allocate_allocatable (stmtblock_t
* block
, tree mem
, tree size
, tree token
,
769 tree status
, tree errmsg
, tree errlen
, tree label_finish
,
772 stmtblock_t alloc_block
;
773 tree tmp
, null_mem
, alloc
, error
;
774 tree type
= TREE_TYPE (mem
);
776 if (TREE_TYPE (size
) != TREE_TYPE (size_type_node
))
777 size
= fold_convert (size_type_node
, size
);
779 null_mem
= gfc_unlikely (fold_build2_loc (input_location
, NE_EXPR
,
780 boolean_type_node
, mem
,
781 build_int_cst (type
, 0)),
782 PRED_FORTRAN_FAIL_ALLOC
);
784 /* If mem is NULL, we call gfc_allocate_using_malloc or
785 gfc_allocate_using_lib. */
786 gfc_start_block (&alloc_block
);
788 if (flag_coarray
== GFC_FCOARRAY_LIB
789 && gfc_expr_attr (expr
).codimension
)
792 bool lock_var
= expr
->ts
.type
== BT_DERIVED
793 && expr
->ts
.u
.derived
->from_intmod
794 == INTMOD_ISO_FORTRAN_ENV
795 && expr
->ts
.u
.derived
->intmod_sym_id
796 == ISOFORTRAN_LOCK_TYPE
;
797 /* In the front end, we represent the lock variable as pointer. However,
798 the FE only passes the pointer around and leaves the actual
799 representation to the library. Hence, we have to convert back to the
800 number of elements. */
802 size
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, size_type_node
,
803 size
, TYPE_SIZE_UNIT (ptr_type_node
));
805 gfc_allocate_using_lib (&alloc_block
, mem
, size
, token
, status
,
806 errmsg
, errlen
, lock_var
);
808 if (status
!= NULL_TREE
)
810 TREE_USED (label_finish
) = 1;
811 tmp
= build1_v (GOTO_EXPR
, label_finish
);
812 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
813 status
, build_zero_cst (TREE_TYPE (status
)));
814 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
815 gfc_unlikely (cond
, PRED_FORTRAN_FAIL_ALLOC
),
816 tmp
, build_empty_stmt (input_location
));
817 gfc_add_expr_to_block (&alloc_block
, tmp
);
821 gfc_allocate_using_malloc (&alloc_block
, mem
, size
, status
);
823 alloc
= gfc_finish_block (&alloc_block
);
825 /* If mem is not NULL, we issue a runtime error or set the
831 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
&& expr
->symtree
);
832 varname
= gfc_build_cstring_const (expr
->symtree
->name
);
833 varname
= gfc_build_addr_expr (pchar_type_node
, varname
);
835 error
= gfc_trans_runtime_error (true, &expr
->where
,
836 "Attempting to allocate already"
837 " allocated variable '%s'",
841 error
= gfc_trans_runtime_error (true, NULL
,
842 "Attempting to allocate already allocated"
845 if (status
!= NULL_TREE
)
847 tree status_type
= TREE_TYPE (status
);
849 error
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
850 status
, build_int_cst (status_type
, LIBERROR_ALLOCATION
));
853 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, null_mem
,
855 gfc_add_expr_to_block (block
, tmp
);
859 /* Free a given variable, if it's not NULL. */
861 gfc_call_free (tree var
)
864 tree tmp
, cond
, call
;
866 if (TREE_TYPE (var
) != TREE_TYPE (pvoid_type_node
))
867 var
= fold_convert (pvoid_type_node
, var
);
869 gfc_start_block (&block
);
870 var
= gfc_evaluate_now (var
, &block
);
871 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, var
,
872 build_int_cst (pvoid_type_node
, 0));
873 call
= build_call_expr_loc (input_location
,
874 builtin_decl_explicit (BUILT_IN_FREE
),
876 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, call
,
877 build_empty_stmt (input_location
));
878 gfc_add_expr_to_block (&block
, tmp
);
880 return gfc_finish_block (&block
);
884 /* Build a call to a FINAL procedure, which finalizes "var". */
887 gfc_build_final_call (gfc_typespec ts
, gfc_expr
*final_wrapper
, gfc_expr
*var
,
888 bool fini_coarray
, gfc_expr
*class_size
)
892 tree final_fndecl
, array
, size
, tmp
;
893 symbol_attribute attr
;
895 gcc_assert (final_wrapper
->expr_type
== EXPR_VARIABLE
);
898 gfc_start_block (&block
);
899 gfc_init_se (&se
, NULL
);
900 gfc_conv_expr (&se
, final_wrapper
);
901 final_fndecl
= se
.expr
;
902 if (POINTER_TYPE_P (TREE_TYPE (final_fndecl
)))
903 final_fndecl
= build_fold_indirect_ref_loc (input_location
, final_fndecl
);
905 if (ts
.type
== BT_DERIVED
)
909 gcc_assert (!class_size
);
910 elem_size
= gfc_typenode_for_spec (&ts
);
911 elem_size
= TYPE_SIZE_UNIT (elem_size
);
912 size
= fold_convert (gfc_array_index_type
, elem_size
);
914 gfc_init_se (&se
, NULL
);
918 se
.descriptor_only
= 1;
919 gfc_conv_expr_descriptor (&se
, var
);
924 gfc_conv_expr (&se
, var
);
925 gcc_assert (se
.pre
.head
== NULL_TREE
&& se
.post
.head
== NULL_TREE
);
928 /* No copy back needed, hence set attr's allocatable/pointer
930 gfc_clear_attr (&attr
);
931 gfc_init_se (&se
, NULL
);
932 array
= gfc_conv_scalar_to_descriptor (&se
, array
, attr
);
933 gcc_assert (se
.post
.head
== NULL_TREE
);
938 gfc_expr
*array_expr
;
939 gcc_assert (class_size
);
940 gfc_init_se (&se
, NULL
);
941 gfc_conv_expr (&se
, class_size
);
942 gfc_add_block_to_block (&block
, &se
.pre
);
943 gcc_assert (se
.post
.head
== NULL_TREE
);
946 array_expr
= gfc_copy_expr (var
);
947 gfc_init_se (&se
, NULL
);
949 if (array_expr
->rank
)
951 gfc_add_class_array_ref (array_expr
);
952 se
.descriptor_only
= 1;
953 gfc_conv_expr_descriptor (&se
, array_expr
);
958 gfc_add_data_component (array_expr
);
959 gfc_conv_expr (&se
, array_expr
);
960 gfc_add_block_to_block (&block
, &se
.pre
);
961 gcc_assert (se
.post
.head
== NULL_TREE
);
963 if (TREE_CODE (array
) == ADDR_EXPR
964 && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (array
, 0))))
965 tmp
= TREE_OPERAND (array
, 0);
967 if (!gfc_is_coarray (array_expr
))
969 /* No copy back needed, hence set attr's allocatable/pointer
971 gfc_clear_attr (&attr
);
972 gfc_init_se (&se
, NULL
);
973 array
= gfc_conv_scalar_to_descriptor (&se
, array
, attr
);
975 gcc_assert (se
.post
.head
== NULL_TREE
);
977 gfc_free_expr (array_expr
);
980 if (!POINTER_TYPE_P (TREE_TYPE (array
)))
981 array
= gfc_build_addr_expr (NULL
, array
);
983 gfc_add_block_to_block (&block
, &se
.pre
);
984 tmp
= build_call_expr_loc (input_location
,
985 final_fndecl
, 3, array
,
986 size
, fini_coarray
? boolean_true_node
987 : boolean_false_node
);
988 gfc_add_block_to_block (&block
, &se
.post
);
989 gfc_add_expr_to_block (&block
, tmp
);
990 return gfc_finish_block (&block
);
995 gfc_add_comp_finalizer_call (stmtblock_t
*block
, tree decl
, gfc_component
*comp
,
1000 tree final_fndecl
, size
, array
, tmp
, cond
;
1001 symbol_attribute attr
;
1002 gfc_expr
*final_expr
= NULL
;
1004 if (comp
->ts
.type
!= BT_DERIVED
&& comp
->ts
.type
!= BT_CLASS
)
1007 gfc_init_block (&block2
);
1009 if (comp
->ts
.type
== BT_DERIVED
)
1011 if (comp
->attr
.pointer
)
1014 gfc_is_finalizable (comp
->ts
.u
.derived
, &final_expr
);
1018 gfc_init_se (&se
, NULL
);
1019 gfc_conv_expr (&se
, final_expr
);
1020 final_fndecl
= se
.expr
;
1021 size
= gfc_typenode_for_spec (&comp
->ts
);
1022 size
= TYPE_SIZE_UNIT (size
);
1023 size
= fold_convert (gfc_array_index_type
, size
);
1027 else /* comp->ts.type == BT_CLASS. */
1029 if (CLASS_DATA (comp
)->attr
.class_pointer
)
1032 gfc_is_finalizable (CLASS_DATA (comp
)->ts
.u
.derived
, &final_expr
);
1033 final_fndecl
= gfc_class_vtab_final_get (decl
);
1034 size
= gfc_class_vtab_size_get (decl
);
1035 array
= gfc_class_data_get (decl
);
1038 if (comp
->attr
.allocatable
1039 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)->attr
.allocatable
))
1041 tmp
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array
))
1042 ? gfc_conv_descriptor_data_get (array
) : array
;
1043 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1044 tmp
, fold_convert (TREE_TYPE (tmp
),
1045 null_pointer_node
));
1048 cond
= boolean_true_node
;
1050 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array
)))
1052 gfc_clear_attr (&attr
);
1053 gfc_init_se (&se
, NULL
);
1054 array
= gfc_conv_scalar_to_descriptor (&se
, array
, attr
);
1055 gfc_add_block_to_block (&block2
, &se
.pre
);
1056 gcc_assert (se
.post
.head
== NULL_TREE
);
1059 if (!POINTER_TYPE_P (TREE_TYPE (array
)))
1060 array
= gfc_build_addr_expr (NULL
, array
);
1064 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1066 fold_convert (TREE_TYPE (final_fndecl
),
1067 null_pointer_node
));
1068 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1069 boolean_type_node
, cond
, tmp
);
1072 if (POINTER_TYPE_P (TREE_TYPE (final_fndecl
)))
1073 final_fndecl
= build_fold_indirect_ref_loc (input_location
, final_fndecl
);
1075 tmp
= build_call_expr_loc (input_location
,
1076 final_fndecl
, 3, array
,
1077 size
, fini_coarray
? boolean_true_node
1078 : boolean_false_node
);
1079 gfc_add_expr_to_block (&block2
, tmp
);
1080 tmp
= gfc_finish_block (&block2
);
1082 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
1083 build_empty_stmt (input_location
));
1084 gfc_add_expr_to_block (block
, tmp
);
1090 /* Add a call to the finalizer, using the passed *expr. Returns
1091 true when a finalizer call has been inserted. */
1094 gfc_add_finalizer_call (stmtblock_t
*block
, gfc_expr
*expr2
)
1099 gfc_expr
*final_expr
= NULL
;
1100 gfc_expr
*elem_size
= NULL
;
1101 bool has_finalizer
= false;
1103 if (!expr2
|| (expr2
->ts
.type
!= BT_DERIVED
&& expr2
->ts
.type
!= BT_CLASS
))
1106 if (expr2
->ts
.type
== BT_DERIVED
)
1108 gfc_is_finalizable (expr2
->ts
.u
.derived
, &final_expr
);
1113 /* If we have a class array, we need go back to the class
1115 expr
= gfc_copy_expr (expr2
);
1117 if (expr
->ref
&& expr
->ref
->next
&& !expr
->ref
->next
->next
1118 && expr
->ref
->next
->type
== REF_ARRAY
1119 && expr
->ref
->type
== REF_COMPONENT
1120 && strcmp (expr
->ref
->u
.c
.component
->name
, "_data") == 0)
1122 gfc_free_ref_list (expr
->ref
);
1126 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1127 if (ref
->next
&& ref
->next
->next
&& !ref
->next
->next
->next
1128 && ref
->next
->next
->type
== REF_ARRAY
1129 && ref
->next
->type
== REF_COMPONENT
1130 && strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0)
1132 gfc_free_ref_list (ref
->next
);
1136 if (expr
->ts
.type
== BT_CLASS
)
1138 has_finalizer
= gfc_is_finalizable (expr
->ts
.u
.derived
, NULL
);
1140 if (!expr2
->rank
&& !expr2
->ref
&& CLASS_DATA (expr2
->symtree
->n
.sym
)->as
)
1141 expr
->rank
= CLASS_DATA (expr2
->symtree
->n
.sym
)->as
->rank
;
1143 final_expr
= gfc_copy_expr (expr
);
1144 gfc_add_vptr_component (final_expr
);
1145 gfc_add_component_ref (final_expr
, "_final");
1147 elem_size
= gfc_copy_expr (expr
);
1148 gfc_add_vptr_component (elem_size
);
1149 gfc_add_component_ref (elem_size
, "_size");
1152 gcc_assert (final_expr
->expr_type
== EXPR_VARIABLE
);
1154 tmp
= gfc_build_final_call (expr
->ts
, final_expr
, expr
,
1157 if (expr
->ts
.type
== BT_CLASS
&& !has_finalizer
)
1162 gfc_init_se (&se
, NULL
);
1163 se
.want_pointer
= 1;
1164 gfc_conv_expr (&se
, final_expr
);
1165 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1166 se
.expr
, build_int_cst (TREE_TYPE (se
.expr
), 0));
1168 /* For CLASS(*) not only sym->_vtab->_final can be NULL
1169 but already sym->_vtab itself. */
1170 if (UNLIMITED_POLY (expr
))
1173 gfc_expr
*vptr_expr
;
1175 vptr_expr
= gfc_copy_expr (expr
);
1176 gfc_add_vptr_component (vptr_expr
);
1178 gfc_init_se (&se
, NULL
);
1179 se
.want_pointer
= 1;
1180 gfc_conv_expr (&se
, vptr_expr
);
1181 gfc_free_expr (vptr_expr
);
1183 cond2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1185 build_int_cst (TREE_TYPE (se
.expr
), 0));
1186 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1187 boolean_type_node
, cond2
, cond
);
1190 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1191 cond
, tmp
, build_empty_stmt (input_location
));
1194 gfc_add_expr_to_block (block
, tmp
);
1200 /* User-deallocate; we emit the code directly from the front-end, and the
1201 logic is the same as the previous library function:
1204 deallocate (void *pointer, GFC_INTEGER_4 * stat)
1211 runtime_error ("Attempt to DEALLOCATE unallocated memory.");
1221 In this front-end version, status doesn't have to be GFC_INTEGER_4.
1222 Moreover, if CAN_FAIL is true, then we will not emit a runtime error,
1223 even when no status variable is passed to us (this is used for
1224 unconditional deallocation generated by the front-end at end of
1227 If a runtime-message is possible, `expr' must point to the original
1228 expression being deallocated for its locus and variable name.
1230 For coarrays, "pointer" must be the array descriptor and not its
1231 "data" component. */
1233 gfc_deallocate_with_status (tree pointer
, tree status
, tree errmsg
,
1234 tree errlen
, tree label_finish
,
1235 bool can_fail
, gfc_expr
* expr
, bool coarray
)
1237 stmtblock_t null
, non_null
;
1238 tree cond
, tmp
, error
;
1239 tree status_type
= NULL_TREE
;
1240 tree caf_decl
= NULL_TREE
;
1244 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer
)));
1246 pointer
= gfc_conv_descriptor_data_get (caf_decl
);
1247 STRIP_NOPS (pointer
);
1250 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, pointer
,
1251 build_int_cst (TREE_TYPE (pointer
), 0));
1253 /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
1254 we emit a runtime error. */
1255 gfc_start_block (&null
);
1260 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
&& expr
->symtree
);
1262 varname
= gfc_build_cstring_const (expr
->symtree
->name
);
1263 varname
= gfc_build_addr_expr (pchar_type_node
, varname
);
1265 error
= gfc_trans_runtime_error (true, &expr
->where
,
1266 "Attempt to DEALLOCATE unallocated '%s'",
1270 error
= build_empty_stmt (input_location
);
1272 if (status
!= NULL_TREE
&& !integer_zerop (status
))
1276 status_type
= TREE_TYPE (TREE_TYPE (status
));
1277 cond2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1278 status
, build_int_cst (TREE_TYPE (status
), 0));
1279 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
1280 fold_build1_loc (input_location
, INDIRECT_REF
,
1281 status_type
, status
),
1282 build_int_cst (status_type
, 1));
1283 error
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1287 gfc_add_expr_to_block (&null
, error
);
1289 /* When POINTER is not NULL, we free it. */
1290 gfc_start_block (&non_null
);
1291 gfc_add_finalizer_call (&non_null
, expr
);
1292 if (!coarray
|| flag_coarray
!= GFC_FCOARRAY_LIB
)
1294 tmp
= build_call_expr_loc (input_location
,
1295 builtin_decl_explicit (BUILT_IN_FREE
), 1,
1296 fold_convert (pvoid_type_node
, pointer
));
1297 gfc_add_expr_to_block (&non_null
, tmp
);
1299 if (status
!= NULL_TREE
&& !integer_zerop (status
))
1301 /* We set STATUS to zero if it is present. */
1302 tree status_type
= TREE_TYPE (TREE_TYPE (status
));
1305 cond2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1307 build_int_cst (TREE_TYPE (status
), 0));
1308 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
1309 fold_build1_loc (input_location
, INDIRECT_REF
,
1310 status_type
, status
),
1311 build_int_cst (status_type
, 0));
1312 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1313 gfc_unlikely (cond2
, PRED_FORTRAN_FAIL_ALLOC
),
1314 tmp
, build_empty_stmt (input_location
));
1315 gfc_add_expr_to_block (&non_null
, tmp
);
1320 tree caf_type
, token
, cond2
;
1321 tree pstat
= null_pointer_node
;
1323 if (errmsg
== NULL_TREE
)
1325 gcc_assert (errlen
== NULL_TREE
);
1326 errmsg
= null_pointer_node
;
1327 errlen
= build_zero_cst (integer_type_node
);
1331 gcc_assert (errlen
!= NULL_TREE
);
1332 if (!POINTER_TYPE_P (TREE_TYPE (errmsg
)))
1333 errmsg
= gfc_build_addr_expr (NULL_TREE
, errmsg
);
1336 caf_type
= TREE_TYPE (caf_decl
);
1338 if (status
!= NULL_TREE
&& !integer_zerop (status
))
1340 gcc_assert (status_type
== integer_type_node
);
1344 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
1345 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
1346 token
= gfc_conv_descriptor_token (caf_decl
);
1347 else if (DECL_LANG_SPECIFIC (caf_decl
)
1348 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
1349 token
= GFC_DECL_TOKEN (caf_decl
);
1352 gcc_assert (GFC_ARRAY_TYPE_P (caf_type
)
1353 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) != NULL_TREE
);
1354 token
= GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
);
1357 token
= gfc_build_addr_expr (NULL_TREE
, token
);
1358 tmp
= build_call_expr_loc (input_location
,
1359 gfor_fndecl_caf_deregister
, 4,
1360 token
, pstat
, errmsg
, errlen
);
1361 gfc_add_expr_to_block (&non_null
, tmp
);
1363 if (status
!= NULL_TREE
)
1365 tree stat
= build_fold_indirect_ref_loc (input_location
, status
);
1367 TREE_USED (label_finish
) = 1;
1368 tmp
= build1_v (GOTO_EXPR
, label_finish
);
1369 cond2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1370 stat
, build_zero_cst (TREE_TYPE (stat
)));
1371 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1372 gfc_unlikely (cond2
, PRED_FORTRAN_FAIL_ALLOC
),
1373 tmp
, build_empty_stmt (input_location
));
1374 gfc_add_expr_to_block (&non_null
, tmp
);
1378 return fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
1379 gfc_finish_block (&null
),
1380 gfc_finish_block (&non_null
));
1384 /* Generate code for deallocation of allocatable scalars (variables or
1385 components). Before the object itself is freed, any allocatable
1386 subcomponents are being deallocated. */
1389 gfc_deallocate_scalar_with_status (tree pointer
, tree status
, bool can_fail
,
1390 gfc_expr
* expr
, gfc_typespec ts
)
1392 stmtblock_t null
, non_null
;
1393 tree cond
, tmp
, error
;
1396 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, pointer
,
1397 build_int_cst (TREE_TYPE (pointer
), 0));
1399 /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
1400 we emit a runtime error. */
1401 gfc_start_block (&null
);
1406 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
&& expr
->symtree
);
1408 varname
= gfc_build_cstring_const (expr
->symtree
->name
);
1409 varname
= gfc_build_addr_expr (pchar_type_node
, varname
);
1411 error
= gfc_trans_runtime_error (true, &expr
->where
,
1412 "Attempt to DEALLOCATE unallocated '%s'",
1416 error
= build_empty_stmt (input_location
);
1418 if (status
!= NULL_TREE
&& !integer_zerop (status
))
1420 tree status_type
= TREE_TYPE (TREE_TYPE (status
));
1423 cond2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1424 status
, build_int_cst (TREE_TYPE (status
), 0));
1425 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
1426 fold_build1_loc (input_location
, INDIRECT_REF
,
1427 status_type
, status
),
1428 build_int_cst (status_type
, 1));
1429 error
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1433 gfc_add_expr_to_block (&null
, error
);
1435 /* When POINTER is not NULL, we free it. */
1436 gfc_start_block (&non_null
);
1438 /* Free allocatable components. */
1439 finalizable
= gfc_add_finalizer_call (&non_null
, expr
);
1440 if (!finalizable
&& ts
.type
== BT_DERIVED
&& ts
.u
.derived
->attr
.alloc_comp
)
1442 tmp
= build_fold_indirect_ref_loc (input_location
, pointer
);
1443 tmp
= gfc_deallocate_alloc_comp (ts
.u
.derived
, tmp
, 0);
1444 gfc_add_expr_to_block (&non_null
, tmp
);
1447 tmp
= build_call_expr_loc (input_location
,
1448 builtin_decl_explicit (BUILT_IN_FREE
), 1,
1449 fold_convert (pvoid_type_node
, pointer
));
1450 gfc_add_expr_to_block (&non_null
, tmp
);
1452 if (status
!= NULL_TREE
&& !integer_zerop (status
))
1454 /* We set STATUS to zero if it is present. */
1455 tree status_type
= TREE_TYPE (TREE_TYPE (status
));
1458 cond2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1459 status
, build_int_cst (TREE_TYPE (status
), 0));
1460 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
1461 fold_build1_loc (input_location
, INDIRECT_REF
,
1462 status_type
, status
),
1463 build_int_cst (status_type
, 0));
1464 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
1465 tmp
, build_empty_stmt (input_location
));
1466 gfc_add_expr_to_block (&non_null
, tmp
);
1469 return fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
1470 gfc_finish_block (&null
),
1471 gfc_finish_block (&non_null
));
1475 /* Reallocate MEM so it has SIZE bytes of data. This behaves like the
1476 following pseudo-code:
1479 internal_realloc (void *mem, size_t size)
1481 res = realloc (mem, size);
1482 if (!res && size != 0)
1483 _gfortran_os_error ("Allocation would exceed memory limit");
1488 gfc_call_realloc (stmtblock_t
* block
, tree mem
, tree size
)
1490 tree msg
, res
, nonzero
, null_result
, tmp
;
1491 tree type
= TREE_TYPE (mem
);
1493 size
= gfc_evaluate_now (size
, block
);
1495 if (TREE_TYPE (size
) != TREE_TYPE (size_type_node
))
1496 size
= fold_convert (size_type_node
, size
);
1498 /* Create a variable to hold the result. */
1499 res
= gfc_create_var (type
, NULL
);
1501 /* Call realloc and check the result. */
1502 tmp
= build_call_expr_loc (input_location
,
1503 builtin_decl_explicit (BUILT_IN_REALLOC
), 2,
1504 fold_convert (pvoid_type_node
, mem
), size
);
1505 gfc_add_modify (block
, res
, fold_convert (type
, tmp
));
1506 null_result
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1507 res
, build_int_cst (pvoid_type_node
, 0));
1508 nonzero
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, size
,
1509 build_int_cst (size_type_node
, 0));
1510 null_result
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, boolean_type_node
,
1511 null_result
, nonzero
);
1512 msg
= gfc_build_addr_expr (pchar_type_node
, gfc_build_localized_cstring_const
1513 ("Allocation would exceed memory limit"));
1514 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1516 build_call_expr_loc (input_location
,
1517 gfor_fndecl_os_error
, 1, msg
),
1518 build_empty_stmt (input_location
));
1519 gfc_add_expr_to_block (block
, tmp
);
1525 /* Add an expression to another one, either at the front or the back. */
1528 add_expr_to_chain (tree
* chain
, tree expr
, bool front
)
1530 if (expr
== NULL_TREE
|| IS_EMPTY_STMT (expr
))
1535 if (TREE_CODE (*chain
) != STATEMENT_LIST
)
1541 append_to_statement_list (tmp
, chain
);
1546 tree_stmt_iterator i
;
1548 i
= tsi_start (*chain
);
1549 tsi_link_before (&i
, expr
, TSI_CONTINUE_LINKING
);
1552 append_to_statement_list (expr
, chain
);
1559 /* Add a statement at the end of a block. */
1562 gfc_add_expr_to_block (stmtblock_t
* block
, tree expr
)
1565 add_expr_to_chain (&block
->head
, expr
, false);
1569 /* Add a statement at the beginning of a block. */
1572 gfc_prepend_expr_to_block (stmtblock_t
* block
, tree expr
)
1575 add_expr_to_chain (&block
->head
, expr
, true);
1579 /* Add a block the end of a block. */
1582 gfc_add_block_to_block (stmtblock_t
* block
, stmtblock_t
* append
)
1584 gcc_assert (append
);
1585 gcc_assert (!append
->has_scope
);
1587 gfc_add_expr_to_block (block
, append
->head
);
1588 append
->head
= NULL_TREE
;
1592 /* Save the current locus. The structure may not be complete, and should
1593 only be used with gfc_restore_backend_locus. */
1596 gfc_save_backend_locus (locus
* loc
)
1598 loc
->lb
= XCNEW (gfc_linebuf
);
1599 loc
->lb
->location
= input_location
;
1600 loc
->lb
->file
= gfc_current_backend_file
;
1604 /* Set the current locus. */
1607 gfc_set_backend_locus (locus
* loc
)
1609 gfc_current_backend_file
= loc
->lb
->file
;
1610 input_location
= loc
->lb
->location
;
1614 /* Restore the saved locus. Only used in conjunction with
1615 gfc_save_backend_locus, to free the memory when we are done. */
1618 gfc_restore_backend_locus (locus
* loc
)
1620 gfc_set_backend_locus (loc
);
1625 /* Translate an executable statement. The tree cond is used by gfc_trans_do.
1626 This static function is wrapped by gfc_trans_code_cond and
1630 trans_code (gfc_code
* code
, tree cond
)
1636 return build_empty_stmt (input_location
);
1638 gfc_start_block (&block
);
1640 /* Translate statements one by one into GENERIC trees until we reach
1641 the end of this gfc_code branch. */
1642 for (; code
; code
= code
->next
)
1644 if (code
->here
!= 0)
1646 res
= gfc_trans_label_here (code
);
1647 gfc_add_expr_to_block (&block
, res
);
1650 gfc_set_backend_locus (&code
->loc
);
1655 case EXEC_END_BLOCK
:
1656 case EXEC_END_NESTED_BLOCK
:
1657 case EXEC_END_PROCEDURE
:
1662 if (code
->expr1
->ts
.type
== BT_CLASS
)
1663 res
= gfc_trans_class_assign (code
->expr1
, code
->expr2
, code
->op
);
1665 res
= gfc_trans_assign (code
);
1668 case EXEC_LABEL_ASSIGN
:
1669 res
= gfc_trans_label_assign (code
);
1672 case EXEC_POINTER_ASSIGN
:
1673 if (code
->expr1
->ts
.type
== BT_CLASS
)
1674 res
= gfc_trans_class_assign (code
->expr1
, code
->expr2
, code
->op
);
1675 else if (UNLIMITED_POLY (code
->expr2
)
1676 && code
->expr1
->ts
.type
== BT_DERIVED
1677 && (code
->expr1
->ts
.u
.derived
->attr
.sequence
1678 || code
->expr1
->ts
.u
.derived
->attr
.is_bind_c
))
1680 res
= gfc_trans_class_assign (code
->expr1
, code
->expr2
, code
->op
);
1682 res
= gfc_trans_pointer_assign (code
);
1685 case EXEC_INIT_ASSIGN
:
1686 if (code
->expr1
->ts
.type
== BT_CLASS
)
1687 res
= gfc_trans_class_init_assign (code
);
1689 res
= gfc_trans_init_assign (code
);
1697 res
= gfc_trans_critical (code
);
1701 res
= gfc_trans_cycle (code
);
1705 res
= gfc_trans_exit (code
);
1709 res
= gfc_trans_goto (code
);
1713 res
= gfc_trans_entry (code
);
1717 res
= gfc_trans_pause (code
);
1721 case EXEC_ERROR_STOP
:
1722 res
= gfc_trans_stop (code
, code
->op
== EXEC_ERROR_STOP
);
1726 /* For MVBITS we've got the special exception that we need a
1727 dependency check, too. */
1729 bool is_mvbits
= false;
1731 if (code
->resolved_isym
)
1733 res
= gfc_conv_intrinsic_subroutine (code
);
1734 if (res
!= NULL_TREE
)
1738 if (code
->resolved_isym
1739 && code
->resolved_isym
->id
== GFC_ISYM_MVBITS
)
1742 res
= gfc_trans_call (code
, is_mvbits
, NULL_TREE
,
1748 res
= gfc_trans_call (code
, false, NULL_TREE
,
1752 case EXEC_ASSIGN_CALL
:
1753 res
= gfc_trans_call (code
, true, NULL_TREE
,
1758 res
= gfc_trans_return (code
);
1762 res
= gfc_trans_if (code
);
1765 case EXEC_ARITHMETIC_IF
:
1766 res
= gfc_trans_arithmetic_if (code
);
1770 res
= gfc_trans_block_construct (code
);
1774 res
= gfc_trans_do (code
, cond
);
1777 case EXEC_DO_CONCURRENT
:
1778 res
= gfc_trans_do_concurrent (code
);
1782 res
= gfc_trans_do_while (code
);
1786 res
= gfc_trans_select (code
);
1789 case EXEC_SELECT_TYPE
:
1790 /* Do nothing. SELECT TYPE statements should be transformed into
1791 an ordinary SELECT CASE at resolution stage.
1792 TODO: Add an error message here once this is done. */
1797 res
= gfc_trans_flush (code
);
1801 case EXEC_SYNC_IMAGES
:
1802 case EXEC_SYNC_MEMORY
:
1803 res
= gfc_trans_sync (code
, code
->op
);
1808 res
= gfc_trans_lock_unlock (code
, code
->op
);
1812 res
= gfc_trans_forall (code
);
1816 res
= gfc_trans_where (code
);
1820 res
= gfc_trans_allocate (code
);
1823 case EXEC_DEALLOCATE
:
1824 res
= gfc_trans_deallocate (code
);
1828 res
= gfc_trans_open (code
);
1832 res
= gfc_trans_close (code
);
1836 res
= gfc_trans_read (code
);
1840 res
= gfc_trans_write (code
);
1844 res
= gfc_trans_iolength (code
);
1847 case EXEC_BACKSPACE
:
1848 res
= gfc_trans_backspace (code
);
1852 res
= gfc_trans_endfile (code
);
1856 res
= gfc_trans_inquire (code
);
1860 res
= gfc_trans_wait (code
);
1864 res
= gfc_trans_rewind (code
);
1868 res
= gfc_trans_transfer (code
);
1872 res
= gfc_trans_dt_end (code
);
1875 case EXEC_OMP_ATOMIC
:
1876 case EXEC_OMP_BARRIER
:
1877 case EXEC_OMP_CANCEL
:
1878 case EXEC_OMP_CANCELLATION_POINT
:
1879 case EXEC_OMP_CRITICAL
:
1880 case EXEC_OMP_DISTRIBUTE
:
1881 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
1882 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
1883 case EXEC_OMP_DISTRIBUTE_SIMD
:
1885 case EXEC_OMP_DO_SIMD
:
1886 case EXEC_OMP_FLUSH
:
1887 case EXEC_OMP_MASTER
:
1888 case EXEC_OMP_ORDERED
:
1889 case EXEC_OMP_PARALLEL
:
1890 case EXEC_OMP_PARALLEL_DO
:
1891 case EXEC_OMP_PARALLEL_DO_SIMD
:
1892 case EXEC_OMP_PARALLEL_SECTIONS
:
1893 case EXEC_OMP_PARALLEL_WORKSHARE
:
1894 case EXEC_OMP_SECTIONS
:
1896 case EXEC_OMP_SINGLE
:
1897 case EXEC_OMP_TARGET
:
1898 case EXEC_OMP_TARGET_DATA
:
1899 case EXEC_OMP_TARGET_TEAMS
:
1900 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
1901 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
1902 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
1903 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
1904 case EXEC_OMP_TARGET_UPDATE
:
1906 case EXEC_OMP_TASKGROUP
:
1907 case EXEC_OMP_TASKWAIT
:
1908 case EXEC_OMP_TASKYIELD
:
1909 case EXEC_OMP_TEAMS
:
1910 case EXEC_OMP_TEAMS_DISTRIBUTE
:
1911 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
1912 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
1913 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
1914 case EXEC_OMP_WORKSHARE
:
1915 res
= gfc_trans_omp_directive (code
);
1918 case EXEC_OACC_CACHE
:
1919 case EXEC_OACC_WAIT
:
1920 case EXEC_OACC_UPDATE
:
1921 case EXEC_OACC_LOOP
:
1922 case EXEC_OACC_HOST_DATA
:
1923 case EXEC_OACC_DATA
:
1924 case EXEC_OACC_KERNELS
:
1925 case EXEC_OACC_KERNELS_LOOP
:
1926 case EXEC_OACC_PARALLEL
:
1927 case EXEC_OACC_PARALLEL_LOOP
:
1928 case EXEC_OACC_ENTER_DATA
:
1929 case EXEC_OACC_EXIT_DATA
:
1930 res
= gfc_trans_oacc_directive (code
);
1934 gfc_internal_error ("gfc_trans_code(): Bad statement code");
1937 gfc_set_backend_locus (&code
->loc
);
1939 if (res
!= NULL_TREE
&& ! IS_EMPTY_STMT (res
))
1941 if (TREE_CODE (res
) != STATEMENT_LIST
)
1942 SET_EXPR_LOCATION (res
, input_location
);
1944 /* Add the new statement to the block. */
1945 gfc_add_expr_to_block (&block
, res
);
1949 /* Return the finished block. */
1950 return gfc_finish_block (&block
);
1954 /* Translate an executable statement with condition, cond. The condition is
1955 used by gfc_trans_do to test for IO result conditions inside implied
1956 DO loops of READ and WRITE statements. See build_dt in trans-io.c. */
1959 gfc_trans_code_cond (gfc_code
* code
, tree cond
)
1961 return trans_code (code
, cond
);
1964 /* Translate an executable statement without condition. */
1967 gfc_trans_code (gfc_code
* code
)
1969 return trans_code (code
, NULL_TREE
);
1973 /* This function is called after a complete program unit has been parsed
1977 gfc_generate_code (gfc_namespace
* ns
)
1980 if (ns
->is_block_data
)
1982 gfc_generate_block_data (ns
);
1986 gfc_generate_function_code (ns
);
1990 /* This function is called after a complete module has been parsed
1994 gfc_generate_module_code (gfc_namespace
* ns
)
1997 struct module_htab_entry
*entry
;
1999 gcc_assert (ns
->proc_name
->backend_decl
== NULL
);
2000 ns
->proc_name
->backend_decl
2001 = build_decl (ns
->proc_name
->declared_at
.lb
->location
,
2002 NAMESPACE_DECL
, get_identifier (ns
->proc_name
->name
),
2004 entry
= gfc_find_module (ns
->proc_name
->name
);
2005 if (entry
->namespace_decl
)
2006 /* Buggy sourcecode, using a module before defining it? */
2007 entry
->decls
->empty ();
2008 entry
->namespace_decl
= ns
->proc_name
->backend_decl
;
2010 gfc_generate_module_vars (ns
);
2012 /* We need to generate all module function prototypes first, to allow
2014 for (n
= ns
->contained
; n
; n
= n
->sibling
)
2021 gfc_create_function_decl (n
, false);
2022 DECL_CONTEXT (n
->proc_name
->backend_decl
) = ns
->proc_name
->backend_decl
;
2023 gfc_module_add_decl (entry
, n
->proc_name
->backend_decl
);
2024 for (el
= ns
->entries
; el
; el
= el
->next
)
2026 DECL_CONTEXT (el
->sym
->backend_decl
) = ns
->proc_name
->backend_decl
;
2027 gfc_module_add_decl (entry
, el
->sym
->backend_decl
);
2031 for (n
= ns
->contained
; n
; n
= n
->sibling
)
2036 gfc_generate_function_code (n
);
2041 /* Initialize an init/cleanup block with existing code. */
2044 gfc_start_wrapped_block (gfc_wrapped_block
* block
, tree code
)
2048 block
->init
= NULL_TREE
;
2050 block
->cleanup
= NULL_TREE
;
2054 /* Add a new pair of initializers/clean-up code. */
2057 gfc_add_init_cleanup (gfc_wrapped_block
* block
, tree init
, tree cleanup
)
2061 /* The new pair of init/cleanup should be "wrapped around" the existing
2062 block of code, thus the initialization is added to the front and the
2063 cleanup to the back. */
2064 add_expr_to_chain (&block
->init
, init
, true);
2065 add_expr_to_chain (&block
->cleanup
, cleanup
, false);
2069 /* Finish up a wrapped block by building a corresponding try-finally expr. */
2072 gfc_finish_wrapped_block (gfc_wrapped_block
* block
)
2078 /* Build the final expression. For this, just add init and body together,
2079 and put clean-up with that into a TRY_FINALLY_EXPR. */
2080 result
= block
->init
;
2081 add_expr_to_chain (&result
, block
->code
, false);
2083 result
= build2_loc (input_location
, TRY_FINALLY_EXPR
, void_type_node
,
2084 result
, block
->cleanup
);
2086 /* Clear the block. */
2087 block
->init
= NULL_TREE
;
2088 block
->code
= NULL_TREE
;
2089 block
->cleanup
= NULL_TREE
;
2095 /* Helper function for marking a boolean expression tree as unlikely. */
2098 gfc_unlikely (tree cond
, enum br_predictor predictor
)
2104 cond
= fold_convert (long_integer_type_node
, cond
);
2105 tmp
= build_zero_cst (long_integer_type_node
);
2106 cond
= build_call_expr_loc (input_location
,
2107 builtin_decl_explicit (BUILT_IN_EXPECT
),
2109 build_int_cst (integer_type_node
,
2112 cond
= fold_convert (boolean_type_node
, cond
);
2117 /* Helper function for marking a boolean expression tree as likely. */
2120 gfc_likely (tree cond
, enum br_predictor predictor
)
2126 cond
= fold_convert (long_integer_type_node
, cond
);
2127 tmp
= build_one_cst (long_integer_type_node
);
2128 cond
= build_call_expr_loc (input_location
,
2129 builtin_decl_explicit (BUILT_IN_EXPECT
),
2131 build_int_cst (integer_type_node
,
2134 cond
= fold_convert (boolean_type_node
, cond
);
2139 /* Get the string length for a deferred character length component. */
2142 gfc_deferred_strlen (gfc_component
*c
, tree
*decl
)
2144 char name
[GFC_MAX_SYMBOL_LEN
+9];
2145 gfc_component
*strlen
;
2146 if (!(c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
))
2148 sprintf (name
, "_%s_length", c
->name
);
2149 for (strlen
= c
; strlen
; strlen
= strlen
->next
)
2150 if (strcmp (strlen
->name
, name
) == 0)
2152 *decl
= strlen
? strlen
->backend_decl
: NULL_TREE
;
2153 return strlen
!= NULL
;