1 /* Code translation -- generate GCC trees from gfc_code.
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
3 Free Software Foundation, Inc.
4 Contributed by Paul Brook
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
24 #include "coretypes.h"
26 #include "gimple.h" /* For create_tmp_var_raw. */
27 #include "tree-iterator.h"
28 #include "diagnostic-core.h" /* For internal_error. */
33 #include "trans-stmt.h"
34 #include "trans-array.h"
35 #include "trans-types.h"
36 #include "trans-const.h"
38 /* Naming convention for backend interface code:
40 gfc_trans_* translate gfc_code into STMT trees.
42 gfc_conv_* expression conversion
44 gfc_get_* get a backend tree representation of a decl or type */
46 static gfc_file
*gfc_current_backend_file
;
48 const char gfc_msg_fault
[] = N_("Array reference out of bounds");
49 const char gfc_msg_wrong_return
[] = N_("Incorrect function return value");
52 /* Advance along TREE_CHAIN n times. */
55 gfc_advance_chain (tree t
, int n
)
59 gcc_assert (t
!= NULL_TREE
);
66 /* Wrap a node in a TREE_LIST node and add it to the end of a list. */
69 gfc_chainon_list (tree list
, tree add
)
73 l
= tree_cons (NULL_TREE
, add
, NULL_TREE
);
75 return chainon (list
, l
);
79 /* Strip off a legitimate source ending from the input
80 string NAME of length LEN. */
83 remove_suffix (char *name
, int len
)
87 for (i
= 2; i
< 8 && len
> i
; i
++)
89 if (name
[len
- i
] == '.')
98 /* Creates a variable declaration with a given TYPE. */
101 gfc_create_var_np (tree type
, const char *prefix
)
105 t
= create_tmp_var_raw (type
, prefix
);
107 /* No warnings for anonymous variables. */
109 TREE_NO_WARNING (t
) = 1;
115 /* Like above, but also adds it to the current scope. */
118 gfc_create_var (tree type
, const char *prefix
)
122 tmp
= gfc_create_var_np (type
, prefix
);
130 /* If the expression is not constant, evaluate it now. We assign the
131 result of the expression to an artificially created variable VAR, and
132 return a pointer to the VAR_DECL node for this variable. */
135 gfc_evaluate_now_loc (location_t loc
, tree expr
, stmtblock_t
* pblock
)
139 if (CONSTANT_CLASS_P (expr
))
142 var
= gfc_create_var (TREE_TYPE (expr
), NULL
);
143 gfc_add_modify_loc (loc
, pblock
, var
, expr
);
150 gfc_evaluate_now (tree expr
, stmtblock_t
* pblock
)
152 return gfc_evaluate_now_loc (input_location
, expr
, pblock
);
156 /* Build a MODIFY_EXPR node and add it to a given statement block PBLOCK.
157 A MODIFY_EXPR is an assignment:
161 gfc_add_modify_loc (location_t loc
, stmtblock_t
* pblock
, tree lhs
, tree rhs
)
165 #ifdef ENABLE_CHECKING
167 t1
= TREE_TYPE (rhs
);
168 t2
= TREE_TYPE (lhs
);
169 /* Make sure that the types of the rhs and the lhs are the same
170 for scalar assignments. We should probably have something
171 similar for aggregates, but right now removing that check just
172 breaks everything. */
174 || AGGREGATE_TYPE_P (TREE_TYPE (lhs
)));
177 tmp
= fold_build2_loc (loc
, MODIFY_EXPR
, void_type_node
, lhs
,
179 gfc_add_expr_to_block (pblock
, tmp
);
184 gfc_add_modify (stmtblock_t
* pblock
, tree lhs
, tree rhs
)
186 gfc_add_modify_loc (input_location
, pblock
, lhs
, rhs
);
190 /* Create a new scope/binding level and initialize a block. Care must be
191 taken when translating expressions as any temporaries will be placed in
192 the innermost scope. */
195 gfc_start_block (stmtblock_t
* block
)
197 /* Start a new binding level. */
199 block
->has_scope
= 1;
201 /* The block is empty. */
202 block
->head
= NULL_TREE
;
206 /* Initialize a block without creating a new scope. */
209 gfc_init_block (stmtblock_t
* block
)
211 block
->head
= NULL_TREE
;
212 block
->has_scope
= 0;
216 /* Sometimes we create a scope but it turns out that we don't actually
217 need it. This function merges the scope of BLOCK with its parent.
218 Only variable decls will be merged, you still need to add the code. */
221 gfc_merge_block_scope (stmtblock_t
* block
)
226 gcc_assert (block
->has_scope
);
227 block
->has_scope
= 0;
229 /* Remember the decls in this scope. */
233 /* Add them to the parent scope. */
234 while (decl
!= NULL_TREE
)
236 next
= DECL_CHAIN (decl
);
237 DECL_CHAIN (decl
) = NULL_TREE
;
245 /* Finish a scope containing a block of statements. */
248 gfc_finish_block (stmtblock_t
* stmtblock
)
254 expr
= stmtblock
->head
;
256 expr
= build_empty_stmt (input_location
);
258 stmtblock
->head
= NULL_TREE
;
260 if (stmtblock
->has_scope
)
266 block
= poplevel (1, 0, 0);
267 expr
= build3_v (BIND_EXPR
, decl
, expr
, block
);
277 /* Build an ADDR_EXPR and cast the result to TYPE. If TYPE is NULL, the
278 natural type is used. */
281 gfc_build_addr_expr (tree type
, tree t
)
283 tree base_type
= TREE_TYPE (t
);
286 if (type
&& POINTER_TYPE_P (type
)
287 && TREE_CODE (base_type
) == ARRAY_TYPE
288 && TYPE_MAIN_VARIANT (TREE_TYPE (type
))
289 == TYPE_MAIN_VARIANT (TREE_TYPE (base_type
)))
291 tree min_val
= size_zero_node
;
292 tree type_domain
= TYPE_DOMAIN (base_type
);
293 if (type_domain
&& TYPE_MIN_VALUE (type_domain
))
294 min_val
= TYPE_MIN_VALUE (type_domain
);
295 t
= fold (build4_loc (input_location
, ARRAY_REF
, TREE_TYPE (type
),
296 t
, min_val
, NULL_TREE
, NULL_TREE
));
300 natural_type
= build_pointer_type (base_type
);
302 if (TREE_CODE (t
) == INDIRECT_REF
)
306 t
= TREE_OPERAND (t
, 0);
307 natural_type
= TREE_TYPE (t
);
311 tree base
= get_base_address (t
);
312 if (base
&& DECL_P (base
))
313 TREE_ADDRESSABLE (base
) = 1;
314 t
= fold_build1_loc (input_location
, ADDR_EXPR
, natural_type
, t
);
317 if (type
&& natural_type
!= type
)
318 t
= convert (type
, t
);
324 /* Build an ARRAY_REF with its natural type. */
327 gfc_build_array_ref (tree base
, tree offset
, tree decl
)
329 tree type
= TREE_TYPE (base
);
332 gcc_assert (TREE_CODE (type
) == ARRAY_TYPE
);
333 type
= TREE_TYPE (type
);
336 TREE_ADDRESSABLE (base
) = 1;
338 /* Strip NON_LVALUE_EXPR nodes. */
339 STRIP_TYPE_NOPS (offset
);
341 /* If the array reference is to a pointer, whose target contains a
342 subreference, use the span that is stored with the backend decl
343 and reference the element with pointer arithmetic. */
344 if (decl
&& (TREE_CODE (decl
) == FIELD_DECL
345 || TREE_CODE (decl
) == VAR_DECL
346 || TREE_CODE (decl
) == PARM_DECL
)
347 && GFC_DECL_SUBREF_ARRAY_P (decl
)
348 && !integer_zerop (GFC_DECL_SPAN(decl
)))
350 offset
= fold_build2_loc (input_location
, MULT_EXPR
,
351 gfc_array_index_type
,
352 offset
, GFC_DECL_SPAN(decl
));
353 tmp
= gfc_build_addr_expr (pvoid_type_node
, base
);
354 tmp
= fold_build2_loc (input_location
, POINTER_PLUS_EXPR
,
355 pvoid_type_node
, tmp
,
356 fold_convert (sizetype
, offset
));
357 tmp
= fold_convert (build_pointer_type (type
), tmp
);
358 if (!TYPE_STRING_FLAG (type
))
359 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
363 /* Otherwise use a straightforward array reference. */
364 return build4_loc (input_location
, ARRAY_REF
, type
, base
, offset
,
365 NULL_TREE
, NULL_TREE
);
369 /* Generate a call to print a runtime error possibly including multiple
370 arguments and a locus. */
373 trans_runtime_error_vararg (bool error
, locus
* where
, const char* msgid
,
386 /* Compute the number of extra arguments from the format string. */
387 for (p
= msgid
, nargs
= 0; *p
; p
++)
395 /* The code to generate the error. */
396 gfc_start_block (&block
);
400 line
= LOCATION_LINE (where
->lb
->location
);
401 asprintf (&message
, "At line %d of file %s", line
,
402 where
->lb
->file
->filename
);
405 asprintf (&message
, "In file '%s', around line %d",
406 gfc_source_file
, input_line
+ 1);
408 arg
= gfc_build_addr_expr (pchar_type_node
,
409 gfc_build_localized_cstring_const (message
));
412 asprintf (&message
, "%s", _(msgid
));
413 arg2
= gfc_build_addr_expr (pchar_type_node
,
414 gfc_build_localized_cstring_const (message
));
417 /* Build the argument array. */
418 argarray
= XALLOCAVEC (tree
, nargs
+ 2);
421 for (i
= 0; i
< nargs
; i
++)
422 argarray
[2 + i
] = va_arg (ap
, tree
);
424 /* Build the function call to runtime_(warning,error)_at; because of the
425 variable number of arguments, we can't use build_call_expr_loc dinput_location,
428 fntype
= TREE_TYPE (gfor_fndecl_runtime_error_at
);
430 fntype
= TREE_TYPE (gfor_fndecl_runtime_warning_at
);
432 loc
= where
? where
->lb
->location
: input_location
;
433 tmp
= fold_builtin_call_array (loc
, TREE_TYPE (fntype
),
434 fold_build1_loc (loc
, ADDR_EXPR
,
435 build_pointer_type (fntype
),
437 ? gfor_fndecl_runtime_error_at
438 : gfor_fndecl_runtime_warning_at
),
439 nargs
+ 2, argarray
);
440 gfc_add_expr_to_block (&block
, tmp
);
442 return gfc_finish_block (&block
);
447 gfc_trans_runtime_error (bool error
, locus
* where
, const char* msgid
, ...)
452 va_start (ap
, msgid
);
453 result
= trans_runtime_error_vararg (error
, where
, msgid
, ap
);
459 /* Generate a runtime error if COND is true. */
462 gfc_trans_runtime_check (bool error
, bool once
, tree cond
, stmtblock_t
* pblock
,
463 locus
* where
, const char * msgid
, ...)
471 if (integer_zerop (cond
))
476 tmpvar
= gfc_create_var (boolean_type_node
, "print_warning");
477 TREE_STATIC (tmpvar
) = 1;
478 DECL_INITIAL (tmpvar
) = boolean_true_node
;
479 gfc_add_expr_to_block (pblock
, tmpvar
);
482 gfc_start_block (&block
);
484 /* The code to generate the error. */
485 va_start (ap
, msgid
);
486 gfc_add_expr_to_block (&block
,
487 trans_runtime_error_vararg (error
, where
,
491 gfc_add_modify (&block
, tmpvar
, boolean_false_node
);
493 body
= gfc_finish_block (&block
);
495 if (integer_onep (cond
))
497 gfc_add_expr_to_block (pblock
, body
);
501 /* Tell the compiler that this isn't likely. */
503 cond
= fold_build2_loc (where
->lb
->location
, TRUTH_AND_EXPR
,
504 long_integer_type_node
, tmpvar
, cond
);
506 cond
= fold_convert (long_integer_type_node
, cond
);
508 tmp
= build_int_cst (long_integer_type_node
, 0);
509 cond
= build_call_expr_loc (where
->lb
->location
,
510 built_in_decls
[BUILT_IN_EXPECT
], 2, cond
, tmp
);
511 cond
= fold_convert (boolean_type_node
, cond
);
513 tmp
= fold_build3_loc (where
->lb
->location
, COND_EXPR
, void_type_node
,
515 build_empty_stmt (where
->lb
->location
));
516 gfc_add_expr_to_block (pblock
, tmp
);
521 /* Call malloc to allocate size bytes of memory, with special conditions:
522 + if size == 0, return a malloced area of size 1,
523 + if malloc returns NULL, issue a runtime error. */
525 gfc_call_malloc (stmtblock_t
* block
, tree type
, tree size
)
527 tree tmp
, msg
, malloc_result
, null_result
, res
;
530 size
= gfc_evaluate_now (size
, block
);
532 if (TREE_TYPE (size
) != TREE_TYPE (size_type_node
))
533 size
= fold_convert (size_type_node
, size
);
535 /* Create a variable to hold the result. */
536 res
= gfc_create_var (prvoid_type_node
, NULL
);
539 gfc_start_block (&block2
);
541 size
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
, size
,
542 build_int_cst (size_type_node
, 1));
544 gfc_add_modify (&block2
, res
,
545 fold_convert (prvoid_type_node
,
546 build_call_expr_loc (input_location
,
547 built_in_decls
[BUILT_IN_MALLOC
], 1, size
)));
549 /* Optionally check whether malloc was successful. */
550 if (gfc_option
.rtcheck
& GFC_RTCHECK_MEM
)
552 null_result
= fold_build2_loc (input_location
, EQ_EXPR
,
553 boolean_type_node
, res
,
554 build_int_cst (pvoid_type_node
, 0));
555 msg
= gfc_build_addr_expr (pchar_type_node
,
556 gfc_build_localized_cstring_const ("Memory allocation failed"));
557 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
559 build_call_expr_loc (input_location
,
560 gfor_fndecl_os_error
, 1, msg
),
561 build_empty_stmt (input_location
));
562 gfc_add_expr_to_block (&block2
, tmp
);
565 malloc_result
= gfc_finish_block (&block2
);
567 gfc_add_expr_to_block (block
, malloc_result
);
570 res
= fold_convert (type
, res
);
575 /* Allocate memory, using an optional status argument.
577 This function follows the following pseudo-code:
580 allocate (size_t size, integer_type* stat)
587 newmem = malloc (MAX (size, 1));
591 *stat = LIBERROR_ALLOCATION;
593 runtime_error ("Allocation would exceed memory limit");
598 gfc_allocate_with_status (stmtblock_t
* block
, tree size
, tree status
)
600 stmtblock_t alloc_block
;
601 tree res
, tmp
, msg
, cond
;
602 tree status_type
= status
? TREE_TYPE (TREE_TYPE (status
)) : NULL_TREE
;
604 /* Evaluate size only once, and make sure it has the right type. */
605 size
= gfc_evaluate_now (size
, block
);
606 if (TREE_TYPE (size
) != TREE_TYPE (size_type_node
))
607 size
= fold_convert (size_type_node
, size
);
609 /* Create a variable to hold the result. */
610 res
= gfc_create_var (prvoid_type_node
, NULL
);
612 /* Set the optional status variable to zero. */
613 if (status
!= NULL_TREE
&& !integer_zerop (status
))
615 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
616 fold_build1_loc (input_location
, INDIRECT_REF
,
617 status_type
, status
),
618 build_int_cst (status_type
, 0));
619 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
620 fold_build2_loc (input_location
, NE_EXPR
,
621 boolean_type_node
, status
,
622 build_int_cst (TREE_TYPE (status
), 0)),
623 tmp
, build_empty_stmt (input_location
));
624 gfc_add_expr_to_block (block
, tmp
);
627 /* The allocation itself. */
628 gfc_start_block (&alloc_block
);
629 gfc_add_modify (&alloc_block
, res
,
630 fold_convert (prvoid_type_node
,
631 build_call_expr_loc (input_location
,
632 built_in_decls
[BUILT_IN_MALLOC
], 1,
633 fold_build2_loc (input_location
,
634 MAX_EXPR
, size_type_node
, size
,
635 build_int_cst (size_type_node
,
638 msg
= gfc_build_addr_expr (pchar_type_node
, gfc_build_localized_cstring_const
639 ("Allocation would exceed memory limit"));
640 tmp
= build_call_expr_loc (input_location
,
641 gfor_fndecl_os_error
, 1, msg
);
643 if (status
!= NULL_TREE
&& !integer_zerop (status
))
645 /* Set the status variable if it's present. */
648 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
649 status
, build_int_cst (TREE_TYPE (status
), 0));
650 tmp2
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
651 fold_build1_loc (input_location
, INDIRECT_REF
,
652 status_type
, status
),
653 build_int_cst (status_type
, LIBERROR_ALLOCATION
));
654 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
658 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
659 fold_build2_loc (input_location
, EQ_EXPR
,
660 boolean_type_node
, res
,
661 build_int_cst (prvoid_type_node
, 0)),
662 tmp
, build_empty_stmt (input_location
));
663 gfc_add_expr_to_block (&alloc_block
, tmp
);
664 gfc_add_expr_to_block (block
, gfc_finish_block (&alloc_block
));
670 /* Generate code for an ALLOCATE statement when the argument is an
671 allocatable array. If the array is currently allocated, it is an
672 error to allocate it again.
674 This function follows the following pseudo-code:
677 allocate_array (void *mem, size_t size, integer_type *stat)
680 return allocate (size, stat);
686 mem = allocate (size, stat);
687 *stat = LIBERROR_ALLOCATION;
691 runtime_error ("Attempting to allocate already allocated variable");
695 expr must be set to the original expression being allocated for its locus
696 and variable name in case a runtime error has to be printed. */
698 gfc_allocate_array_with_status (stmtblock_t
* block
, tree mem
, tree size
,
699 tree status
, gfc_expr
* expr
)
701 stmtblock_t alloc_block
;
702 tree res
, tmp
, null_mem
, alloc
, error
;
703 tree type
= TREE_TYPE (mem
);
705 if (TREE_TYPE (size
) != TREE_TYPE (size_type_node
))
706 size
= fold_convert (size_type_node
, size
);
708 /* Create a variable to hold the result. */
709 res
= gfc_create_var (type
, NULL
);
710 null_mem
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, mem
,
711 build_int_cst (type
, 0));
713 /* If mem is NULL, we call gfc_allocate_with_status. */
714 gfc_start_block (&alloc_block
);
715 tmp
= gfc_allocate_with_status (&alloc_block
, size
, status
);
716 gfc_add_modify (&alloc_block
, res
, fold_convert (type
, tmp
));
717 alloc
= gfc_finish_block (&alloc_block
);
719 /* Otherwise, we issue a runtime error or set the status variable. */
724 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
&& expr
->symtree
);
725 varname
= gfc_build_cstring_const (expr
->symtree
->name
);
726 varname
= gfc_build_addr_expr (pchar_type_node
, varname
);
728 error
= gfc_trans_runtime_error (true, &expr
->where
,
729 "Attempting to allocate already"
730 " allocated variable '%s'",
734 error
= gfc_trans_runtime_error (true, NULL
,
735 "Attempting to allocate already allocated"
738 if (status
!= NULL_TREE
&& !integer_zerop (status
))
740 tree status_type
= TREE_TYPE (TREE_TYPE (status
));
741 stmtblock_t set_status_block
;
743 gfc_start_block (&set_status_block
);
744 tmp
= build_call_expr_loc (input_location
,
745 built_in_decls
[BUILT_IN_FREE
], 1,
746 fold_convert (pvoid_type_node
, mem
));
747 gfc_add_expr_to_block (&set_status_block
, tmp
);
749 tmp
= gfc_allocate_with_status (&set_status_block
, size
, status
);
750 gfc_add_modify (&set_status_block
, res
, fold_convert (type
, tmp
));
752 gfc_add_modify (&set_status_block
,
753 fold_build1_loc (input_location
, INDIRECT_REF
,
754 status_type
, status
),
755 build_int_cst (status_type
, LIBERROR_ALLOCATION
));
757 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
758 status
, build_int_cst (status_type
, 0));
759 error
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, tmp
,
760 error
, gfc_finish_block (&set_status_block
));
763 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, null_mem
,
765 gfc_add_expr_to_block (block
, tmp
);
771 /* Free a given variable, if it's not NULL. */
773 gfc_call_free (tree var
)
776 tree tmp
, cond
, call
;
778 if (TREE_TYPE (var
) != TREE_TYPE (pvoid_type_node
))
779 var
= fold_convert (pvoid_type_node
, var
);
781 gfc_start_block (&block
);
782 var
= gfc_evaluate_now (var
, &block
);
783 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, var
,
784 build_int_cst (pvoid_type_node
, 0));
785 call
= build_call_expr_loc (input_location
,
786 built_in_decls
[BUILT_IN_FREE
], 1, var
);
787 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, call
,
788 build_empty_stmt (input_location
));
789 gfc_add_expr_to_block (&block
, tmp
);
791 return gfc_finish_block (&block
);
796 /* User-deallocate; we emit the code directly from the front-end, and the
797 logic is the same as the previous library function:
800 deallocate (void *pointer, GFC_INTEGER_4 * stat)
807 runtime_error ("Attempt to DEALLOCATE unallocated memory.");
817 In this front-end version, status doesn't have to be GFC_INTEGER_4.
818 Moreover, if CAN_FAIL is true, then we will not emit a runtime error,
819 even when no status variable is passed to us (this is used for
820 unconditional deallocation generated by the front-end at end of
823 If a runtime-message is possible, `expr' must point to the original
824 expression being deallocated for its locus and variable name. */
826 gfc_deallocate_with_status (tree pointer
, tree status
, bool can_fail
,
829 stmtblock_t null
, non_null
;
830 tree cond
, tmp
, error
;
832 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, pointer
,
833 build_int_cst (TREE_TYPE (pointer
), 0));
835 /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
836 we emit a runtime error. */
837 gfc_start_block (&null
);
842 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
&& expr
->symtree
);
844 varname
= gfc_build_cstring_const (expr
->symtree
->name
);
845 varname
= gfc_build_addr_expr (pchar_type_node
, varname
);
847 error
= gfc_trans_runtime_error (true, &expr
->where
,
848 "Attempt to DEALLOCATE unallocated '%s'",
852 error
= build_empty_stmt (input_location
);
854 if (status
!= NULL_TREE
&& !integer_zerop (status
))
856 tree status_type
= TREE_TYPE (TREE_TYPE (status
));
859 cond2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
860 status
, build_int_cst (TREE_TYPE (status
), 0));
861 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
862 fold_build1_loc (input_location
, INDIRECT_REF
,
863 status_type
, status
),
864 build_int_cst (status_type
, 1));
865 error
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
869 gfc_add_expr_to_block (&null
, error
);
871 /* When POINTER is not NULL, we free it. */
872 gfc_start_block (&non_null
);
873 tmp
= build_call_expr_loc (input_location
,
874 built_in_decls
[BUILT_IN_FREE
], 1,
875 fold_convert (pvoid_type_node
, pointer
));
876 gfc_add_expr_to_block (&non_null
, tmp
);
878 if (status
!= NULL_TREE
&& !integer_zerop (status
))
880 /* We set STATUS to zero if it is present. */
881 tree status_type
= TREE_TYPE (TREE_TYPE (status
));
884 cond2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
885 status
, build_int_cst (TREE_TYPE (status
), 0));
886 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
887 fold_build1_loc (input_location
, INDIRECT_REF
,
888 status_type
, status
),
889 build_int_cst (status_type
, 0));
890 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
891 tmp
, build_empty_stmt (input_location
));
892 gfc_add_expr_to_block (&non_null
, tmp
);
895 return fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
896 gfc_finish_block (&null
),
897 gfc_finish_block (&non_null
));
901 /* Generate code for deallocation of allocatable scalars (variables or
902 components). Before the object itself is freed, any allocatable
903 subcomponents are being deallocated. */
906 gfc_deallocate_scalar_with_status (tree pointer
, tree status
, bool can_fail
,
907 gfc_expr
* expr
, gfc_typespec ts
)
909 stmtblock_t null
, non_null
;
910 tree cond
, tmp
, error
;
912 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, pointer
,
913 build_int_cst (TREE_TYPE (pointer
), 0));
915 /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
916 we emit a runtime error. */
917 gfc_start_block (&null
);
922 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
&& expr
->symtree
);
924 varname
= gfc_build_cstring_const (expr
->symtree
->name
);
925 varname
= gfc_build_addr_expr (pchar_type_node
, varname
);
927 error
= gfc_trans_runtime_error (true, &expr
->where
,
928 "Attempt to DEALLOCATE unallocated '%s'",
932 error
= build_empty_stmt (input_location
);
934 if (status
!= NULL_TREE
&& !integer_zerop (status
))
936 tree status_type
= TREE_TYPE (TREE_TYPE (status
));
939 cond2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
940 status
, build_int_cst (TREE_TYPE (status
), 0));
941 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
942 fold_build1_loc (input_location
, INDIRECT_REF
,
943 status_type
, status
),
944 build_int_cst (status_type
, 1));
945 error
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
949 gfc_add_expr_to_block (&null
, error
);
951 /* When POINTER is not NULL, we free it. */
952 gfc_start_block (&non_null
);
954 /* Free allocatable components. */
955 if (ts
.type
== BT_DERIVED
&& ts
.u
.derived
->attr
.alloc_comp
)
957 tmp
= build_fold_indirect_ref_loc (input_location
, pointer
);
958 tmp
= gfc_deallocate_alloc_comp (ts
.u
.derived
, tmp
, 0);
959 gfc_add_expr_to_block (&non_null
, tmp
);
961 else if (ts
.type
== BT_CLASS
962 && ts
.u
.derived
->components
->ts
.u
.derived
->attr
.alloc_comp
)
964 tmp
= build_fold_indirect_ref_loc (input_location
, pointer
);
965 tmp
= gfc_deallocate_alloc_comp (ts
.u
.derived
->components
->ts
.u
.derived
,
967 gfc_add_expr_to_block (&non_null
, tmp
);
970 tmp
= build_call_expr_loc (input_location
,
971 built_in_decls
[BUILT_IN_FREE
], 1,
972 fold_convert (pvoid_type_node
, pointer
));
973 gfc_add_expr_to_block (&non_null
, tmp
);
975 if (status
!= NULL_TREE
&& !integer_zerop (status
))
977 /* We set STATUS to zero if it is present. */
978 tree status_type
= TREE_TYPE (TREE_TYPE (status
));
981 cond2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
982 status
, build_int_cst (TREE_TYPE (status
), 0));
983 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
984 fold_build1_loc (input_location
, INDIRECT_REF
,
985 status_type
, status
),
986 build_int_cst (status_type
, 0));
987 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
988 tmp
, build_empty_stmt (input_location
));
989 gfc_add_expr_to_block (&non_null
, tmp
);
992 return fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
993 gfc_finish_block (&null
),
994 gfc_finish_block (&non_null
));
998 /* Reallocate MEM so it has SIZE bytes of data. This behaves like the
999 following pseudo-code:
1002 internal_realloc (void *mem, size_t size)
1004 res = realloc (mem, size);
1005 if (!res && size != 0)
1006 _gfortran_os_error ("Allocation would exceed memory limit");
1014 gfc_call_realloc (stmtblock_t
* block
, tree mem
, tree size
)
1016 tree msg
, res
, nonzero
, zero
, null_result
, tmp
;
1017 tree type
= TREE_TYPE (mem
);
1019 size
= gfc_evaluate_now (size
, block
);
1021 if (TREE_TYPE (size
) != TREE_TYPE (size_type_node
))
1022 size
= fold_convert (size_type_node
, size
);
1024 /* Create a variable to hold the result. */
1025 res
= gfc_create_var (type
, NULL
);
1027 /* Call realloc and check the result. */
1028 tmp
= build_call_expr_loc (input_location
,
1029 built_in_decls
[BUILT_IN_REALLOC
], 2,
1030 fold_convert (pvoid_type_node
, mem
), size
);
1031 gfc_add_modify (block
, res
, fold_convert (type
, tmp
));
1032 null_result
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1033 res
, build_int_cst (pvoid_type_node
, 0));
1034 nonzero
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, size
,
1035 build_int_cst (size_type_node
, 0));
1036 null_result
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, boolean_type_node
,
1037 null_result
, nonzero
);
1038 msg
= gfc_build_addr_expr (pchar_type_node
, gfc_build_localized_cstring_const
1039 ("Allocation would exceed memory limit"));
1040 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1042 build_call_expr_loc (input_location
,
1043 gfor_fndecl_os_error
, 1, msg
),
1044 build_empty_stmt (input_location
));
1045 gfc_add_expr_to_block (block
, tmp
);
1047 /* if (size == 0) then the result is NULL. */
1048 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, type
, res
,
1049 build_int_cst (type
, 0));
1050 zero
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
, boolean_type_node
,
1052 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, zero
, tmp
,
1053 build_empty_stmt (input_location
));
1054 gfc_add_expr_to_block (block
, tmp
);
1060 /* Add an expression to another one, either at the front or the back. */
1063 add_expr_to_chain (tree
* chain
, tree expr
, bool front
)
1065 if (expr
== NULL_TREE
|| IS_EMPTY_STMT (expr
))
1070 if (TREE_CODE (*chain
) != STATEMENT_LIST
)
1076 append_to_statement_list (tmp
, chain
);
1081 tree_stmt_iterator i
;
1083 i
= tsi_start (*chain
);
1084 tsi_link_before (&i
, expr
, TSI_CONTINUE_LINKING
);
1087 append_to_statement_list (expr
, chain
);
1094 /* Add a statement at the end of a block. */
1097 gfc_add_expr_to_block (stmtblock_t
* block
, tree expr
)
1100 add_expr_to_chain (&block
->head
, expr
, false);
1104 /* Add a statement at the beginning of a block. */
1107 gfc_prepend_expr_to_block (stmtblock_t
* block
, tree expr
)
1110 add_expr_to_chain (&block
->head
, expr
, true);
1114 /* Add a block the end of a block. */
1117 gfc_add_block_to_block (stmtblock_t
* block
, stmtblock_t
* append
)
1119 gcc_assert (append
);
1120 gcc_assert (!append
->has_scope
);
1122 gfc_add_expr_to_block (block
, append
->head
);
1123 append
->head
= NULL_TREE
;
1127 /* Save the current locus. The structure may not be complete, and should
1128 only be used with gfc_restore_backend_locus. */
1131 gfc_save_backend_locus (locus
* loc
)
1133 loc
->lb
= XCNEW (gfc_linebuf
);
1134 loc
->lb
->location
= input_location
;
1135 loc
->lb
->file
= gfc_current_backend_file
;
1139 /* Set the current locus. */
1142 gfc_set_backend_locus (locus
* loc
)
1144 gfc_current_backend_file
= loc
->lb
->file
;
1145 input_location
= loc
->lb
->location
;
1149 /* Restore the saved locus. Only used in conjonction with
1150 gfc_save_backend_locus, to free the memory when we are done. */
1153 gfc_restore_backend_locus (locus
* loc
)
1155 gfc_set_backend_locus (loc
);
1160 /* Translate an executable statement. The tree cond is used by gfc_trans_do.
1161 This static function is wrapped by gfc_trans_code_cond and
1165 trans_code (gfc_code
* code
, tree cond
)
1171 return build_empty_stmt (input_location
);
1173 gfc_start_block (&block
);
1175 /* Translate statements one by one into GENERIC trees until we reach
1176 the end of this gfc_code branch. */
1177 for (; code
; code
= code
->next
)
1179 if (code
->here
!= 0)
1181 res
= gfc_trans_label_here (code
);
1182 gfc_add_expr_to_block (&block
, res
);
1185 gfc_set_backend_locus (&code
->loc
);
1190 case EXEC_END_BLOCK
:
1191 case EXEC_END_PROCEDURE
:
1196 if (code
->expr1
->ts
.type
== BT_CLASS
)
1197 res
= gfc_trans_class_assign (code
->expr1
, code
->expr2
, code
->op
);
1199 res
= gfc_trans_assign (code
);
1202 case EXEC_LABEL_ASSIGN
:
1203 res
= gfc_trans_label_assign (code
);
1206 case EXEC_POINTER_ASSIGN
:
1207 if (code
->expr1
->ts
.type
== BT_CLASS
)
1208 res
= gfc_trans_class_assign (code
->expr1
, code
->expr2
, code
->op
);
1210 res
= gfc_trans_pointer_assign (code
);
1213 case EXEC_INIT_ASSIGN
:
1214 if (code
->expr1
->ts
.type
== BT_CLASS
)
1215 res
= gfc_trans_class_init_assign (code
);
1217 res
= gfc_trans_init_assign (code
);
1225 res
= gfc_trans_critical (code
);
1229 res
= gfc_trans_cycle (code
);
1233 res
= gfc_trans_exit (code
);
1237 res
= gfc_trans_goto (code
);
1241 res
= gfc_trans_entry (code
);
1245 res
= gfc_trans_pause (code
);
1249 case EXEC_ERROR_STOP
:
1250 res
= gfc_trans_stop (code
, code
->op
== EXEC_ERROR_STOP
);
1254 /* For MVBITS we've got the special exception that we need a
1255 dependency check, too. */
1257 bool is_mvbits
= false;
1258 if (code
->resolved_isym
1259 && code
->resolved_isym
->id
== GFC_ISYM_MVBITS
)
1261 if (code
->resolved_isym
1262 && code
->resolved_isym
->id
== GFC_ISYM_MOVE_ALLOC
)
1263 res
= gfc_conv_intrinsic_move_alloc (code
);
1265 res
= gfc_trans_call (code
, is_mvbits
, NULL_TREE
,
1271 res
= gfc_trans_call (code
, false, NULL_TREE
,
1275 case EXEC_ASSIGN_CALL
:
1276 res
= gfc_trans_call (code
, true, NULL_TREE
,
1281 res
= gfc_trans_return (code
);
1285 res
= gfc_trans_if (code
);
1288 case EXEC_ARITHMETIC_IF
:
1289 res
= gfc_trans_arithmetic_if (code
);
1293 res
= gfc_trans_block_construct (code
);
1297 res
= gfc_trans_do (code
, cond
);
1301 res
= gfc_trans_do_while (code
);
1305 res
= gfc_trans_select (code
);
1308 case EXEC_SELECT_TYPE
:
1309 /* Do nothing. SELECT TYPE statements should be transformed into
1310 an ordinary SELECT CASE at resolution stage.
1311 TODO: Add an error message here once this is done. */
1316 res
= gfc_trans_flush (code
);
1320 case EXEC_SYNC_IMAGES
:
1321 case EXEC_SYNC_MEMORY
:
1322 res
= gfc_trans_sync (code
, code
->op
);
1326 res
= gfc_trans_forall (code
);
1330 res
= gfc_trans_where (code
);
1334 res
= gfc_trans_allocate (code
);
1337 case EXEC_DEALLOCATE
:
1338 res
= gfc_trans_deallocate (code
);
1342 res
= gfc_trans_open (code
);
1346 res
= gfc_trans_close (code
);
1350 res
= gfc_trans_read (code
);
1354 res
= gfc_trans_write (code
);
1358 res
= gfc_trans_iolength (code
);
1361 case EXEC_BACKSPACE
:
1362 res
= gfc_trans_backspace (code
);
1366 res
= gfc_trans_endfile (code
);
1370 res
= gfc_trans_inquire (code
);
1374 res
= gfc_trans_wait (code
);
1378 res
= gfc_trans_rewind (code
);
1382 res
= gfc_trans_transfer (code
);
1386 res
= gfc_trans_dt_end (code
);
1389 case EXEC_OMP_ATOMIC
:
1390 case EXEC_OMP_BARRIER
:
1391 case EXEC_OMP_CRITICAL
:
1393 case EXEC_OMP_FLUSH
:
1394 case EXEC_OMP_MASTER
:
1395 case EXEC_OMP_ORDERED
:
1396 case EXEC_OMP_PARALLEL
:
1397 case EXEC_OMP_PARALLEL_DO
:
1398 case EXEC_OMP_PARALLEL_SECTIONS
:
1399 case EXEC_OMP_PARALLEL_WORKSHARE
:
1400 case EXEC_OMP_SECTIONS
:
1401 case EXEC_OMP_SINGLE
:
1403 case EXEC_OMP_TASKWAIT
:
1404 case EXEC_OMP_WORKSHARE
:
1405 res
= gfc_trans_omp_directive (code
);
1409 internal_error ("gfc_trans_code(): Bad statement code");
1412 gfc_set_backend_locus (&code
->loc
);
1414 if (res
!= NULL_TREE
&& ! IS_EMPTY_STMT (res
))
1416 if (TREE_CODE (res
) != STATEMENT_LIST
)
1417 SET_EXPR_LOCATION (res
, input_location
);
1419 /* Add the new statement to the block. */
1420 gfc_add_expr_to_block (&block
, res
);
1424 /* Return the finished block. */
1425 return gfc_finish_block (&block
);
1429 /* Translate an executable statement with condition, cond. The condition is
1430 used by gfc_trans_do to test for IO result conditions inside implied
1431 DO loops of READ and WRITE statements. See build_dt in trans-io.c. */
1434 gfc_trans_code_cond (gfc_code
* code
, tree cond
)
1436 return trans_code (code
, cond
);
1439 /* Translate an executable statement without condition. */
1442 gfc_trans_code (gfc_code
* code
)
1444 return trans_code (code
, NULL_TREE
);
1448 /* This function is called after a complete program unit has been parsed
1452 gfc_generate_code (gfc_namespace
* ns
)
1455 if (ns
->is_block_data
)
1457 gfc_generate_block_data (ns
);
1461 gfc_generate_function_code (ns
);
1465 /* This function is called after a complete module has been parsed
1469 gfc_generate_module_code (gfc_namespace
* ns
)
1472 struct module_htab_entry
*entry
;
1474 gcc_assert (ns
->proc_name
->backend_decl
== NULL
);
1475 ns
->proc_name
->backend_decl
1476 = build_decl (ns
->proc_name
->declared_at
.lb
->location
,
1477 NAMESPACE_DECL
, get_identifier (ns
->proc_name
->name
),
1479 entry
= gfc_find_module (ns
->proc_name
->name
);
1480 if (entry
->namespace_decl
)
1481 /* Buggy sourcecode, using a module before defining it? */
1482 htab_empty (entry
->decls
);
1483 entry
->namespace_decl
= ns
->proc_name
->backend_decl
;
1485 gfc_generate_module_vars (ns
);
1487 /* We need to generate all module function prototypes first, to allow
1489 for (n
= ns
->contained
; n
; n
= n
->sibling
)
1496 gfc_create_function_decl (n
, false);
1497 DECL_CONTEXT (n
->proc_name
->backend_decl
) = ns
->proc_name
->backend_decl
;
1498 gfc_module_add_decl (entry
, n
->proc_name
->backend_decl
);
1499 for (el
= ns
->entries
; el
; el
= el
->next
)
1501 DECL_CONTEXT (el
->sym
->backend_decl
) = ns
->proc_name
->backend_decl
;
1502 gfc_module_add_decl (entry
, el
->sym
->backend_decl
);
1506 for (n
= ns
->contained
; n
; n
= n
->sibling
)
1511 gfc_generate_function_code (n
);
1516 /* Initialize an init/cleanup block with existing code. */
1519 gfc_start_wrapped_block (gfc_wrapped_block
* block
, tree code
)
1523 block
->init
= NULL_TREE
;
1525 block
->cleanup
= NULL_TREE
;
1529 /* Add a new pair of initializers/clean-up code. */
1532 gfc_add_init_cleanup (gfc_wrapped_block
* block
, tree init
, tree cleanup
)
1536 /* The new pair of init/cleanup should be "wrapped around" the existing
1537 block of code, thus the initialization is added to the front and the
1538 cleanup to the back. */
1539 add_expr_to_chain (&block
->init
, init
, true);
1540 add_expr_to_chain (&block
->cleanup
, cleanup
, false);
1544 /* Finish up a wrapped block by building a corresponding try-finally expr. */
1547 gfc_finish_wrapped_block (gfc_wrapped_block
* block
)
1553 /* Build the final expression. For this, just add init and body together,
1554 and put clean-up with that into a TRY_FINALLY_EXPR. */
1555 result
= block
->init
;
1556 add_expr_to_chain (&result
, block
->code
, false);
1558 result
= build2_loc (input_location
, TRY_FINALLY_EXPR
, void_type_node
,
1559 result
, block
->cleanup
);
1561 /* Clear the block. */
1562 block
->init
= NULL_TREE
;
1563 block
->code
= NULL_TREE
;
1564 block
->cleanup
= NULL_TREE
;