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 "toplev.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 (tree expr
, stmtblock_t
* pblock
)
139 if (CONSTANT_CLASS_P (expr
))
142 var
= gfc_create_var (TREE_TYPE (expr
), NULL
);
143 gfc_add_modify (pblock
, var
, expr
);
149 /* Build a MODIFY_EXPR node and add it to a given statement block PBLOCK.
150 A MODIFY_EXPR is an assignment:
154 gfc_add_modify (stmtblock_t
* pblock
, tree lhs
, tree rhs
)
158 #ifdef ENABLE_CHECKING
160 t1
= TREE_TYPE (rhs
);
161 t2
= TREE_TYPE (lhs
);
162 /* Make sure that the types of the rhs and the lhs are the same
163 for scalar assignments. We should probably have something
164 similar for aggregates, but right now removing that check just
165 breaks everything. */
167 || AGGREGATE_TYPE_P (TREE_TYPE (lhs
)));
170 tmp
= fold_build2 (MODIFY_EXPR
, void_type_node
, lhs
, rhs
);
171 gfc_add_expr_to_block (pblock
, tmp
);
175 /* Create a new scope/binding level and initialize a block. Care must be
176 taken when translating expressions as any temporaries will be placed in
177 the innermost scope. */
180 gfc_start_block (stmtblock_t
* block
)
182 /* Start a new binding level. */
184 block
->has_scope
= 1;
186 /* The block is empty. */
187 block
->head
= NULL_TREE
;
191 /* Initialize a block without creating a new scope. */
194 gfc_init_block (stmtblock_t
* block
)
196 block
->head
= NULL_TREE
;
197 block
->has_scope
= 0;
201 /* Sometimes we create a scope but it turns out that we don't actually
202 need it. This function merges the scope of BLOCK with its parent.
203 Only variable decls will be merged, you still need to add the code. */
206 gfc_merge_block_scope (stmtblock_t
* block
)
211 gcc_assert (block
->has_scope
);
212 block
->has_scope
= 0;
214 /* Remember the decls in this scope. */
218 /* Add them to the parent scope. */
219 while (decl
!= NULL_TREE
)
221 next
= TREE_CHAIN (decl
);
222 TREE_CHAIN (decl
) = NULL_TREE
;
230 /* Finish a scope containing a block of statements. */
233 gfc_finish_block (stmtblock_t
* stmtblock
)
239 expr
= stmtblock
->head
;
241 expr
= build_empty_stmt (input_location
);
243 stmtblock
->head
= NULL_TREE
;
245 if (stmtblock
->has_scope
)
251 block
= poplevel (1, 0, 0);
252 expr
= build3_v (BIND_EXPR
, decl
, expr
, block
);
262 /* Build an ADDR_EXPR and cast the result to TYPE. If TYPE is NULL, the
263 natural type is used. */
266 gfc_build_addr_expr (tree type
, tree t
)
268 tree base_type
= TREE_TYPE (t
);
271 if (type
&& POINTER_TYPE_P (type
)
272 && TREE_CODE (base_type
) == ARRAY_TYPE
273 && TYPE_MAIN_VARIANT (TREE_TYPE (type
))
274 == TYPE_MAIN_VARIANT (TREE_TYPE (base_type
)))
276 tree min_val
= size_zero_node
;
277 tree type_domain
= TYPE_DOMAIN (base_type
);
278 if (type_domain
&& TYPE_MIN_VALUE (type_domain
))
279 min_val
= TYPE_MIN_VALUE (type_domain
);
280 t
= fold (build4 (ARRAY_REF
, TREE_TYPE (type
),
281 t
, min_val
, NULL_TREE
, NULL_TREE
));
285 natural_type
= build_pointer_type (base_type
);
287 if (TREE_CODE (t
) == INDIRECT_REF
)
291 t
= TREE_OPERAND (t
, 0);
292 natural_type
= TREE_TYPE (t
);
296 tree base
= get_base_address (t
);
297 if (base
&& DECL_P (base
))
298 TREE_ADDRESSABLE (base
) = 1;
299 t
= fold_build1 (ADDR_EXPR
, natural_type
, t
);
302 if (type
&& natural_type
!= type
)
303 t
= convert (type
, t
);
309 /* Build an ARRAY_REF with its natural type. */
312 gfc_build_array_ref (tree base
, tree offset
, tree decl
)
314 tree type
= TREE_TYPE (base
);
317 gcc_assert (TREE_CODE (type
) == ARRAY_TYPE
);
318 type
= TREE_TYPE (type
);
321 TREE_ADDRESSABLE (base
) = 1;
323 /* Strip NON_LVALUE_EXPR nodes. */
324 STRIP_TYPE_NOPS (offset
);
326 /* If the array reference is to a pointer, whose target contains a
327 subreference, use the span that is stored with the backend decl
328 and reference the element with pointer arithmetic. */
329 if (decl
&& (TREE_CODE (decl
) == FIELD_DECL
330 || TREE_CODE (decl
) == VAR_DECL
331 || TREE_CODE (decl
) == PARM_DECL
)
332 && GFC_DECL_SUBREF_ARRAY_P (decl
)
333 && !integer_zerop (GFC_DECL_SPAN(decl
)))
335 offset
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
336 offset
, GFC_DECL_SPAN(decl
));
337 tmp
= gfc_build_addr_expr (pvoid_type_node
, base
);
338 tmp
= fold_build2 (POINTER_PLUS_EXPR
, pvoid_type_node
,
339 tmp
, fold_convert (sizetype
, offset
));
340 tmp
= fold_convert (build_pointer_type (type
), tmp
);
341 if (!TYPE_STRING_FLAG (type
))
342 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
346 /* Otherwise use a straightforward array reference. */
347 return build4 (ARRAY_REF
, type
, base
, offset
, NULL_TREE
, NULL_TREE
);
351 /* Generate a call to print a runtime error possibly including multiple
352 arguments and a locus. */
355 gfc_trans_runtime_error (bool error
, locus
* where
, const char* msgid
, ...)
359 va_start (ap
, msgid
);
360 return gfc_trans_runtime_error_vararg (error
, where
, msgid
, ap
);
364 gfc_trans_runtime_error_vararg (bool error
, locus
* where
, const char* msgid
,
376 /* Compute the number of extra arguments from the format string. */
377 for (p
= msgid
, nargs
= 0; *p
; p
++)
385 /* The code to generate the error. */
386 gfc_start_block (&block
);
390 line
= LOCATION_LINE (where
->lb
->location
);
391 asprintf (&message
, "At line %d of file %s", line
,
392 where
->lb
->file
->filename
);
395 asprintf (&message
, "In file '%s', around line %d",
396 gfc_source_file
, input_line
+ 1);
398 arg
= gfc_build_addr_expr (pchar_type_node
,
399 gfc_build_localized_cstring_const (message
));
402 asprintf (&message
, "%s", _(msgid
));
403 arg2
= gfc_build_addr_expr (pchar_type_node
,
404 gfc_build_localized_cstring_const (message
));
407 /* Build the argument array. */
408 argarray
= (tree
*) alloca (sizeof (tree
) * (nargs
+ 2));
411 for (i
= 0; i
< nargs
; i
++)
412 argarray
[2 + i
] = va_arg (ap
, tree
);
415 /* Build the function call to runtime_(warning,error)_at; because of the
416 variable number of arguments, we can't use build_call_expr_loc dinput_location,
419 fntype
= TREE_TYPE (gfor_fndecl_runtime_error_at
);
421 fntype
= TREE_TYPE (gfor_fndecl_runtime_warning_at
);
423 tmp
= fold_builtin_call_array (input_location
, TREE_TYPE (fntype
),
424 fold_build1 (ADDR_EXPR
,
425 build_pointer_type (fntype
),
427 ? gfor_fndecl_runtime_error_at
428 : gfor_fndecl_runtime_warning_at
),
429 nargs
+ 2, argarray
);
430 gfc_add_expr_to_block (&block
, tmp
);
432 return gfc_finish_block (&block
);
436 /* Generate a runtime error if COND is true. */
439 gfc_trans_runtime_check (bool error
, bool once
, tree cond
, stmtblock_t
* pblock
,
440 locus
* where
, const char * msgid
, ...)
448 if (integer_zerop (cond
))
453 tmpvar
= gfc_create_var (boolean_type_node
, "print_warning");
454 TREE_STATIC (tmpvar
) = 1;
455 DECL_INITIAL (tmpvar
) = boolean_true_node
;
456 gfc_add_expr_to_block (pblock
, tmpvar
);
459 gfc_start_block (&block
);
461 /* The code to generate the error. */
462 va_start (ap
, msgid
);
463 gfc_add_expr_to_block (&block
,
464 gfc_trans_runtime_error_vararg (error
, where
,
468 gfc_add_modify (&block
, tmpvar
, boolean_false_node
);
470 body
= gfc_finish_block (&block
);
472 if (integer_onep (cond
))
474 gfc_add_expr_to_block (pblock
, body
);
478 /* Tell the compiler that this isn't likely. */
480 cond
= fold_build2 (TRUTH_AND_EXPR
, long_integer_type_node
, tmpvar
,
483 cond
= fold_convert (long_integer_type_node
, cond
);
485 tmp
= build_int_cst (long_integer_type_node
, 0);
486 cond
= build_call_expr_loc (input_location
,
487 built_in_decls
[BUILT_IN_EXPECT
], 2, cond
, tmp
);
488 cond
= fold_convert (boolean_type_node
, cond
);
490 tmp
= build3_v (COND_EXPR
, cond
, body
, build_empty_stmt (input_location
));
491 gfc_add_expr_to_block (pblock
, tmp
);
496 /* Call malloc to allocate size bytes of memory, with special conditions:
497 + if size <= 0, return a malloced area of size 1,
498 + if malloc returns NULL, issue a runtime error. */
500 gfc_call_malloc (stmtblock_t
* block
, tree type
, tree size
)
502 tree tmp
, msg
, malloc_result
, null_result
, res
;
505 size
= gfc_evaluate_now (size
, block
);
507 if (TREE_TYPE (size
) != TREE_TYPE (size_type_node
))
508 size
= fold_convert (size_type_node
, size
);
510 /* Create a variable to hold the result. */
511 res
= gfc_create_var (prvoid_type_node
, NULL
);
514 gfc_start_block (&block2
);
516 size
= fold_build2 (MAX_EXPR
, size_type_node
, size
,
517 build_int_cst (size_type_node
, 1));
519 gfc_add_modify (&block2
, res
,
520 fold_convert (prvoid_type_node
,
521 build_call_expr_loc (input_location
,
522 built_in_decls
[BUILT_IN_MALLOC
], 1, size
)));
524 /* Optionally check whether malloc was successful. */
525 if (gfc_option
.rtcheck
& GFC_RTCHECK_MEM
)
527 null_result
= fold_build2 (EQ_EXPR
, boolean_type_node
, res
,
528 build_int_cst (pvoid_type_node
, 0));
529 msg
= gfc_build_addr_expr (pchar_type_node
,
530 gfc_build_localized_cstring_const ("Memory allocation failed"));
531 tmp
= fold_build3 (COND_EXPR
, void_type_node
, null_result
,
532 build_call_expr_loc (input_location
,
533 gfor_fndecl_os_error
, 1, msg
),
534 build_empty_stmt (input_location
));
535 gfc_add_expr_to_block (&block2
, tmp
);
538 malloc_result
= gfc_finish_block (&block2
);
540 gfc_add_expr_to_block (block
, malloc_result
);
543 res
= fold_convert (type
, res
);
548 /* Allocate memory, using an optional status argument.
550 This function follows the following pseudo-code:
553 allocate (size_t size, integer_type* stat)
560 // The only time this can happen is the size wraps around.
565 *stat = LIBERROR_ALLOCATION;
569 runtime_error ("Attempt to allocate negative amount of memory. "
570 "Possible integer overflow");
574 newmem = malloc (MAX (size, 1));
578 *stat = LIBERROR_ALLOCATION;
580 runtime_error ("Out of memory");
587 gfc_allocate_with_status (stmtblock_t
* block
, tree size
, tree status
)
589 stmtblock_t alloc_block
;
590 tree res
, tmp
, error
, msg
, cond
;
591 tree status_type
= status
? TREE_TYPE (TREE_TYPE (status
)) : NULL_TREE
;
593 /* Evaluate size only once, and make sure it has the right type. */
594 size
= gfc_evaluate_now (size
, block
);
595 if (TREE_TYPE (size
) != TREE_TYPE (size_type_node
))
596 size
= fold_convert (size_type_node
, size
);
598 /* Create a variable to hold the result. */
599 res
= gfc_create_var (prvoid_type_node
, NULL
);
601 /* Set the optional status variable to zero. */
602 if (status
!= NULL_TREE
&& !integer_zerop (status
))
604 tmp
= fold_build2 (MODIFY_EXPR
, status_type
,
605 fold_build1 (INDIRECT_REF
, status_type
, status
),
606 build_int_cst (status_type
, 0));
607 tmp
= fold_build3 (COND_EXPR
, void_type_node
,
608 fold_build2 (NE_EXPR
, boolean_type_node
, status
,
609 build_int_cst (TREE_TYPE (status
), 0)),
610 tmp
, build_empty_stmt (input_location
));
611 gfc_add_expr_to_block (block
, tmp
);
614 /* Generate the block of code handling (size < 0). */
615 msg
= gfc_build_addr_expr (pchar_type_node
, gfc_build_localized_cstring_const
616 ("Attempt to allocate negative amount of memory. "
617 "Possible integer overflow"));
618 error
= build_call_expr_loc (input_location
,
619 gfor_fndecl_runtime_error
, 1, msg
);
621 if (status
!= NULL_TREE
&& !integer_zerop (status
))
623 /* Set the status variable if it's present. */
624 stmtblock_t set_status_block
;
626 gfc_start_block (&set_status_block
);
627 gfc_add_modify (&set_status_block
,
628 fold_build1 (INDIRECT_REF
, status_type
, status
),
629 build_int_cst (status_type
, LIBERROR_ALLOCATION
));
630 gfc_add_modify (&set_status_block
, res
,
631 build_int_cst (prvoid_type_node
, 0));
633 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, status
,
634 build_int_cst (TREE_TYPE (status
), 0));
635 error
= fold_build3 (COND_EXPR
, void_type_node
, tmp
, error
,
636 gfc_finish_block (&set_status_block
));
639 /* The allocation itself. */
640 gfc_start_block (&alloc_block
);
641 gfc_add_modify (&alloc_block
, res
,
642 fold_convert (prvoid_type_node
,
643 build_call_expr_loc (input_location
,
644 built_in_decls
[BUILT_IN_MALLOC
], 1,
645 fold_build2 (MAX_EXPR
, size_type_node
,
647 build_int_cst (size_type_node
, 1)))));
649 msg
= gfc_build_addr_expr (pchar_type_node
, gfc_build_localized_cstring_const
651 tmp
= build_call_expr_loc (input_location
,
652 gfor_fndecl_os_error
, 1, msg
);
654 if (status
!= NULL_TREE
&& !integer_zerop (status
))
656 /* Set the status variable if it's present. */
659 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
, status
,
660 build_int_cst (TREE_TYPE (status
), 0));
661 tmp2
= fold_build2 (MODIFY_EXPR
, status_type
,
662 fold_build1 (INDIRECT_REF
, status_type
, status
),
663 build_int_cst (status_type
, LIBERROR_ALLOCATION
));
664 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond
, tmp
,
668 tmp
= fold_build3 (COND_EXPR
, void_type_node
,
669 fold_build2 (EQ_EXPR
, boolean_type_node
, res
,
670 build_int_cst (prvoid_type_node
, 0)),
671 tmp
, build_empty_stmt (input_location
));
672 gfc_add_expr_to_block (&alloc_block
, tmp
);
674 cond
= fold_build2 (LT_EXPR
, boolean_type_node
, size
,
675 build_int_cst (TREE_TYPE (size
), 0));
676 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond
, error
,
677 gfc_finish_block (&alloc_block
));
678 gfc_add_expr_to_block (block
, tmp
);
684 /* Generate code for an ALLOCATE statement when the argument is an
685 allocatable array. If the array is currently allocated, it is an
686 error to allocate it again.
688 This function follows the following pseudo-code:
691 allocate_array (void *mem, size_t size, integer_type *stat)
694 return allocate (size, stat);
700 mem = allocate (size, stat);
701 *stat = LIBERROR_ALLOCATION;
705 runtime_error ("Attempting to allocate already allocated variable");
709 expr must be set to the original expression being allocated for its locus
710 and variable name in case a runtime error has to be printed. */
712 gfc_allocate_array_with_status (stmtblock_t
* block
, tree mem
, tree size
,
713 tree status
, gfc_expr
* expr
)
715 stmtblock_t alloc_block
;
716 tree res
, tmp
, null_mem
, alloc
, error
;
717 tree type
= TREE_TYPE (mem
);
719 if (TREE_TYPE (size
) != TREE_TYPE (size_type_node
))
720 size
= fold_convert (size_type_node
, size
);
722 /* Create a variable to hold the result. */
723 res
= gfc_create_var (type
, NULL
);
724 null_mem
= fold_build2 (EQ_EXPR
, boolean_type_node
, mem
,
725 build_int_cst (type
, 0));
727 /* If mem is NULL, we call gfc_allocate_with_status. */
728 gfc_start_block (&alloc_block
);
729 tmp
= gfc_allocate_with_status (&alloc_block
, size
, status
);
730 gfc_add_modify (&alloc_block
, res
, fold_convert (type
, tmp
));
731 alloc
= gfc_finish_block (&alloc_block
);
733 /* Otherwise, we issue a runtime error or set the status variable. */
738 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
&& expr
->symtree
);
739 varname
= gfc_build_cstring_const (expr
->symtree
->name
);
740 varname
= gfc_build_addr_expr (pchar_type_node
, varname
);
742 error
= gfc_trans_runtime_error (true, &expr
->where
,
743 "Attempting to allocate already"
744 " allocated variable '%s'",
748 error
= gfc_trans_runtime_error (true, NULL
,
749 "Attempting to allocate already allocated"
752 if (status
!= NULL_TREE
&& !integer_zerop (status
))
754 tree status_type
= TREE_TYPE (TREE_TYPE (status
));
755 stmtblock_t set_status_block
;
757 gfc_start_block (&set_status_block
);
758 tmp
= build_call_expr_loc (input_location
,
759 built_in_decls
[BUILT_IN_FREE
], 1,
760 fold_convert (pvoid_type_node
, mem
));
761 gfc_add_expr_to_block (&set_status_block
, tmp
);
763 tmp
= gfc_allocate_with_status (&set_status_block
, size
, status
);
764 gfc_add_modify (&set_status_block
, res
, fold_convert (type
, tmp
));
766 gfc_add_modify (&set_status_block
,
767 fold_build1 (INDIRECT_REF
, status_type
, status
),
768 build_int_cst (status_type
, LIBERROR_ALLOCATION
));
770 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, status
,
771 build_int_cst (status_type
, 0));
772 error
= fold_build3 (COND_EXPR
, void_type_node
, tmp
, error
,
773 gfc_finish_block (&set_status_block
));
776 tmp
= fold_build3 (COND_EXPR
, void_type_node
, null_mem
, alloc
, error
);
777 gfc_add_expr_to_block (block
, tmp
);
783 /* Free a given variable, if it's not NULL. */
785 gfc_call_free (tree var
)
788 tree tmp
, cond
, call
;
790 if (TREE_TYPE (var
) != TREE_TYPE (pvoid_type_node
))
791 var
= fold_convert (pvoid_type_node
, var
);
793 gfc_start_block (&block
);
794 var
= gfc_evaluate_now (var
, &block
);
795 cond
= fold_build2 (NE_EXPR
, boolean_type_node
, var
,
796 build_int_cst (pvoid_type_node
, 0));
797 call
= build_call_expr_loc (input_location
,
798 built_in_decls
[BUILT_IN_FREE
], 1, var
);
799 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond
, call
,
800 build_empty_stmt (input_location
));
801 gfc_add_expr_to_block (&block
, tmp
);
803 return gfc_finish_block (&block
);
808 /* User-deallocate; we emit the code directly from the front-end, and the
809 logic is the same as the previous library function:
812 deallocate (void *pointer, GFC_INTEGER_4 * stat)
819 runtime_error ("Attempt to DEALLOCATE unallocated memory.");
829 In this front-end version, status doesn't have to be GFC_INTEGER_4.
830 Moreover, if CAN_FAIL is true, then we will not emit a runtime error,
831 even when no status variable is passed to us (this is used for
832 unconditional deallocation generated by the front-end at end of
835 If a runtime-message is possible, `expr' must point to the original
836 expression being deallocated for its locus and variable name. */
838 gfc_deallocate_with_status (tree pointer
, tree status
, bool can_fail
,
841 stmtblock_t null
, non_null
;
842 tree cond
, tmp
, error
;
844 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
, pointer
,
845 build_int_cst (TREE_TYPE (pointer
), 0));
847 /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
848 we emit a runtime error. */
849 gfc_start_block (&null
);
854 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
&& expr
->symtree
);
856 varname
= gfc_build_cstring_const (expr
->symtree
->name
);
857 varname
= gfc_build_addr_expr (pchar_type_node
, varname
);
859 error
= gfc_trans_runtime_error (true, &expr
->where
,
860 "Attempt to DEALLOCATE unallocated '%s'",
864 error
= build_empty_stmt (input_location
);
866 if (status
!= NULL_TREE
&& !integer_zerop (status
))
868 tree status_type
= TREE_TYPE (TREE_TYPE (status
));
871 cond2
= fold_build2 (NE_EXPR
, boolean_type_node
, status
,
872 build_int_cst (TREE_TYPE (status
), 0));
873 tmp
= fold_build2 (MODIFY_EXPR
, status_type
,
874 fold_build1 (INDIRECT_REF
, status_type
, status
),
875 build_int_cst (status_type
, 1));
876 error
= fold_build3 (COND_EXPR
, void_type_node
, cond2
, tmp
, error
);
879 gfc_add_expr_to_block (&null
, error
);
881 /* When POINTER is not NULL, we free it. */
882 gfc_start_block (&non_null
);
883 tmp
= build_call_expr_loc (input_location
,
884 built_in_decls
[BUILT_IN_FREE
], 1,
885 fold_convert (pvoid_type_node
, pointer
));
886 gfc_add_expr_to_block (&non_null
, tmp
);
888 if (status
!= NULL_TREE
&& !integer_zerop (status
))
890 /* We set STATUS to zero if it is present. */
891 tree status_type
= TREE_TYPE (TREE_TYPE (status
));
894 cond2
= fold_build2 (NE_EXPR
, boolean_type_node
, status
,
895 build_int_cst (TREE_TYPE (status
), 0));
896 tmp
= fold_build2 (MODIFY_EXPR
, status_type
,
897 fold_build1 (INDIRECT_REF
, status_type
, status
),
898 build_int_cst (status_type
, 0));
899 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond2
, tmp
,
900 build_empty_stmt (input_location
));
901 gfc_add_expr_to_block (&non_null
, tmp
);
904 return fold_build3 (COND_EXPR
, void_type_node
, cond
,
905 gfc_finish_block (&null
), gfc_finish_block (&non_null
));
909 /* Reallocate MEM so it has SIZE bytes of data. This behaves like the
910 following pseudo-code:
913 internal_realloc (void *mem, size_t size)
916 runtime_error ("Attempt to allocate a negative amount of memory.");
917 res = realloc (mem, size);
918 if (!res && size != 0)
919 _gfortran_os_error ("Out of memory");
927 gfc_call_realloc (stmtblock_t
* block
, tree mem
, tree size
)
929 tree msg
, res
, negative
, nonzero
, zero
, null_result
, tmp
;
930 tree type
= TREE_TYPE (mem
);
932 size
= gfc_evaluate_now (size
, block
);
934 if (TREE_TYPE (size
) != TREE_TYPE (size_type_node
))
935 size
= fold_convert (size_type_node
, size
);
937 /* Create a variable to hold the result. */
938 res
= gfc_create_var (type
, NULL
);
941 negative
= fold_build2 (LT_EXPR
, boolean_type_node
, size
,
942 build_int_cst (size_type_node
, 0));
943 msg
= gfc_build_addr_expr (pchar_type_node
, gfc_build_localized_cstring_const
944 ("Attempt to allocate a negative amount of memory."));
945 tmp
= fold_build3 (COND_EXPR
, void_type_node
, negative
,
946 build_call_expr_loc (input_location
,
947 gfor_fndecl_runtime_error
, 1, msg
),
948 build_empty_stmt (input_location
));
949 gfc_add_expr_to_block (block
, tmp
);
951 /* Call realloc and check the result. */
952 tmp
= build_call_expr_loc (input_location
,
953 built_in_decls
[BUILT_IN_REALLOC
], 2,
954 fold_convert (pvoid_type_node
, mem
), size
);
955 gfc_add_modify (block
, res
, fold_convert (type
, tmp
));
956 null_result
= fold_build2 (EQ_EXPR
, boolean_type_node
, res
,
957 build_int_cst (pvoid_type_node
, 0));
958 nonzero
= fold_build2 (NE_EXPR
, boolean_type_node
, size
,
959 build_int_cst (size_type_node
, 0));
960 null_result
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
, null_result
,
962 msg
= gfc_build_addr_expr (pchar_type_node
, gfc_build_localized_cstring_const
964 tmp
= fold_build3 (COND_EXPR
, void_type_node
, null_result
,
965 build_call_expr_loc (input_location
,
966 gfor_fndecl_os_error
, 1, msg
),
967 build_empty_stmt (input_location
));
968 gfc_add_expr_to_block (block
, tmp
);
970 /* if (size == 0) then the result is NULL. */
971 tmp
= fold_build2 (MODIFY_EXPR
, type
, res
, build_int_cst (type
, 0));
972 zero
= fold_build1 (TRUTH_NOT_EXPR
, boolean_type_node
, nonzero
);
973 tmp
= fold_build3 (COND_EXPR
, void_type_node
, zero
, tmp
,
974 build_empty_stmt (input_location
));
975 gfc_add_expr_to_block (block
, tmp
);
980 /* Add a statement to a block. */
983 gfc_add_expr_to_block (stmtblock_t
* block
, tree expr
)
987 if (expr
== NULL_TREE
|| IS_EMPTY_STMT (expr
))
992 if (TREE_CODE (block
->head
) != STATEMENT_LIST
)
997 block
->head
= NULL_TREE
;
998 append_to_statement_list (tmp
, &block
->head
);
1000 append_to_statement_list (expr
, &block
->head
);
1003 /* Don't bother creating a list if we only have a single statement. */
1008 /* Add a block the end of a block. */
1011 gfc_add_block_to_block (stmtblock_t
* block
, stmtblock_t
* append
)
1013 gcc_assert (append
);
1014 gcc_assert (!append
->has_scope
);
1016 gfc_add_expr_to_block (block
, append
->head
);
1017 append
->head
= NULL_TREE
;
1021 /* Get the current locus. The structure may not be complete, and should
1022 only be used with gfc_set_backend_locus. */
1025 gfc_get_backend_locus (locus
* loc
)
1027 loc
->lb
= XCNEW (gfc_linebuf
);
1028 loc
->lb
->location
= input_location
;
1029 loc
->lb
->file
= gfc_current_backend_file
;
1033 /* Set the current locus. */
1036 gfc_set_backend_locus (locus
* loc
)
1038 gfc_current_backend_file
= loc
->lb
->file
;
1039 input_location
= loc
->lb
->location
;
1043 /* Translate an executable statement. The tree cond is used by gfc_trans_do.
1044 This static function is wrapped by gfc_trans_code_cond and
1048 trans_code (gfc_code
* code
, tree cond
)
1054 return build_empty_stmt (input_location
);
1056 gfc_start_block (&block
);
1058 /* Translate statements one by one into GENERIC trees until we reach
1059 the end of this gfc_code branch. */
1060 for (; code
; code
= code
->next
)
1062 if (code
->here
!= 0)
1064 res
= gfc_trans_label_here (code
);
1065 gfc_add_expr_to_block (&block
, res
);
1068 gfc_set_backend_locus (&code
->loc
);
1073 case EXEC_END_BLOCK
:
1074 case EXEC_END_PROCEDURE
:
1079 if (code
->expr1
->ts
.type
== BT_CLASS
)
1080 res
= gfc_trans_class_assign (code
);
1082 res
= gfc_trans_assign (code
);
1085 case EXEC_LABEL_ASSIGN
:
1086 res
= gfc_trans_label_assign (code
);
1089 case EXEC_POINTER_ASSIGN
:
1090 if (code
->expr1
->ts
.type
== BT_CLASS
)
1091 res
= gfc_trans_class_assign (code
);
1093 res
= gfc_trans_pointer_assign (code
);
1096 case EXEC_INIT_ASSIGN
:
1097 if (code
->expr1
->ts
.type
== BT_CLASS
)
1098 res
= gfc_trans_class_assign (code
);
1100 res
= gfc_trans_init_assign (code
);
1108 res
= gfc_trans_critical (code
);
1112 res
= gfc_trans_cycle (code
);
1116 res
= gfc_trans_exit (code
);
1120 res
= gfc_trans_goto (code
);
1124 res
= gfc_trans_entry (code
);
1128 res
= gfc_trans_pause (code
);
1132 case EXEC_ERROR_STOP
:
1133 res
= gfc_trans_stop (code
, code
->op
== EXEC_ERROR_STOP
);
1137 /* For MVBITS we've got the special exception that we need a
1138 dependency check, too. */
1140 bool is_mvbits
= false;
1141 if (code
->resolved_isym
1142 && code
->resolved_isym
->id
== GFC_ISYM_MVBITS
)
1144 res
= gfc_trans_call (code
, is_mvbits
, NULL_TREE
,
1150 res
= gfc_trans_call (code
, false, NULL_TREE
,
1154 case EXEC_ASSIGN_CALL
:
1155 res
= gfc_trans_call (code
, true, NULL_TREE
,
1160 res
= gfc_trans_return (code
);
1164 res
= gfc_trans_if (code
);
1167 case EXEC_ARITHMETIC_IF
:
1168 res
= gfc_trans_arithmetic_if (code
);
1172 res
= gfc_trans_block_construct (code
);
1176 res
= gfc_trans_do (code
, cond
);
1180 res
= gfc_trans_do_while (code
);
1184 res
= gfc_trans_select (code
);
1187 case EXEC_SELECT_TYPE
:
1188 /* Do nothing. SELECT TYPE statements should be transformed into
1189 an ordinary SELECT CASE at resolution stage.
1190 TODO: Add an error message here once this is done. */
1195 res
= gfc_trans_flush (code
);
1199 case EXEC_SYNC_IMAGES
:
1200 case EXEC_SYNC_MEMORY
:
1201 res
= gfc_trans_sync (code
, code
->op
);
1205 res
= gfc_trans_forall (code
);
1209 res
= gfc_trans_where (code
);
1213 res
= gfc_trans_allocate (code
);
1216 case EXEC_DEALLOCATE
:
1217 res
= gfc_trans_deallocate (code
);
1221 res
= gfc_trans_open (code
);
1225 res
= gfc_trans_close (code
);
1229 res
= gfc_trans_read (code
);
1233 res
= gfc_trans_write (code
);
1237 res
= gfc_trans_iolength (code
);
1240 case EXEC_BACKSPACE
:
1241 res
= gfc_trans_backspace (code
);
1245 res
= gfc_trans_endfile (code
);
1249 res
= gfc_trans_inquire (code
);
1253 res
= gfc_trans_wait (code
);
1257 res
= gfc_trans_rewind (code
);
1261 res
= gfc_trans_transfer (code
);
1265 res
= gfc_trans_dt_end (code
);
1268 case EXEC_OMP_ATOMIC
:
1269 case EXEC_OMP_BARRIER
:
1270 case EXEC_OMP_CRITICAL
:
1272 case EXEC_OMP_FLUSH
:
1273 case EXEC_OMP_MASTER
:
1274 case EXEC_OMP_ORDERED
:
1275 case EXEC_OMP_PARALLEL
:
1276 case EXEC_OMP_PARALLEL_DO
:
1277 case EXEC_OMP_PARALLEL_SECTIONS
:
1278 case EXEC_OMP_PARALLEL_WORKSHARE
:
1279 case EXEC_OMP_SECTIONS
:
1280 case EXEC_OMP_SINGLE
:
1282 case EXEC_OMP_TASKWAIT
:
1283 case EXEC_OMP_WORKSHARE
:
1284 res
= gfc_trans_omp_directive (code
);
1288 internal_error ("gfc_trans_code(): Bad statement code");
1291 gfc_set_backend_locus (&code
->loc
);
1293 if (res
!= NULL_TREE
&& ! IS_EMPTY_STMT (res
))
1295 if (TREE_CODE (res
) != STATEMENT_LIST
)
1296 SET_EXPR_LOCATION (res
, input_location
);
1298 /* Add the new statement to the block. */
1299 gfc_add_expr_to_block (&block
, res
);
1303 /* Return the finished block. */
1304 return gfc_finish_block (&block
);
1308 /* Translate an executable statement with condition, cond. The condition is
1309 used by gfc_trans_do to test for IO result conditions inside implied
1310 DO loops of READ and WRITE statements. See build_dt in trans-io.c. */
1313 gfc_trans_code_cond (gfc_code
* code
, tree cond
)
1315 return trans_code (code
, cond
);
1318 /* Translate an executable statement without condition. */
1321 gfc_trans_code (gfc_code
* code
)
1323 return trans_code (code
, NULL_TREE
);
1327 /* This function is called after a complete program unit has been parsed
1331 gfc_generate_code (gfc_namespace
* ns
)
1334 if (ns
->is_block_data
)
1336 gfc_generate_block_data (ns
);
1340 gfc_generate_function_code (ns
);
1344 /* This function is called after a complete module has been parsed
1348 gfc_generate_module_code (gfc_namespace
* ns
)
1351 struct module_htab_entry
*entry
;
1353 gcc_assert (ns
->proc_name
->backend_decl
== NULL
);
1354 ns
->proc_name
->backend_decl
1355 = build_decl (ns
->proc_name
->declared_at
.lb
->location
,
1356 NAMESPACE_DECL
, get_identifier (ns
->proc_name
->name
),
1358 entry
= gfc_find_module (ns
->proc_name
->name
);
1359 if (entry
->namespace_decl
)
1360 /* Buggy sourcecode, using a module before defining it? */
1361 htab_empty (entry
->decls
);
1362 entry
->namespace_decl
= ns
->proc_name
->backend_decl
;
1364 gfc_generate_module_vars (ns
);
1366 /* We need to generate all module function prototypes first, to allow
1368 for (n
= ns
->contained
; n
; n
= n
->sibling
)
1375 gfc_create_function_decl (n
);
1376 gcc_assert (DECL_CONTEXT (n
->proc_name
->backend_decl
) == NULL_TREE
);
1377 DECL_CONTEXT (n
->proc_name
->backend_decl
) = ns
->proc_name
->backend_decl
;
1378 gfc_module_add_decl (entry
, n
->proc_name
->backend_decl
);
1379 for (el
= ns
->entries
; el
; el
= el
->next
)
1381 gcc_assert (DECL_CONTEXT (el
->sym
->backend_decl
) == NULL_TREE
);
1382 DECL_CONTEXT (el
->sym
->backend_decl
) = ns
->proc_name
->backend_decl
;
1383 gfc_module_add_decl (entry
, el
->sym
->backend_decl
);
1387 for (n
= ns
->contained
; n
; n
= n
->sibling
)
1392 gfc_generate_function_code (n
);