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"
29 #include "fold-const.h"
30 #include "gimple-expr.h" /* For create_tmp_var_raw. */
31 #include "stringpool.h"
32 #include "tree-iterator.h"
33 #include "diagnostic-core.h" /* For internal_error. */
36 #include "trans-stmt.h"
37 #include "trans-array.h"
38 #include "trans-types.h"
39 #include "trans-const.h"
41 /* Naming convention for backend interface code:
43 gfc_trans_* translate gfc_code into STMT trees.
45 gfc_conv_* expression conversion
47 gfc_get_* get a backend tree representation of a decl or type */
49 static gfc_file
*gfc_current_backend_file
;
51 const char gfc_msg_fault
[] = N_("Array reference out of bounds");
52 const char gfc_msg_wrong_return
[] = N_("Incorrect function return value");
55 /* Advance along TREE_CHAIN n times. */
58 gfc_advance_chain (tree t
, int n
)
62 gcc_assert (t
!= NULL_TREE
);
69 /* Strip off a legitimate source ending from the input
70 string NAME of length LEN. */
73 remove_suffix (char *name
, int len
)
77 for (i
= 2; i
< 8 && len
> i
; i
++)
79 if (name
[len
- i
] == '.')
88 /* Creates a variable declaration with a given TYPE. */
91 gfc_create_var_np (tree type
, const char *prefix
)
95 t
= create_tmp_var_raw (type
, prefix
);
97 /* No warnings for anonymous variables. */
99 TREE_NO_WARNING (t
) = 1;
105 /* Like above, but also adds it to the current scope. */
108 gfc_create_var (tree type
, const char *prefix
)
112 tmp
= gfc_create_var_np (type
, prefix
);
120 /* If the expression is not constant, evaluate it now. We assign the
121 result of the expression to an artificially created variable VAR, and
122 return a pointer to the VAR_DECL node for this variable. */
125 gfc_evaluate_now_loc (location_t loc
, tree expr
, stmtblock_t
* pblock
)
129 if (CONSTANT_CLASS_P (expr
))
132 var
= gfc_create_var (TREE_TYPE (expr
), NULL
);
133 gfc_add_modify_loc (loc
, pblock
, var
, expr
);
140 gfc_evaluate_now (tree expr
, stmtblock_t
* pblock
)
142 return gfc_evaluate_now_loc (input_location
, expr
, pblock
);
146 /* Build a MODIFY_EXPR node and add it to a given statement block PBLOCK.
147 A MODIFY_EXPR is an assignment:
151 gfc_add_modify_loc (location_t loc
, stmtblock_t
* pblock
, tree lhs
, tree rhs
)
155 #ifdef ENABLE_CHECKING
157 t1
= TREE_TYPE (rhs
);
158 t2
= TREE_TYPE (lhs
);
159 /* Make sure that the types of the rhs and the lhs are the same
160 for scalar assignments. We should probably have something
161 similar for aggregates, but right now removing that check just
162 breaks everything. */
164 || AGGREGATE_TYPE_P (TREE_TYPE (lhs
)));
167 tmp
= fold_build2_loc (loc
, MODIFY_EXPR
, void_type_node
, lhs
,
169 gfc_add_expr_to_block (pblock
, tmp
);
174 gfc_add_modify (stmtblock_t
* pblock
, tree lhs
, tree rhs
)
176 gfc_add_modify_loc (input_location
, pblock
, lhs
, rhs
);
180 /* Create a new scope/binding level and initialize a block. Care must be
181 taken when translating expressions as any temporaries will be placed in
182 the innermost scope. */
185 gfc_start_block (stmtblock_t
* block
)
187 /* Start a new binding level. */
189 block
->has_scope
= 1;
191 /* The block is empty. */
192 block
->head
= NULL_TREE
;
196 /* Initialize a block without creating a new scope. */
199 gfc_init_block (stmtblock_t
* block
)
201 block
->head
= NULL_TREE
;
202 block
->has_scope
= 0;
206 /* Sometimes we create a scope but it turns out that we don't actually
207 need it. This function merges the scope of BLOCK with its parent.
208 Only variable decls will be merged, you still need to add the code. */
211 gfc_merge_block_scope (stmtblock_t
* block
)
216 gcc_assert (block
->has_scope
);
217 block
->has_scope
= 0;
219 /* Remember the decls in this scope. */
223 /* Add them to the parent scope. */
224 while (decl
!= NULL_TREE
)
226 next
= DECL_CHAIN (decl
);
227 DECL_CHAIN (decl
) = NULL_TREE
;
235 /* Finish a scope containing a block of statements. */
238 gfc_finish_block (stmtblock_t
* stmtblock
)
244 expr
= stmtblock
->head
;
246 expr
= build_empty_stmt (input_location
);
248 stmtblock
->head
= NULL_TREE
;
250 if (stmtblock
->has_scope
)
256 block
= poplevel (1, 0);
257 expr
= build3_v (BIND_EXPR
, decl
, expr
, block
);
267 /* Build an ADDR_EXPR and cast the result to TYPE. If TYPE is NULL, the
268 natural type is used. */
271 gfc_build_addr_expr (tree type
, tree t
)
273 tree base_type
= TREE_TYPE (t
);
276 if (type
&& POINTER_TYPE_P (type
)
277 && TREE_CODE (base_type
) == ARRAY_TYPE
278 && TYPE_MAIN_VARIANT (TREE_TYPE (type
))
279 == TYPE_MAIN_VARIANT (TREE_TYPE (base_type
)))
281 tree min_val
= size_zero_node
;
282 tree type_domain
= TYPE_DOMAIN (base_type
);
283 if (type_domain
&& TYPE_MIN_VALUE (type_domain
))
284 min_val
= TYPE_MIN_VALUE (type_domain
);
285 t
= fold (build4_loc (input_location
, ARRAY_REF
, TREE_TYPE (type
),
286 t
, min_val
, NULL_TREE
, NULL_TREE
));
290 natural_type
= build_pointer_type (base_type
);
292 if (TREE_CODE (t
) == INDIRECT_REF
)
296 t
= TREE_OPERAND (t
, 0);
297 natural_type
= TREE_TYPE (t
);
301 tree base
= get_base_address (t
);
302 if (base
&& DECL_P (base
))
303 TREE_ADDRESSABLE (base
) = 1;
304 t
= fold_build1_loc (input_location
, ADDR_EXPR
, natural_type
, t
);
307 if (type
&& natural_type
!= type
)
308 t
= convert (type
, t
);
314 /* Build an ARRAY_REF with its natural type. */
317 gfc_build_array_ref (tree base
, tree offset
, tree decl
, tree vptr
)
319 tree type
= TREE_TYPE (base
);
323 if (GFC_ARRAY_TYPE_P (type
) && GFC_TYPE_ARRAY_RANK (type
) == 0)
325 gcc_assert (GFC_TYPE_ARRAY_CORANK (type
) > 0);
327 return fold_convert (TYPE_MAIN_VARIANT (type
), base
);
330 /* Scalar coarray, there is nothing to do. */
331 if (TREE_CODE (type
) != ARRAY_TYPE
)
333 gcc_assert (decl
== NULL_TREE
);
334 gcc_assert (integer_zerop (offset
));
338 type
= TREE_TYPE (type
);
341 TREE_ADDRESSABLE (base
) = 1;
343 /* Strip NON_LVALUE_EXPR nodes. */
344 STRIP_TYPE_NOPS (offset
);
346 /* If the array reference is to a pointer, whose target contains a
347 subreference, use the span that is stored with the backend decl
348 and reference the element with pointer arithmetic. */
349 if ((decl
&& (TREE_CODE (decl
) == FIELD_DECL
350 || TREE_CODE (decl
) == VAR_DECL
351 || TREE_CODE (decl
) == PARM_DECL
)
352 && ((GFC_DECL_SUBREF_ARRAY_P (decl
)
353 && !integer_zerop (GFC_DECL_SPAN (decl
)))
354 || GFC_DECL_CLASS (decl
)))
359 if (GFC_DECL_CLASS (decl
))
361 /* When a temporary is in place for the class array, then the
362 original class' declaration is stored in the saved
364 if (DECL_LANG_SPECIFIC (decl
) && GFC_DECL_SAVED_DESCRIPTOR (decl
))
365 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
368 /* Allow for dummy arguments and other good things. */
369 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
370 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
372 /* Check if '_data' is an array descriptor. If it is not,
373 the array must be one of the components of the class
374 object, so return a normal array reference. */
375 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (
376 gfc_class_data_get (decl
))))
377 return build4_loc (input_location
, ARRAY_REF
, type
, base
,
378 offset
, NULL_TREE
, NULL_TREE
);
381 span
= gfc_class_vtab_size_get (decl
);
383 else if (GFC_DECL_SUBREF_ARRAY_P (decl
))
384 span
= GFC_DECL_SPAN (decl
);
389 span
= gfc_vptr_size_get (vptr
);
393 offset
= fold_build2_loc (input_location
, MULT_EXPR
,
394 gfc_array_index_type
,
396 tmp
= gfc_build_addr_expr (pvoid_type_node
, base
);
397 tmp
= fold_build_pointer_plus_loc (input_location
, tmp
, offset
);
398 tmp
= fold_convert (build_pointer_type (type
), tmp
);
399 if (!TYPE_STRING_FLAG (type
))
400 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
404 /* Otherwise use a straightforward array reference. */
405 return build4_loc (input_location
, ARRAY_REF
, type
, base
, offset
,
406 NULL_TREE
, NULL_TREE
);
410 /* Generate a call to print a runtime error possibly including multiple
411 arguments and a locus. */
414 trans_runtime_error_vararg (bool error
, locus
* where
, const char* msgid
,
427 /* Compute the number of extra arguments from the format string. */
428 for (p
= msgid
, nargs
= 0; *p
; p
++)
436 /* The code to generate the error. */
437 gfc_start_block (&block
);
441 line
= LOCATION_LINE (where
->lb
->location
);
442 message
= xasprintf ("At line %d of file %s", line
,
443 where
->lb
->file
->filename
);
446 message
= xasprintf ("In file '%s', around line %d",
447 gfc_source_file
, LOCATION_LINE (input_location
) + 1);
449 arg
= gfc_build_addr_expr (pchar_type_node
,
450 gfc_build_localized_cstring_const (message
));
453 message
= xasprintf ("%s", _(msgid
));
454 arg2
= gfc_build_addr_expr (pchar_type_node
,
455 gfc_build_localized_cstring_const (message
));
458 /* Build the argument array. */
459 argarray
= XALLOCAVEC (tree
, nargs
+ 2);
462 for (i
= 0; i
< nargs
; i
++)
463 argarray
[2 + i
] = va_arg (ap
, tree
);
465 /* Build the function call to runtime_(warning,error)_at; because of the
466 variable number of arguments, we can't use build_call_expr_loc dinput_location,
469 fntype
= TREE_TYPE (gfor_fndecl_runtime_error_at
);
471 fntype
= TREE_TYPE (gfor_fndecl_runtime_warning_at
);
473 loc
= where
? where
->lb
->location
: input_location
;
474 tmp
= fold_build_call_array_loc (loc
, TREE_TYPE (fntype
),
475 fold_build1_loc (loc
, ADDR_EXPR
,
476 build_pointer_type (fntype
),
478 ? gfor_fndecl_runtime_error_at
479 : gfor_fndecl_runtime_warning_at
),
480 nargs
+ 2, argarray
);
481 gfc_add_expr_to_block (&block
, tmp
);
483 return gfc_finish_block (&block
);
488 gfc_trans_runtime_error (bool error
, locus
* where
, const char* msgid
, ...)
493 va_start (ap
, msgid
);
494 result
= trans_runtime_error_vararg (error
, where
, msgid
, ap
);
500 /* Generate a runtime error if COND is true. */
503 gfc_trans_runtime_check (bool error
, bool once
, tree cond
, stmtblock_t
* pblock
,
504 locus
* where
, const char * msgid
, ...)
512 if (integer_zerop (cond
))
517 tmpvar
= gfc_create_var (boolean_type_node
, "print_warning");
518 TREE_STATIC (tmpvar
) = 1;
519 DECL_INITIAL (tmpvar
) = boolean_true_node
;
520 gfc_add_expr_to_block (pblock
, tmpvar
);
523 gfc_start_block (&block
);
525 /* For error, runtime_error_at already implies PRED_NORETURN. */
527 gfc_add_expr_to_block (&block
, build_predict_expr (PRED_FORTRAN_WARN_ONCE
,
530 /* The code to generate the error. */
531 va_start (ap
, msgid
);
532 gfc_add_expr_to_block (&block
,
533 trans_runtime_error_vararg (error
, where
,
538 gfc_add_modify (&block
, tmpvar
, boolean_false_node
);
540 body
= gfc_finish_block (&block
);
542 if (integer_onep (cond
))
544 gfc_add_expr_to_block (pblock
, body
);
549 cond
= fold_build2_loc (where
->lb
->location
, TRUTH_AND_EXPR
,
550 long_integer_type_node
, tmpvar
, cond
);
552 cond
= fold_convert (long_integer_type_node
, cond
);
554 tmp
= fold_build3_loc (where
->lb
->location
, COND_EXPR
, void_type_node
,
556 build_empty_stmt (where
->lb
->location
));
557 gfc_add_expr_to_block (pblock
, tmp
);
562 /* Call malloc to allocate size bytes of memory, with special conditions:
563 + if size == 0, return a malloced area of size 1,
564 + if malloc returns NULL, issue a runtime error. */
566 gfc_call_malloc (stmtblock_t
* block
, tree type
, tree size
)
568 tree tmp
, msg
, malloc_result
, null_result
, res
, malloc_tree
;
571 size
= gfc_evaluate_now (size
, block
);
573 if (TREE_TYPE (size
) != TREE_TYPE (size_type_node
))
574 size
= fold_convert (size_type_node
, size
);
576 /* Create a variable to hold the result. */
577 res
= gfc_create_var (prvoid_type_node
, NULL
);
580 gfc_start_block (&block2
);
582 size
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
, size
,
583 build_int_cst (size_type_node
, 1));
585 malloc_tree
= builtin_decl_explicit (BUILT_IN_MALLOC
);
586 gfc_add_modify (&block2
, res
,
587 fold_convert (prvoid_type_node
,
588 build_call_expr_loc (input_location
,
589 malloc_tree
, 1, size
)));
591 /* Optionally check whether malloc was successful. */
592 if (gfc_option
.rtcheck
& GFC_RTCHECK_MEM
)
594 null_result
= fold_build2_loc (input_location
, EQ_EXPR
,
595 boolean_type_node
, res
,
596 build_int_cst (pvoid_type_node
, 0));
597 msg
= gfc_build_addr_expr (pchar_type_node
,
598 gfc_build_localized_cstring_const ("Memory allocation failed"));
599 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
601 build_call_expr_loc (input_location
,
602 gfor_fndecl_os_error
, 1, msg
),
603 build_empty_stmt (input_location
));
604 gfc_add_expr_to_block (&block2
, tmp
);
607 malloc_result
= gfc_finish_block (&block2
);
609 gfc_add_expr_to_block (block
, malloc_result
);
612 res
= fold_convert (type
, res
);
617 /* Allocate memory, using an optional status argument.
619 This function follows the following pseudo-code:
622 allocate (size_t size, integer_type stat)
629 newmem = malloc (MAX (size, 1));
633 *stat = LIBERROR_ALLOCATION;
635 runtime_error ("Allocation would exceed memory limit");
640 gfc_allocate_using_malloc (stmtblock_t
* block
, tree pointer
,
641 tree size
, tree status
)
643 tree tmp
, error_cond
;
644 stmtblock_t on_error
;
645 tree status_type
= status
? TREE_TYPE (status
) : NULL_TREE
;
647 /* Evaluate size only once, and make sure it has the right type. */
648 size
= gfc_evaluate_now (size
, block
);
649 if (TREE_TYPE (size
) != TREE_TYPE (size_type_node
))
650 size
= fold_convert (size_type_node
, size
);
652 /* If successful and stat= is given, set status to 0. */
653 if (status
!= NULL_TREE
)
654 gfc_add_expr_to_block (block
,
655 fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
656 status
, build_int_cst (status_type
, 0)));
658 /* The allocation itself. */
659 gfc_add_modify (block
, pointer
,
660 fold_convert (TREE_TYPE (pointer
),
661 build_call_expr_loc (input_location
,
662 builtin_decl_explicit (BUILT_IN_MALLOC
), 1,
663 fold_build2_loc (input_location
,
664 MAX_EXPR
, size_type_node
, size
,
665 build_int_cst (size_type_node
, 1)))));
667 /* What to do in case of error. */
668 gfc_start_block (&on_error
);
669 if (status
!= NULL_TREE
)
671 gfc_add_expr_to_block (&on_error
,
672 build_predict_expr (PRED_FORTRAN_FAIL_ALLOC
,
674 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
, status
,
675 build_int_cst (status_type
, LIBERROR_ALLOCATION
));
676 gfc_add_expr_to_block (&on_error
, tmp
);
680 /* Here, os_error already implies PRED_NORETURN. */
681 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_os_error
, 1,
682 gfc_build_addr_expr (pchar_type_node
,
683 gfc_build_localized_cstring_const
684 ("Allocation would exceed memory limit")));
685 gfc_add_expr_to_block (&on_error
, tmp
);
688 error_cond
= fold_build2_loc (input_location
, EQ_EXPR
,
689 boolean_type_node
, pointer
,
690 build_int_cst (prvoid_type_node
, 0));
691 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
692 error_cond
, gfc_finish_block (&on_error
),
693 build_empty_stmt (input_location
));
695 gfc_add_expr_to_block (block
, tmp
);
699 /* Allocate memory, using an optional status argument.
701 This function follows the following pseudo-code:
704 allocate (size_t size, void** token, int *stat, char* errmsg, int errlen)
708 newmem = _caf_register (size, regtype, token, &stat, errmsg, errlen);
712 gfc_allocate_using_lib (stmtblock_t
* block
, tree pointer
, tree size
,
713 tree token
, tree status
, tree errmsg
, tree errlen
,
718 gcc_assert (token
!= NULL_TREE
);
720 /* Evaluate size only once, and make sure it has the right type. */
721 size
= gfc_evaluate_now (size
, block
);
722 if (TREE_TYPE (size
) != TREE_TYPE (size_type_node
))
723 size
= fold_convert (size_type_node
, size
);
725 /* The allocation itself. */
726 if (status
== NULL_TREE
)
727 pstat
= null_pointer_node
;
729 pstat
= gfc_build_addr_expr (NULL_TREE
, status
);
731 if (errmsg
== NULL_TREE
)
733 gcc_assert(errlen
== NULL_TREE
);
734 errmsg
= null_pointer_node
;
735 errlen
= build_int_cst (integer_type_node
, 0);
738 tmp
= build_call_expr_loc (input_location
,
739 gfor_fndecl_caf_register
, 6,
740 fold_build2_loc (input_location
,
741 MAX_EXPR
, size_type_node
, size
,
742 build_int_cst (size_type_node
, 1)),
743 build_int_cst (integer_type_node
,
744 lock_var
? GFC_CAF_LOCK_ALLOC
745 : GFC_CAF_COARRAY_ALLOC
),
746 token
, pstat
, errmsg
, errlen
);
748 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
749 TREE_TYPE (pointer
), pointer
,
750 fold_convert ( TREE_TYPE (pointer
), tmp
));
751 gfc_add_expr_to_block (block
, tmp
);
755 /* Generate code for an ALLOCATE statement when the argument is an
756 allocatable variable. If the variable is currently allocated, it is an
757 error to allocate it again.
759 This function follows the following pseudo-code:
762 allocate_allocatable (void *mem, size_t size, integer_type stat)
765 return allocate (size, stat);
769 stat = LIBERROR_ALLOCATION;
771 runtime_error ("Attempting to allocate already allocated variable");
775 expr must be set to the original expression being allocated for its locus
776 and variable name in case a runtime error has to be printed. */
778 gfc_allocate_allocatable (stmtblock_t
* block
, tree mem
, tree size
, tree token
,
779 tree status
, tree errmsg
, tree errlen
, tree label_finish
,
782 stmtblock_t alloc_block
;
783 tree tmp
, null_mem
, alloc
, error
;
784 tree type
= TREE_TYPE (mem
);
786 if (TREE_TYPE (size
) != TREE_TYPE (size_type_node
))
787 size
= fold_convert (size_type_node
, size
);
789 null_mem
= gfc_unlikely (fold_build2_loc (input_location
, NE_EXPR
,
790 boolean_type_node
, mem
,
791 build_int_cst (type
, 0)),
792 PRED_FORTRAN_FAIL_ALLOC
);
794 /* If mem is NULL, we call gfc_allocate_using_malloc or
795 gfc_allocate_using_lib. */
796 gfc_start_block (&alloc_block
);
798 if (flag_coarray
== GFC_FCOARRAY_LIB
799 && gfc_expr_attr (expr
).codimension
)
802 bool lock_var
= expr
->ts
.type
== BT_DERIVED
803 && expr
->ts
.u
.derived
->from_intmod
804 == INTMOD_ISO_FORTRAN_ENV
805 && expr
->ts
.u
.derived
->intmod_sym_id
806 == ISOFORTRAN_LOCK_TYPE
;
807 /* In the front end, we represent the lock variable as pointer. However,
808 the FE only passes the pointer around and leaves the actual
809 representation to the library. Hence, we have to convert back to the
810 number of elements. */
812 size
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, size_type_node
,
813 size
, TYPE_SIZE_UNIT (ptr_type_node
));
815 gfc_allocate_using_lib (&alloc_block
, mem
, size
, token
, status
,
816 errmsg
, errlen
, lock_var
);
818 if (status
!= NULL_TREE
)
820 TREE_USED (label_finish
) = 1;
821 tmp
= build1_v (GOTO_EXPR
, label_finish
);
822 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
823 status
, build_zero_cst (TREE_TYPE (status
)));
824 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
825 gfc_unlikely (cond
, PRED_FORTRAN_FAIL_ALLOC
),
826 tmp
, build_empty_stmt (input_location
));
827 gfc_add_expr_to_block (&alloc_block
, tmp
);
831 gfc_allocate_using_malloc (&alloc_block
, mem
, size
, status
);
833 alloc
= gfc_finish_block (&alloc_block
);
835 /* If mem is not NULL, we issue a runtime error or set the
841 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
&& expr
->symtree
);
842 varname
= gfc_build_cstring_const (expr
->symtree
->name
);
843 varname
= gfc_build_addr_expr (pchar_type_node
, varname
);
845 error
= gfc_trans_runtime_error (true, &expr
->where
,
846 "Attempting to allocate already"
847 " allocated variable '%s'",
851 error
= gfc_trans_runtime_error (true, NULL
,
852 "Attempting to allocate already allocated"
855 if (status
!= NULL_TREE
)
857 tree status_type
= TREE_TYPE (status
);
859 error
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
860 status
, build_int_cst (status_type
, LIBERROR_ALLOCATION
));
863 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, null_mem
,
865 gfc_add_expr_to_block (block
, tmp
);
869 /* Free a given variable, if it's not NULL. */
871 gfc_call_free (tree var
)
874 tree tmp
, cond
, call
;
876 if (TREE_TYPE (var
) != TREE_TYPE (pvoid_type_node
))
877 var
= fold_convert (pvoid_type_node
, var
);
879 gfc_start_block (&block
);
880 var
= gfc_evaluate_now (var
, &block
);
881 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, var
,
882 build_int_cst (pvoid_type_node
, 0));
883 call
= build_call_expr_loc (input_location
,
884 builtin_decl_explicit (BUILT_IN_FREE
),
886 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, call
,
887 build_empty_stmt (input_location
));
888 gfc_add_expr_to_block (&block
, tmp
);
890 return gfc_finish_block (&block
);
894 /* Build a call to a FINAL procedure, which finalizes "var". */
897 gfc_build_final_call (gfc_typespec ts
, gfc_expr
*final_wrapper
, gfc_expr
*var
,
898 bool fini_coarray
, gfc_expr
*class_size
)
902 tree final_fndecl
, array
, size
, tmp
;
903 symbol_attribute attr
;
905 gcc_assert (final_wrapper
->expr_type
== EXPR_VARIABLE
);
908 gfc_start_block (&block
);
909 gfc_init_se (&se
, NULL
);
910 gfc_conv_expr (&se
, final_wrapper
);
911 final_fndecl
= se
.expr
;
912 if (POINTER_TYPE_P (TREE_TYPE (final_fndecl
)))
913 final_fndecl
= build_fold_indirect_ref_loc (input_location
, final_fndecl
);
915 if (ts
.type
== BT_DERIVED
)
919 gcc_assert (!class_size
);
920 elem_size
= gfc_typenode_for_spec (&ts
);
921 elem_size
= TYPE_SIZE_UNIT (elem_size
);
922 size
= fold_convert (gfc_array_index_type
, elem_size
);
924 gfc_init_se (&se
, NULL
);
928 se
.descriptor_only
= 1;
929 gfc_conv_expr_descriptor (&se
, var
);
934 gfc_conv_expr (&se
, var
);
935 gcc_assert (se
.pre
.head
== NULL_TREE
&& se
.post
.head
== NULL_TREE
);
938 /* No copy back needed, hence set attr's allocatable/pointer
940 gfc_clear_attr (&attr
);
941 gfc_init_se (&se
, NULL
);
942 array
= gfc_conv_scalar_to_descriptor (&se
, array
, attr
);
943 gcc_assert (se
.post
.head
== NULL_TREE
);
948 gfc_expr
*array_expr
;
949 gcc_assert (class_size
);
950 gfc_init_se (&se
, NULL
);
951 gfc_conv_expr (&se
, class_size
);
952 gfc_add_block_to_block (&block
, &se
.pre
);
953 gcc_assert (se
.post
.head
== NULL_TREE
);
956 array_expr
= gfc_copy_expr (var
);
957 gfc_init_se (&se
, NULL
);
959 if (array_expr
->rank
)
961 gfc_add_class_array_ref (array_expr
);
962 se
.descriptor_only
= 1;
963 gfc_conv_expr_descriptor (&se
, array_expr
);
968 gfc_add_data_component (array_expr
);
969 gfc_conv_expr (&se
, array_expr
);
970 gfc_add_block_to_block (&block
, &se
.pre
);
971 gcc_assert (se
.post
.head
== NULL_TREE
);
973 if (TREE_CODE (array
) == ADDR_EXPR
974 && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (array
, 0))))
975 tmp
= TREE_OPERAND (array
, 0);
977 if (!gfc_is_coarray (array_expr
))
979 /* No copy back needed, hence set attr's allocatable/pointer
981 gfc_clear_attr (&attr
);
982 gfc_init_se (&se
, NULL
);
983 array
= gfc_conv_scalar_to_descriptor (&se
, array
, attr
);
985 gcc_assert (se
.post
.head
== NULL_TREE
);
987 gfc_free_expr (array_expr
);
990 if (!POINTER_TYPE_P (TREE_TYPE (array
)))
991 array
= gfc_build_addr_expr (NULL
, array
);
993 gfc_add_block_to_block (&block
, &se
.pre
);
994 tmp
= build_call_expr_loc (input_location
,
995 final_fndecl
, 3, array
,
996 size
, fini_coarray
? boolean_true_node
997 : boolean_false_node
);
998 gfc_add_block_to_block (&block
, &se
.post
);
999 gfc_add_expr_to_block (&block
, tmp
);
1000 return gfc_finish_block (&block
);
1005 gfc_add_comp_finalizer_call (stmtblock_t
*block
, tree decl
, gfc_component
*comp
,
1010 tree final_fndecl
, size
, array
, tmp
, cond
;
1011 symbol_attribute attr
;
1012 gfc_expr
*final_expr
= NULL
;
1014 if (comp
->ts
.type
!= BT_DERIVED
&& comp
->ts
.type
!= BT_CLASS
)
1017 gfc_init_block (&block2
);
1019 if (comp
->ts
.type
== BT_DERIVED
)
1021 if (comp
->attr
.pointer
)
1024 gfc_is_finalizable (comp
->ts
.u
.derived
, &final_expr
);
1028 gfc_init_se (&se
, NULL
);
1029 gfc_conv_expr (&se
, final_expr
);
1030 final_fndecl
= se
.expr
;
1031 size
= gfc_typenode_for_spec (&comp
->ts
);
1032 size
= TYPE_SIZE_UNIT (size
);
1033 size
= fold_convert (gfc_array_index_type
, size
);
1037 else /* comp->ts.type == BT_CLASS. */
1039 if (CLASS_DATA (comp
)->attr
.class_pointer
)
1042 gfc_is_finalizable (CLASS_DATA (comp
)->ts
.u
.derived
, &final_expr
);
1043 final_fndecl
= gfc_class_vtab_final_get (decl
);
1044 size
= gfc_class_vtab_size_get (decl
);
1045 array
= gfc_class_data_get (decl
);
1048 if (comp
->attr
.allocatable
1049 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)->attr
.allocatable
))
1051 tmp
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array
))
1052 ? gfc_conv_descriptor_data_get (array
) : array
;
1053 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1054 tmp
, fold_convert (TREE_TYPE (tmp
),
1055 null_pointer_node
));
1058 cond
= boolean_true_node
;
1060 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array
)))
1062 gfc_clear_attr (&attr
);
1063 gfc_init_se (&se
, NULL
);
1064 array
= gfc_conv_scalar_to_descriptor (&se
, array
, attr
);
1065 gfc_add_block_to_block (&block2
, &se
.pre
);
1066 gcc_assert (se
.post
.head
== NULL_TREE
);
1069 if (!POINTER_TYPE_P (TREE_TYPE (array
)))
1070 array
= gfc_build_addr_expr (NULL
, array
);
1074 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1076 fold_convert (TREE_TYPE (final_fndecl
),
1077 null_pointer_node
));
1078 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1079 boolean_type_node
, cond
, tmp
);
1082 if (POINTER_TYPE_P (TREE_TYPE (final_fndecl
)))
1083 final_fndecl
= build_fold_indirect_ref_loc (input_location
, final_fndecl
);
1085 tmp
= build_call_expr_loc (input_location
,
1086 final_fndecl
, 3, array
,
1087 size
, fini_coarray
? boolean_true_node
1088 : boolean_false_node
);
1089 gfc_add_expr_to_block (&block2
, tmp
);
1090 tmp
= gfc_finish_block (&block2
);
1092 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
1093 build_empty_stmt (input_location
));
1094 gfc_add_expr_to_block (block
, tmp
);
1100 /* Add a call to the finalizer, using the passed *expr. Returns
1101 true when a finalizer call has been inserted. */
1104 gfc_add_finalizer_call (stmtblock_t
*block
, gfc_expr
*expr2
)
1109 gfc_expr
*final_expr
= NULL
;
1110 gfc_expr
*elem_size
= NULL
;
1111 bool has_finalizer
= false;
1113 if (!expr2
|| (expr2
->ts
.type
!= BT_DERIVED
&& expr2
->ts
.type
!= BT_CLASS
))
1116 if (expr2
->ts
.type
== BT_DERIVED
)
1118 gfc_is_finalizable (expr2
->ts
.u
.derived
, &final_expr
);
1123 /* If we have a class array, we need go back to the class
1125 expr
= gfc_copy_expr (expr2
);
1127 if (expr
->ref
&& expr
->ref
->next
&& !expr
->ref
->next
->next
1128 && expr
->ref
->next
->type
== REF_ARRAY
1129 && expr
->ref
->type
== REF_COMPONENT
1130 && strcmp (expr
->ref
->u
.c
.component
->name
, "_data") == 0)
1132 gfc_free_ref_list (expr
->ref
);
1136 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1137 if (ref
->next
&& ref
->next
->next
&& !ref
->next
->next
->next
1138 && ref
->next
->next
->type
== REF_ARRAY
1139 && ref
->next
->type
== REF_COMPONENT
1140 && strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0)
1142 gfc_free_ref_list (ref
->next
);
1146 if (expr
->ts
.type
== BT_CLASS
)
1148 has_finalizer
= gfc_is_finalizable (expr
->ts
.u
.derived
, NULL
);
1150 if (!expr2
->rank
&& !expr2
->ref
&& CLASS_DATA (expr2
->symtree
->n
.sym
)->as
)
1151 expr
->rank
= CLASS_DATA (expr2
->symtree
->n
.sym
)->as
->rank
;
1153 final_expr
= gfc_copy_expr (expr
);
1154 gfc_add_vptr_component (final_expr
);
1155 gfc_add_component_ref (final_expr
, "_final");
1157 elem_size
= gfc_copy_expr (expr
);
1158 gfc_add_vptr_component (elem_size
);
1159 gfc_add_component_ref (elem_size
, "_size");
1162 gcc_assert (final_expr
->expr_type
== EXPR_VARIABLE
);
1164 tmp
= gfc_build_final_call (expr
->ts
, final_expr
, expr
,
1167 if (expr
->ts
.type
== BT_CLASS
&& !has_finalizer
)
1172 gfc_init_se (&se
, NULL
);
1173 se
.want_pointer
= 1;
1174 gfc_conv_expr (&se
, final_expr
);
1175 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1176 se
.expr
, build_int_cst (TREE_TYPE (se
.expr
), 0));
1178 /* For CLASS(*) not only sym->_vtab->_final can be NULL
1179 but already sym->_vtab itself. */
1180 if (UNLIMITED_POLY (expr
))
1183 gfc_expr
*vptr_expr
;
1185 vptr_expr
= gfc_copy_expr (expr
);
1186 gfc_add_vptr_component (vptr_expr
);
1188 gfc_init_se (&se
, NULL
);
1189 se
.want_pointer
= 1;
1190 gfc_conv_expr (&se
, vptr_expr
);
1191 gfc_free_expr (vptr_expr
);
1193 cond2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1195 build_int_cst (TREE_TYPE (se
.expr
), 0));
1196 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1197 boolean_type_node
, cond2
, cond
);
1200 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1201 cond
, tmp
, build_empty_stmt (input_location
));
1204 gfc_add_expr_to_block (block
, tmp
);
1210 /* User-deallocate; we emit the code directly from the front-end, and the
1211 logic is the same as the previous library function:
1214 deallocate (void *pointer, GFC_INTEGER_4 * stat)
1221 runtime_error ("Attempt to DEALLOCATE unallocated memory.");
1231 In this front-end version, status doesn't have to be GFC_INTEGER_4.
1232 Moreover, if CAN_FAIL is true, then we will not emit a runtime error,
1233 even when no status variable is passed to us (this is used for
1234 unconditional deallocation generated by the front-end at end of
1237 If a runtime-message is possible, `expr' must point to the original
1238 expression being deallocated for its locus and variable name.
1240 For coarrays, "pointer" must be the array descriptor and not its
1241 "data" component. */
1243 gfc_deallocate_with_status (tree pointer
, tree status
, tree errmsg
,
1244 tree errlen
, tree label_finish
,
1245 bool can_fail
, gfc_expr
* expr
, bool coarray
)
1247 stmtblock_t null
, non_null
;
1248 tree cond
, tmp
, error
;
1249 tree status_type
= NULL_TREE
;
1250 tree caf_decl
= NULL_TREE
;
1254 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer
)));
1256 pointer
= gfc_conv_descriptor_data_get (caf_decl
);
1257 STRIP_NOPS (pointer
);
1260 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, pointer
,
1261 build_int_cst (TREE_TYPE (pointer
), 0));
1263 /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
1264 we emit a runtime error. */
1265 gfc_start_block (&null
);
1270 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
&& expr
->symtree
);
1272 varname
= gfc_build_cstring_const (expr
->symtree
->name
);
1273 varname
= gfc_build_addr_expr (pchar_type_node
, varname
);
1275 error
= gfc_trans_runtime_error (true, &expr
->where
,
1276 "Attempt to DEALLOCATE unallocated '%s'",
1280 error
= build_empty_stmt (input_location
);
1282 if (status
!= NULL_TREE
&& !integer_zerop (status
))
1286 status_type
= TREE_TYPE (TREE_TYPE (status
));
1287 cond2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1288 status
, build_int_cst (TREE_TYPE (status
), 0));
1289 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
1290 fold_build1_loc (input_location
, INDIRECT_REF
,
1291 status_type
, status
),
1292 build_int_cst (status_type
, 1));
1293 error
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1297 gfc_add_expr_to_block (&null
, error
);
1299 /* When POINTER is not NULL, we free it. */
1300 gfc_start_block (&non_null
);
1301 gfc_add_finalizer_call (&non_null
, expr
);
1302 if (!coarray
|| flag_coarray
!= GFC_FCOARRAY_LIB
)
1304 tmp
= build_call_expr_loc (input_location
,
1305 builtin_decl_explicit (BUILT_IN_FREE
), 1,
1306 fold_convert (pvoid_type_node
, pointer
));
1307 gfc_add_expr_to_block (&non_null
, tmp
);
1309 if (status
!= NULL_TREE
&& !integer_zerop (status
))
1311 /* We set STATUS to zero if it is present. */
1312 tree status_type
= TREE_TYPE (TREE_TYPE (status
));
1315 cond2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1317 build_int_cst (TREE_TYPE (status
), 0));
1318 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
1319 fold_build1_loc (input_location
, INDIRECT_REF
,
1320 status_type
, status
),
1321 build_int_cst (status_type
, 0));
1322 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1323 gfc_unlikely (cond2
, PRED_FORTRAN_FAIL_ALLOC
),
1324 tmp
, build_empty_stmt (input_location
));
1325 gfc_add_expr_to_block (&non_null
, tmp
);
1330 tree caf_type
, token
, cond2
;
1331 tree pstat
= null_pointer_node
;
1333 if (errmsg
== NULL_TREE
)
1335 gcc_assert (errlen
== NULL_TREE
);
1336 errmsg
= null_pointer_node
;
1337 errlen
= build_zero_cst (integer_type_node
);
1341 gcc_assert (errlen
!= NULL_TREE
);
1342 if (!POINTER_TYPE_P (TREE_TYPE (errmsg
)))
1343 errmsg
= gfc_build_addr_expr (NULL_TREE
, errmsg
);
1346 caf_type
= TREE_TYPE (caf_decl
);
1348 if (status
!= NULL_TREE
&& !integer_zerop (status
))
1350 gcc_assert (status_type
== integer_type_node
);
1354 if (GFC_DESCRIPTOR_TYPE_P (caf_type
)
1355 && GFC_TYPE_ARRAY_AKIND (caf_type
) == GFC_ARRAY_ALLOCATABLE
)
1356 token
= gfc_conv_descriptor_token (caf_decl
);
1357 else if (DECL_LANG_SPECIFIC (caf_decl
)
1358 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
1359 token
= GFC_DECL_TOKEN (caf_decl
);
1362 gcc_assert (GFC_ARRAY_TYPE_P (caf_type
)
1363 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) != NULL_TREE
);
1364 token
= GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
);
1367 token
= gfc_build_addr_expr (NULL_TREE
, token
);
1368 tmp
= build_call_expr_loc (input_location
,
1369 gfor_fndecl_caf_deregister
, 4,
1370 token
, pstat
, errmsg
, errlen
);
1371 gfc_add_expr_to_block (&non_null
, tmp
);
1373 if (status
!= NULL_TREE
)
1375 tree stat
= build_fold_indirect_ref_loc (input_location
, status
);
1377 TREE_USED (label_finish
) = 1;
1378 tmp
= build1_v (GOTO_EXPR
, label_finish
);
1379 cond2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1380 stat
, build_zero_cst (TREE_TYPE (stat
)));
1381 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1382 gfc_unlikely (cond2
, PRED_FORTRAN_FAIL_ALLOC
),
1383 tmp
, build_empty_stmt (input_location
));
1384 gfc_add_expr_to_block (&non_null
, tmp
);
1388 return fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
1389 gfc_finish_block (&null
),
1390 gfc_finish_block (&non_null
));
1394 /* Generate code for deallocation of allocatable scalars (variables or
1395 components). Before the object itself is freed, any allocatable
1396 subcomponents are being deallocated. */
1399 gfc_deallocate_scalar_with_status (tree pointer
, tree status
, bool can_fail
,
1400 gfc_expr
* expr
, gfc_typespec ts
)
1402 stmtblock_t null
, non_null
;
1403 tree cond
, tmp
, error
;
1406 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, pointer
,
1407 build_int_cst (TREE_TYPE (pointer
), 0));
1409 /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
1410 we emit a runtime error. */
1411 gfc_start_block (&null
);
1416 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
&& expr
->symtree
);
1418 varname
= gfc_build_cstring_const (expr
->symtree
->name
);
1419 varname
= gfc_build_addr_expr (pchar_type_node
, varname
);
1421 error
= gfc_trans_runtime_error (true, &expr
->where
,
1422 "Attempt to DEALLOCATE unallocated '%s'",
1426 error
= build_empty_stmt (input_location
);
1428 if (status
!= NULL_TREE
&& !integer_zerop (status
))
1430 tree status_type
= TREE_TYPE (TREE_TYPE (status
));
1433 cond2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1434 status
, build_int_cst (TREE_TYPE (status
), 0));
1435 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
1436 fold_build1_loc (input_location
, INDIRECT_REF
,
1437 status_type
, status
),
1438 build_int_cst (status_type
, 1));
1439 error
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1443 gfc_add_expr_to_block (&null
, error
);
1445 /* When POINTER is not NULL, we free it. */
1446 gfc_start_block (&non_null
);
1448 /* Free allocatable components. */
1449 finalizable
= gfc_add_finalizer_call (&non_null
, expr
);
1450 if (!finalizable
&& ts
.type
== BT_DERIVED
&& ts
.u
.derived
->attr
.alloc_comp
)
1452 tmp
= build_fold_indirect_ref_loc (input_location
, pointer
);
1453 tmp
= gfc_deallocate_alloc_comp (ts
.u
.derived
, tmp
, 0);
1454 gfc_add_expr_to_block (&non_null
, tmp
);
1457 tmp
= build_call_expr_loc (input_location
,
1458 builtin_decl_explicit (BUILT_IN_FREE
), 1,
1459 fold_convert (pvoid_type_node
, pointer
));
1460 gfc_add_expr_to_block (&non_null
, tmp
);
1462 if (status
!= NULL_TREE
&& !integer_zerop (status
))
1464 /* We set STATUS to zero if it is present. */
1465 tree status_type
= TREE_TYPE (TREE_TYPE (status
));
1468 cond2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1469 status
, build_int_cst (TREE_TYPE (status
), 0));
1470 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
1471 fold_build1_loc (input_location
, INDIRECT_REF
,
1472 status_type
, status
),
1473 build_int_cst (status_type
, 0));
1474 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
1475 tmp
, build_empty_stmt (input_location
));
1476 gfc_add_expr_to_block (&non_null
, tmp
);
1479 return fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
1480 gfc_finish_block (&null
),
1481 gfc_finish_block (&non_null
));
1485 /* Reallocate MEM so it has SIZE bytes of data. This behaves like the
1486 following pseudo-code:
1489 internal_realloc (void *mem, size_t size)
1491 res = realloc (mem, size);
1492 if (!res && size != 0)
1493 _gfortran_os_error ("Allocation would exceed memory limit");
1498 gfc_call_realloc (stmtblock_t
* block
, tree mem
, tree size
)
1500 tree msg
, res
, nonzero
, null_result
, tmp
;
1501 tree type
= TREE_TYPE (mem
);
1503 size
= gfc_evaluate_now (size
, block
);
1505 if (TREE_TYPE (size
) != TREE_TYPE (size_type_node
))
1506 size
= fold_convert (size_type_node
, size
);
1508 /* Create a variable to hold the result. */
1509 res
= gfc_create_var (type
, NULL
);
1511 /* Call realloc and check the result. */
1512 tmp
= build_call_expr_loc (input_location
,
1513 builtin_decl_explicit (BUILT_IN_REALLOC
), 2,
1514 fold_convert (pvoid_type_node
, mem
), size
);
1515 gfc_add_modify (block
, res
, fold_convert (type
, tmp
));
1516 null_result
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1517 res
, build_int_cst (pvoid_type_node
, 0));
1518 nonzero
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, size
,
1519 build_int_cst (size_type_node
, 0));
1520 null_result
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, boolean_type_node
,
1521 null_result
, nonzero
);
1522 msg
= gfc_build_addr_expr (pchar_type_node
, gfc_build_localized_cstring_const
1523 ("Allocation would exceed memory limit"));
1524 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1526 build_call_expr_loc (input_location
,
1527 gfor_fndecl_os_error
, 1, msg
),
1528 build_empty_stmt (input_location
));
1529 gfc_add_expr_to_block (block
, tmp
);
1535 /* Add an expression to another one, either at the front or the back. */
1538 add_expr_to_chain (tree
* chain
, tree expr
, bool front
)
1540 if (expr
== NULL_TREE
|| IS_EMPTY_STMT (expr
))
1545 if (TREE_CODE (*chain
) != STATEMENT_LIST
)
1551 append_to_statement_list (tmp
, chain
);
1556 tree_stmt_iterator i
;
1558 i
= tsi_start (*chain
);
1559 tsi_link_before (&i
, expr
, TSI_CONTINUE_LINKING
);
1562 append_to_statement_list (expr
, chain
);
1569 /* Add a statement at the end of a block. */
1572 gfc_add_expr_to_block (stmtblock_t
* block
, tree expr
)
1575 add_expr_to_chain (&block
->head
, expr
, false);
1579 /* Add a statement at the beginning of a block. */
1582 gfc_prepend_expr_to_block (stmtblock_t
* block
, tree expr
)
1585 add_expr_to_chain (&block
->head
, expr
, true);
1589 /* Add a block the end of a block. */
1592 gfc_add_block_to_block (stmtblock_t
* block
, stmtblock_t
* append
)
1594 gcc_assert (append
);
1595 gcc_assert (!append
->has_scope
);
1597 gfc_add_expr_to_block (block
, append
->head
);
1598 append
->head
= NULL_TREE
;
1602 /* Save the current locus. The structure may not be complete, and should
1603 only be used with gfc_restore_backend_locus. */
1606 gfc_save_backend_locus (locus
* loc
)
1608 loc
->lb
= XCNEW (gfc_linebuf
);
1609 loc
->lb
->location
= input_location
;
1610 loc
->lb
->file
= gfc_current_backend_file
;
1614 /* Set the current locus. */
1617 gfc_set_backend_locus (locus
* loc
)
1619 gfc_current_backend_file
= loc
->lb
->file
;
1620 input_location
= loc
->lb
->location
;
1624 /* Restore the saved locus. Only used in conjunction with
1625 gfc_save_backend_locus, to free the memory when we are done. */
1628 gfc_restore_backend_locus (locus
* loc
)
1630 gfc_set_backend_locus (loc
);
1635 /* Translate an executable statement. The tree cond is used by gfc_trans_do.
1636 This static function is wrapped by gfc_trans_code_cond and
1640 trans_code (gfc_code
* code
, tree cond
)
1646 return build_empty_stmt (input_location
);
1648 gfc_start_block (&block
);
1650 /* Translate statements one by one into GENERIC trees until we reach
1651 the end of this gfc_code branch. */
1652 for (; code
; code
= code
->next
)
1654 if (code
->here
!= 0)
1656 res
= gfc_trans_label_here (code
);
1657 gfc_add_expr_to_block (&block
, res
);
1660 gfc_set_backend_locus (&code
->loc
);
1665 case EXEC_END_BLOCK
:
1666 case EXEC_END_NESTED_BLOCK
:
1667 case EXEC_END_PROCEDURE
:
1672 if (code
->expr1
->ts
.type
== BT_CLASS
)
1673 res
= gfc_trans_class_assign (code
->expr1
, code
->expr2
, code
->op
);
1675 res
= gfc_trans_assign (code
);
1678 case EXEC_LABEL_ASSIGN
:
1679 res
= gfc_trans_label_assign (code
);
1682 case EXEC_POINTER_ASSIGN
:
1683 if (code
->expr1
->ts
.type
== BT_CLASS
)
1684 res
= gfc_trans_class_assign (code
->expr1
, code
->expr2
, code
->op
);
1685 else if (UNLIMITED_POLY (code
->expr2
)
1686 && code
->expr1
->ts
.type
== BT_DERIVED
1687 && (code
->expr1
->ts
.u
.derived
->attr
.sequence
1688 || code
->expr1
->ts
.u
.derived
->attr
.is_bind_c
))
1690 res
= gfc_trans_class_assign (code
->expr1
, code
->expr2
, code
->op
);
1692 res
= gfc_trans_pointer_assign (code
);
1695 case EXEC_INIT_ASSIGN
:
1696 if (code
->expr1
->ts
.type
== BT_CLASS
)
1697 res
= gfc_trans_class_init_assign (code
);
1699 res
= gfc_trans_init_assign (code
);
1707 res
= gfc_trans_critical (code
);
1711 res
= gfc_trans_cycle (code
);
1715 res
= gfc_trans_exit (code
);
1719 res
= gfc_trans_goto (code
);
1723 res
= gfc_trans_entry (code
);
1727 res
= gfc_trans_pause (code
);
1731 case EXEC_ERROR_STOP
:
1732 res
= gfc_trans_stop (code
, code
->op
== EXEC_ERROR_STOP
);
1736 /* For MVBITS we've got the special exception that we need a
1737 dependency check, too. */
1739 bool is_mvbits
= false;
1741 if (code
->resolved_isym
)
1743 res
= gfc_conv_intrinsic_subroutine (code
);
1744 if (res
!= NULL_TREE
)
1748 if (code
->resolved_isym
1749 && code
->resolved_isym
->id
== GFC_ISYM_MVBITS
)
1752 res
= gfc_trans_call (code
, is_mvbits
, NULL_TREE
,
1758 res
= gfc_trans_call (code
, false, NULL_TREE
,
1762 case EXEC_ASSIGN_CALL
:
1763 res
= gfc_trans_call (code
, true, NULL_TREE
,
1768 res
= gfc_trans_return (code
);
1772 res
= gfc_trans_if (code
);
1775 case EXEC_ARITHMETIC_IF
:
1776 res
= gfc_trans_arithmetic_if (code
);
1780 res
= gfc_trans_block_construct (code
);
1784 res
= gfc_trans_do (code
, cond
);
1787 case EXEC_DO_CONCURRENT
:
1788 res
= gfc_trans_do_concurrent (code
);
1792 res
= gfc_trans_do_while (code
);
1796 res
= gfc_trans_select (code
);
1799 case EXEC_SELECT_TYPE
:
1800 /* Do nothing. SELECT TYPE statements should be transformed into
1801 an ordinary SELECT CASE at resolution stage.
1802 TODO: Add an error message here once this is done. */
1807 res
= gfc_trans_flush (code
);
1811 case EXEC_SYNC_IMAGES
:
1812 case EXEC_SYNC_MEMORY
:
1813 res
= gfc_trans_sync (code
, code
->op
);
1818 res
= gfc_trans_lock_unlock (code
, code
->op
);
1822 res
= gfc_trans_forall (code
);
1826 res
= gfc_trans_where (code
);
1830 res
= gfc_trans_allocate (code
);
1833 case EXEC_DEALLOCATE
:
1834 res
= gfc_trans_deallocate (code
);
1838 res
= gfc_trans_open (code
);
1842 res
= gfc_trans_close (code
);
1846 res
= gfc_trans_read (code
);
1850 res
= gfc_trans_write (code
);
1854 res
= gfc_trans_iolength (code
);
1857 case EXEC_BACKSPACE
:
1858 res
= gfc_trans_backspace (code
);
1862 res
= gfc_trans_endfile (code
);
1866 res
= gfc_trans_inquire (code
);
1870 res
= gfc_trans_wait (code
);
1874 res
= gfc_trans_rewind (code
);
1878 res
= gfc_trans_transfer (code
);
1882 res
= gfc_trans_dt_end (code
);
1885 case EXEC_OMP_ATOMIC
:
1886 case EXEC_OMP_BARRIER
:
1887 case EXEC_OMP_CANCEL
:
1888 case EXEC_OMP_CANCELLATION_POINT
:
1889 case EXEC_OMP_CRITICAL
:
1890 case EXEC_OMP_DISTRIBUTE
:
1891 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
1892 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
1893 case EXEC_OMP_DISTRIBUTE_SIMD
:
1895 case EXEC_OMP_DO_SIMD
:
1896 case EXEC_OMP_FLUSH
:
1897 case EXEC_OMP_MASTER
:
1898 case EXEC_OMP_ORDERED
:
1899 case EXEC_OMP_PARALLEL
:
1900 case EXEC_OMP_PARALLEL_DO
:
1901 case EXEC_OMP_PARALLEL_DO_SIMD
:
1902 case EXEC_OMP_PARALLEL_SECTIONS
:
1903 case EXEC_OMP_PARALLEL_WORKSHARE
:
1904 case EXEC_OMP_SECTIONS
:
1906 case EXEC_OMP_SINGLE
:
1907 case EXEC_OMP_TARGET
:
1908 case EXEC_OMP_TARGET_DATA
:
1909 case EXEC_OMP_TARGET_TEAMS
:
1910 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
1911 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
1912 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
1913 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
1914 case EXEC_OMP_TARGET_UPDATE
:
1916 case EXEC_OMP_TASKGROUP
:
1917 case EXEC_OMP_TASKWAIT
:
1918 case EXEC_OMP_TASKYIELD
:
1919 case EXEC_OMP_TEAMS
:
1920 case EXEC_OMP_TEAMS_DISTRIBUTE
:
1921 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
1922 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
1923 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
1924 case EXEC_OMP_WORKSHARE
:
1925 res
= gfc_trans_omp_directive (code
);
1928 case EXEC_OACC_CACHE
:
1929 case EXEC_OACC_WAIT
:
1930 case EXEC_OACC_UPDATE
:
1931 case EXEC_OACC_LOOP
:
1932 case EXEC_OACC_HOST_DATA
:
1933 case EXEC_OACC_DATA
:
1934 case EXEC_OACC_KERNELS
:
1935 case EXEC_OACC_KERNELS_LOOP
:
1936 case EXEC_OACC_PARALLEL
:
1937 case EXEC_OACC_PARALLEL_LOOP
:
1938 case EXEC_OACC_ENTER_DATA
:
1939 case EXEC_OACC_EXIT_DATA
:
1940 res
= gfc_trans_oacc_directive (code
);
1944 gfc_internal_error ("gfc_trans_code(): Bad statement code");
1947 gfc_set_backend_locus (&code
->loc
);
1949 if (res
!= NULL_TREE
&& ! IS_EMPTY_STMT (res
))
1951 if (TREE_CODE (res
) != STATEMENT_LIST
)
1952 SET_EXPR_LOCATION (res
, input_location
);
1954 /* Add the new statement to the block. */
1955 gfc_add_expr_to_block (&block
, res
);
1959 /* Return the finished block. */
1960 return gfc_finish_block (&block
);
1964 /* Translate an executable statement with condition, cond. The condition is
1965 used by gfc_trans_do to test for IO result conditions inside implied
1966 DO loops of READ and WRITE statements. See build_dt in trans-io.c. */
1969 gfc_trans_code_cond (gfc_code
* code
, tree cond
)
1971 return trans_code (code
, cond
);
1974 /* Translate an executable statement without condition. */
1977 gfc_trans_code (gfc_code
* code
)
1979 return trans_code (code
, NULL_TREE
);
1983 /* This function is called after a complete program unit has been parsed
1987 gfc_generate_code (gfc_namespace
* ns
)
1990 if (ns
->is_block_data
)
1992 gfc_generate_block_data (ns
);
1996 gfc_generate_function_code (ns
);
2000 /* This function is called after a complete module has been parsed
2004 gfc_generate_module_code (gfc_namespace
* ns
)
2007 struct module_htab_entry
*entry
;
2009 gcc_assert (ns
->proc_name
->backend_decl
== NULL
);
2010 ns
->proc_name
->backend_decl
2011 = build_decl (ns
->proc_name
->declared_at
.lb
->location
,
2012 NAMESPACE_DECL
, get_identifier (ns
->proc_name
->name
),
2014 entry
= gfc_find_module (ns
->proc_name
->name
);
2015 if (entry
->namespace_decl
)
2016 /* Buggy sourcecode, using a module before defining it? */
2017 entry
->decls
->empty ();
2018 entry
->namespace_decl
= ns
->proc_name
->backend_decl
;
2020 gfc_generate_module_vars (ns
);
2022 /* We need to generate all module function prototypes first, to allow
2024 for (n
= ns
->contained
; n
; n
= n
->sibling
)
2031 gfc_create_function_decl (n
, false);
2032 DECL_CONTEXT (n
->proc_name
->backend_decl
) = ns
->proc_name
->backend_decl
;
2033 gfc_module_add_decl (entry
, n
->proc_name
->backend_decl
);
2034 for (el
= ns
->entries
; el
; el
= el
->next
)
2036 DECL_CONTEXT (el
->sym
->backend_decl
) = ns
->proc_name
->backend_decl
;
2037 gfc_module_add_decl (entry
, el
->sym
->backend_decl
);
2041 for (n
= ns
->contained
; n
; n
= n
->sibling
)
2046 gfc_generate_function_code (n
);
2051 /* Initialize an init/cleanup block with existing code. */
2054 gfc_start_wrapped_block (gfc_wrapped_block
* block
, tree code
)
2058 block
->init
= NULL_TREE
;
2060 block
->cleanup
= NULL_TREE
;
2064 /* Add a new pair of initializers/clean-up code. */
2067 gfc_add_init_cleanup (gfc_wrapped_block
* block
, tree init
, tree cleanup
)
2071 /* The new pair of init/cleanup should be "wrapped around" the existing
2072 block of code, thus the initialization is added to the front and the
2073 cleanup to the back. */
2074 add_expr_to_chain (&block
->init
, init
, true);
2075 add_expr_to_chain (&block
->cleanup
, cleanup
, false);
2079 /* Finish up a wrapped block by building a corresponding try-finally expr. */
2082 gfc_finish_wrapped_block (gfc_wrapped_block
* block
)
2088 /* Build the final expression. For this, just add init and body together,
2089 and put clean-up with that into a TRY_FINALLY_EXPR. */
2090 result
= block
->init
;
2091 add_expr_to_chain (&result
, block
->code
, false);
2093 result
= build2_loc (input_location
, TRY_FINALLY_EXPR
, void_type_node
,
2094 result
, block
->cleanup
);
2096 /* Clear the block. */
2097 block
->init
= NULL_TREE
;
2098 block
->code
= NULL_TREE
;
2099 block
->cleanup
= NULL_TREE
;
2105 /* Helper function for marking a boolean expression tree as unlikely. */
2108 gfc_unlikely (tree cond
, enum br_predictor predictor
)
2114 cond
= fold_convert (long_integer_type_node
, cond
);
2115 tmp
= build_zero_cst (long_integer_type_node
);
2116 cond
= build_call_expr_loc (input_location
,
2117 builtin_decl_explicit (BUILT_IN_EXPECT
),
2119 build_int_cst (integer_type_node
,
2122 cond
= fold_convert (boolean_type_node
, cond
);
2127 /* Helper function for marking a boolean expression tree as likely. */
2130 gfc_likely (tree cond
, enum br_predictor predictor
)
2136 cond
= fold_convert (long_integer_type_node
, cond
);
2137 tmp
= build_one_cst (long_integer_type_node
);
2138 cond
= build_call_expr_loc (input_location
,
2139 builtin_decl_explicit (BUILT_IN_EXPECT
),
2141 build_int_cst (integer_type_node
,
2144 cond
= fold_convert (boolean_type_node
, cond
);
2149 /* Get the string length for a deferred character length component. */
2152 gfc_deferred_strlen (gfc_component
*c
, tree
*decl
)
2154 char name
[GFC_MAX_SYMBOL_LEN
+9];
2155 gfc_component
*strlen
;
2156 if (!(c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
))
2158 sprintf (name
, "_%s_length", c
->name
);
2159 for (strlen
= c
; strlen
; strlen
= strlen
->next
)
2160 if (strcmp (strlen
->name
, name
) == 0)
2162 *decl
= strlen
? strlen
->backend_decl
: NULL_TREE
;
2163 return strlen
!= NULL
;