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 /* Strip off a legitimate source ending from the input
67 string NAME of length LEN. */
70 remove_suffix (char *name
, int len
)
74 for (i
= 2; i
< 8 && len
> i
; i
++)
76 if (name
[len
- i
] == '.')
85 /* Creates a variable declaration with a given TYPE. */
88 gfc_create_var_np (tree type
, const char *prefix
)
92 t
= create_tmp_var_raw (type
, prefix
);
94 /* No warnings for anonymous variables. */
96 TREE_NO_WARNING (t
) = 1;
102 /* Like above, but also adds it to the current scope. */
105 gfc_create_var (tree type
, const char *prefix
)
109 tmp
= gfc_create_var_np (type
, prefix
);
117 /* If the expression is not constant, evaluate it now. We assign the
118 result of the expression to an artificially created variable VAR, and
119 return a pointer to the VAR_DECL node for this variable. */
122 gfc_evaluate_now_loc (location_t loc
, tree expr
, stmtblock_t
* pblock
)
126 if (CONSTANT_CLASS_P (expr
))
129 var
= gfc_create_var (TREE_TYPE (expr
), NULL
);
130 gfc_add_modify_loc (loc
, pblock
, var
, expr
);
137 gfc_evaluate_now (tree expr
, stmtblock_t
* pblock
)
139 return gfc_evaluate_now_loc (input_location
, expr
, pblock
);
143 /* Build a MODIFY_EXPR node and add it to a given statement block PBLOCK.
144 A MODIFY_EXPR is an assignment:
148 gfc_add_modify_loc (location_t loc
, stmtblock_t
* pblock
, tree lhs
, tree rhs
)
152 #ifdef ENABLE_CHECKING
154 t1
= TREE_TYPE (rhs
);
155 t2
= TREE_TYPE (lhs
);
156 /* Make sure that the types of the rhs and the lhs are the same
157 for scalar assignments. We should probably have something
158 similar for aggregates, but right now removing that check just
159 breaks everything. */
161 || AGGREGATE_TYPE_P (TREE_TYPE (lhs
)));
164 tmp
= fold_build2_loc (loc
, MODIFY_EXPR
, void_type_node
, lhs
,
166 gfc_add_expr_to_block (pblock
, tmp
);
171 gfc_add_modify (stmtblock_t
* pblock
, tree lhs
, tree rhs
)
173 gfc_add_modify_loc (input_location
, pblock
, lhs
, rhs
);
177 /* Create a new scope/binding level and initialize a block. Care must be
178 taken when translating expressions as any temporaries will be placed in
179 the innermost scope. */
182 gfc_start_block (stmtblock_t
* block
)
184 /* Start a new binding level. */
186 block
->has_scope
= 1;
188 /* The block is empty. */
189 block
->head
= NULL_TREE
;
193 /* Initialize a block without creating a new scope. */
196 gfc_init_block (stmtblock_t
* block
)
198 block
->head
= NULL_TREE
;
199 block
->has_scope
= 0;
203 /* Sometimes we create a scope but it turns out that we don't actually
204 need it. This function merges the scope of BLOCK with its parent.
205 Only variable decls will be merged, you still need to add the code. */
208 gfc_merge_block_scope (stmtblock_t
* block
)
213 gcc_assert (block
->has_scope
);
214 block
->has_scope
= 0;
216 /* Remember the decls in this scope. */
220 /* Add them to the parent scope. */
221 while (decl
!= NULL_TREE
)
223 next
= DECL_CHAIN (decl
);
224 DECL_CHAIN (decl
) = NULL_TREE
;
232 /* Finish a scope containing a block of statements. */
235 gfc_finish_block (stmtblock_t
* stmtblock
)
241 expr
= stmtblock
->head
;
243 expr
= build_empty_stmt (input_location
);
245 stmtblock
->head
= NULL_TREE
;
247 if (stmtblock
->has_scope
)
253 block
= poplevel (1, 0, 0);
254 expr
= build3_v (BIND_EXPR
, decl
, expr
, block
);
264 /* Build an ADDR_EXPR and cast the result to TYPE. If TYPE is NULL, the
265 natural type is used. */
268 gfc_build_addr_expr (tree type
, tree t
)
270 tree base_type
= TREE_TYPE (t
);
273 if (type
&& POINTER_TYPE_P (type
)
274 && TREE_CODE (base_type
) == ARRAY_TYPE
275 && TYPE_MAIN_VARIANT (TREE_TYPE (type
))
276 == TYPE_MAIN_VARIANT (TREE_TYPE (base_type
)))
278 tree min_val
= size_zero_node
;
279 tree type_domain
= TYPE_DOMAIN (base_type
);
280 if (type_domain
&& TYPE_MIN_VALUE (type_domain
))
281 min_val
= TYPE_MIN_VALUE (type_domain
);
282 t
= fold (build4_loc (input_location
, ARRAY_REF
, TREE_TYPE (type
),
283 t
, min_val
, NULL_TREE
, NULL_TREE
));
287 natural_type
= build_pointer_type (base_type
);
289 if (TREE_CODE (t
) == INDIRECT_REF
)
293 t
= TREE_OPERAND (t
, 0);
294 natural_type
= TREE_TYPE (t
);
298 tree base
= get_base_address (t
);
299 if (base
&& DECL_P (base
))
300 TREE_ADDRESSABLE (base
) = 1;
301 t
= fold_build1_loc (input_location
, ADDR_EXPR
, natural_type
, t
);
304 if (type
&& natural_type
!= type
)
305 t
= convert (type
, t
);
311 /* Build an ARRAY_REF with its natural type. */
314 gfc_build_array_ref (tree base
, tree offset
, tree decl
)
316 tree type
= TREE_TYPE (base
);
320 if (GFC_ARRAY_TYPE_P (type
) && GFC_TYPE_ARRAY_RANK (type
) == 0)
322 gcc_assert (GFC_TYPE_ARRAY_CORANK (type
) > 0);
324 return fold_convert (TYPE_MAIN_VARIANT (type
), base
);
327 /* Scalar coarray, there is nothing to do. */
328 if (TREE_CODE (type
) != ARRAY_TYPE
)
330 gcc_assert (decl
== NULL_TREE
);
331 gcc_assert (integer_zerop (offset
));
335 type
= TREE_TYPE (type
);
338 TREE_ADDRESSABLE (base
) = 1;
340 /* Strip NON_LVALUE_EXPR nodes. */
341 STRIP_TYPE_NOPS (offset
);
343 /* If the array reference is to a pointer, whose target contains a
344 subreference, use the span that is stored with the backend decl
345 and reference the element with pointer arithmetic. */
346 if (decl
&& (TREE_CODE (decl
) == FIELD_DECL
347 || TREE_CODE (decl
) == VAR_DECL
348 || TREE_CODE (decl
) == PARM_DECL
)
349 && ((GFC_DECL_SUBREF_ARRAY_P (decl
)
350 && !integer_zerop (GFC_DECL_SPAN(decl
)))
351 || GFC_DECL_CLASS (decl
)))
353 if (GFC_DECL_CLASS (decl
))
355 /* Allow for dummy arguments and other good things. */
356 if (POINTER_TYPE_P (TREE_TYPE (decl
)))
357 decl
= build_fold_indirect_ref_loc (input_location
, decl
);
359 /* Check if '_data' is an array descriptor. If it is not,
360 the array must be one of the components of the class object,
361 so return a normal array reference. */
362 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_class_data_get (decl
))))
363 return build4_loc (input_location
, ARRAY_REF
, type
, base
,
364 offset
, NULL_TREE
, NULL_TREE
);
366 span
= gfc_vtable_size_get (decl
);
368 else if (GFC_DECL_SUBREF_ARRAY_P (decl
))
369 span
= GFC_DECL_SPAN(decl
);
373 offset
= fold_build2_loc (input_location
, MULT_EXPR
,
374 gfc_array_index_type
,
376 tmp
= gfc_build_addr_expr (pvoid_type_node
, base
);
377 tmp
= fold_build_pointer_plus_loc (input_location
, tmp
, offset
);
378 tmp
= fold_convert (build_pointer_type (type
), tmp
);
379 if (!TYPE_STRING_FLAG (type
))
380 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
384 /* Otherwise use a straightforward array reference. */
385 return build4_loc (input_location
, ARRAY_REF
, type
, base
, offset
,
386 NULL_TREE
, NULL_TREE
);
390 /* Generate a call to print a runtime error possibly including multiple
391 arguments and a locus. */
394 trans_runtime_error_vararg (bool error
, locus
* where
, const char* msgid
,
407 /* Compute the number of extra arguments from the format string. */
408 for (p
= msgid
, nargs
= 0; *p
; p
++)
416 /* The code to generate the error. */
417 gfc_start_block (&block
);
421 line
= LOCATION_LINE (where
->lb
->location
);
422 asprintf (&message
, "At line %d of file %s", line
,
423 where
->lb
->file
->filename
);
426 asprintf (&message
, "In file '%s', around line %d",
427 gfc_source_file
, input_line
+ 1);
429 arg
= gfc_build_addr_expr (pchar_type_node
,
430 gfc_build_localized_cstring_const (message
));
433 asprintf (&message
, "%s", _(msgid
));
434 arg2
= gfc_build_addr_expr (pchar_type_node
,
435 gfc_build_localized_cstring_const (message
));
438 /* Build the argument array. */
439 argarray
= XALLOCAVEC (tree
, nargs
+ 2);
442 for (i
= 0; i
< nargs
; i
++)
443 argarray
[2 + i
] = va_arg (ap
, tree
);
445 /* Build the function call to runtime_(warning,error)_at; because of the
446 variable number of arguments, we can't use build_call_expr_loc dinput_location,
449 fntype
= TREE_TYPE (gfor_fndecl_runtime_error_at
);
451 fntype
= TREE_TYPE (gfor_fndecl_runtime_warning_at
);
453 loc
= where
? where
->lb
->location
: input_location
;
454 tmp
= fold_builtin_call_array (loc
, TREE_TYPE (fntype
),
455 fold_build1_loc (loc
, ADDR_EXPR
,
456 build_pointer_type (fntype
),
458 ? gfor_fndecl_runtime_error_at
459 : gfor_fndecl_runtime_warning_at
),
460 nargs
+ 2, argarray
);
461 gfc_add_expr_to_block (&block
, tmp
);
463 return gfc_finish_block (&block
);
468 gfc_trans_runtime_error (bool error
, locus
* where
, const char* msgid
, ...)
473 va_start (ap
, msgid
);
474 result
= trans_runtime_error_vararg (error
, where
, msgid
, ap
);
480 /* Generate a runtime error if COND is true. */
483 gfc_trans_runtime_check (bool error
, bool once
, tree cond
, stmtblock_t
* pblock
,
484 locus
* where
, const char * msgid
, ...)
492 if (integer_zerop (cond
))
497 tmpvar
= gfc_create_var (boolean_type_node
, "print_warning");
498 TREE_STATIC (tmpvar
) = 1;
499 DECL_INITIAL (tmpvar
) = boolean_true_node
;
500 gfc_add_expr_to_block (pblock
, tmpvar
);
503 gfc_start_block (&block
);
505 /* The code to generate the error. */
506 va_start (ap
, msgid
);
507 gfc_add_expr_to_block (&block
,
508 trans_runtime_error_vararg (error
, where
,
512 gfc_add_modify (&block
, tmpvar
, boolean_false_node
);
514 body
= gfc_finish_block (&block
);
516 if (integer_onep (cond
))
518 gfc_add_expr_to_block (pblock
, body
);
522 /* Tell the compiler that this isn't likely. */
524 cond
= fold_build2_loc (where
->lb
->location
, TRUTH_AND_EXPR
,
525 long_integer_type_node
, tmpvar
, cond
);
527 cond
= fold_convert (long_integer_type_node
, cond
);
529 cond
= gfc_unlikely (cond
);
530 tmp
= fold_build3_loc (where
->lb
->location
, COND_EXPR
, void_type_node
,
532 build_empty_stmt (where
->lb
->location
));
533 gfc_add_expr_to_block (pblock
, tmp
);
538 /* Call malloc to allocate size bytes of memory, with special conditions:
539 + if size == 0, return a malloced area of size 1,
540 + if malloc returns NULL, issue a runtime error. */
542 gfc_call_malloc (stmtblock_t
* block
, tree type
, tree size
)
544 tree tmp
, msg
, malloc_result
, null_result
, res
, malloc_tree
;
547 size
= gfc_evaluate_now (size
, block
);
549 if (TREE_TYPE (size
) != TREE_TYPE (size_type_node
))
550 size
= fold_convert (size_type_node
, size
);
552 /* Create a variable to hold the result. */
553 res
= gfc_create_var (prvoid_type_node
, NULL
);
556 gfc_start_block (&block2
);
558 size
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
, size
,
559 build_int_cst (size_type_node
, 1));
561 malloc_tree
= builtin_decl_explicit (BUILT_IN_MALLOC
);
562 gfc_add_modify (&block2
, res
,
563 fold_convert (prvoid_type_node
,
564 build_call_expr_loc (input_location
,
565 malloc_tree
, 1, size
)));
567 /* Optionally check whether malloc was successful. */
568 if (gfc_option
.rtcheck
& GFC_RTCHECK_MEM
)
570 null_result
= fold_build2_loc (input_location
, EQ_EXPR
,
571 boolean_type_node
, res
,
572 build_int_cst (pvoid_type_node
, 0));
573 msg
= gfc_build_addr_expr (pchar_type_node
,
574 gfc_build_localized_cstring_const ("Memory allocation failed"));
575 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
577 build_call_expr_loc (input_location
,
578 gfor_fndecl_os_error
, 1, msg
),
579 build_empty_stmt (input_location
));
580 gfc_add_expr_to_block (&block2
, tmp
);
583 malloc_result
= gfc_finish_block (&block2
);
585 gfc_add_expr_to_block (block
, malloc_result
);
588 res
= fold_convert (type
, res
);
593 /* Allocate memory, using an optional status argument.
595 This function follows the following pseudo-code:
598 allocate (size_t size, integer_type stat)
605 newmem = malloc (MAX (size, 1));
609 *stat = LIBERROR_ALLOCATION;
611 runtime_error ("Allocation would exceed memory limit");
616 gfc_allocate_using_malloc (stmtblock_t
* block
, tree pointer
,
617 tree size
, tree status
)
619 tree tmp
, on_error
, error_cond
;
620 tree status_type
= status
? TREE_TYPE (status
) : NULL_TREE
;
622 /* Evaluate size only once, and make sure it has the right type. */
623 size
= gfc_evaluate_now (size
, block
);
624 if (TREE_TYPE (size
) != TREE_TYPE (size_type_node
))
625 size
= fold_convert (size_type_node
, size
);
627 /* If successful and stat= is given, set status to 0. */
628 if (status
!= NULL_TREE
)
629 gfc_add_expr_to_block (block
,
630 fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
631 status
, build_int_cst (status_type
, 0)));
633 /* The allocation itself. */
634 gfc_add_modify (block
, pointer
,
635 fold_convert (TREE_TYPE (pointer
),
636 build_call_expr_loc (input_location
,
637 builtin_decl_explicit (BUILT_IN_MALLOC
), 1,
638 fold_build2_loc (input_location
,
639 MAX_EXPR
, size_type_node
, size
,
640 build_int_cst (size_type_node
, 1)))));
642 /* What to do in case of error. */
643 if (status
!= NULL_TREE
)
644 on_error
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
645 status
, build_int_cst (status_type
, LIBERROR_ALLOCATION
));
647 on_error
= build_call_expr_loc (input_location
, gfor_fndecl_os_error
, 1,
648 gfc_build_addr_expr (pchar_type_node
,
649 gfc_build_localized_cstring_const
650 ("Allocation would exceed memory limit")));
652 error_cond
= fold_build2_loc (input_location
, EQ_EXPR
,
653 boolean_type_node
, pointer
,
654 build_int_cst (prvoid_type_node
, 0));
655 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
656 gfc_unlikely(error_cond
), on_error
,
657 build_empty_stmt (input_location
));
659 gfc_add_expr_to_block (block
, tmp
);
663 /* Allocate memory, using an optional status argument.
665 This function follows the following pseudo-code:
668 allocate (size_t size, void** token, int *stat, char* errmsg, int errlen)
672 newmem = _caf_register (size, regtype, token, &stat, errmsg, errlen);
676 gfc_allocate_using_lib (stmtblock_t
* block
, tree pointer
, tree size
,
677 tree token
, tree status
, tree errmsg
, tree errlen
)
681 gcc_assert (token
!= NULL_TREE
);
683 /* Evaluate size only once, and make sure it has the right type. */
684 size
= gfc_evaluate_now (size
, block
);
685 if (TREE_TYPE (size
) != TREE_TYPE (size_type_node
))
686 size
= fold_convert (size_type_node
, size
);
688 /* The allocation itself. */
689 if (status
== NULL_TREE
)
690 pstat
= null_pointer_node
;
692 pstat
= gfc_build_addr_expr (NULL_TREE
, status
);
694 if (errmsg
== NULL_TREE
)
696 gcc_assert(errlen
== NULL_TREE
);
697 errmsg
= null_pointer_node
;
698 errlen
= build_int_cst (integer_type_node
, 0);
701 tmp
= build_call_expr_loc (input_location
,
702 gfor_fndecl_caf_register
, 6,
703 fold_build2_loc (input_location
,
704 MAX_EXPR
, size_type_node
, size
,
705 build_int_cst (size_type_node
, 1)),
706 build_int_cst (integer_type_node
,
707 GFC_CAF_COARRAY_ALLOC
),
708 token
, pstat
, errmsg
, errlen
);
710 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
711 TREE_TYPE (pointer
), pointer
,
712 fold_convert ( TREE_TYPE (pointer
), tmp
));
713 gfc_add_expr_to_block (block
, tmp
);
717 /* Generate code for an ALLOCATE statement when the argument is an
718 allocatable variable. If the variable is currently allocated, it is an
719 error to allocate it again.
721 This function follows the following pseudo-code:
724 allocate_allocatable (void *mem, size_t size, integer_type stat)
727 return allocate (size, stat);
731 stat = LIBERROR_ALLOCATION;
733 runtime_error ("Attempting to allocate already allocated variable");
737 expr must be set to the original expression being allocated for its locus
738 and variable name in case a runtime error has to be printed. */
740 gfc_allocate_allocatable (stmtblock_t
* block
, tree mem
, tree size
, tree token
,
741 tree status
, tree errmsg
, tree errlen
, gfc_expr
* expr
)
743 stmtblock_t alloc_block
;
744 tree tmp
, null_mem
, alloc
, error
;
745 tree type
= TREE_TYPE (mem
);
747 if (TREE_TYPE (size
) != TREE_TYPE (size_type_node
))
748 size
= fold_convert (size_type_node
, size
);
750 null_mem
= gfc_unlikely (fold_build2_loc (input_location
, NE_EXPR
,
751 boolean_type_node
, mem
,
752 build_int_cst (type
, 0)));
754 /* If mem is NULL, we call gfc_allocate_using_malloc or
755 gfc_allocate_using_lib. */
756 gfc_start_block (&alloc_block
);
758 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
759 && gfc_expr_attr (expr
).codimension
)
760 gfc_allocate_using_lib (&alloc_block
, mem
, size
, token
, status
,
763 gfc_allocate_using_malloc (&alloc_block
, mem
, size
, status
);
765 alloc
= gfc_finish_block (&alloc_block
);
767 /* If mem is not NULL, we issue a runtime error or set the
773 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
&& expr
->symtree
);
774 varname
= gfc_build_cstring_const (expr
->symtree
->name
);
775 varname
= gfc_build_addr_expr (pchar_type_node
, varname
);
777 error
= gfc_trans_runtime_error (true, &expr
->where
,
778 "Attempting to allocate already"
779 " allocated variable '%s'",
783 error
= gfc_trans_runtime_error (true, NULL
,
784 "Attempting to allocate already allocated"
787 if (status
!= NULL_TREE
)
789 tree status_type
= TREE_TYPE (status
);
791 error
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
792 status
, build_int_cst (status_type
, LIBERROR_ALLOCATION
));
795 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, null_mem
,
797 gfc_add_expr_to_block (block
, tmp
);
801 /* Free a given variable, if it's not NULL. */
803 gfc_call_free (tree var
)
806 tree tmp
, cond
, call
;
808 if (TREE_TYPE (var
) != TREE_TYPE (pvoid_type_node
))
809 var
= fold_convert (pvoid_type_node
, var
);
811 gfc_start_block (&block
);
812 var
= gfc_evaluate_now (var
, &block
);
813 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, var
,
814 build_int_cst (pvoid_type_node
, 0));
815 call
= build_call_expr_loc (input_location
,
816 builtin_decl_explicit (BUILT_IN_FREE
),
818 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, call
,
819 build_empty_stmt (input_location
));
820 gfc_add_expr_to_block (&block
, tmp
);
822 return gfc_finish_block (&block
);
827 /* User-deallocate; we emit the code directly from the front-end, and the
828 logic is the same as the previous library function:
831 deallocate (void *pointer, GFC_INTEGER_4 * stat)
838 runtime_error ("Attempt to DEALLOCATE unallocated memory.");
848 In this front-end version, status doesn't have to be GFC_INTEGER_4.
849 Moreover, if CAN_FAIL is true, then we will not emit a runtime error,
850 even when no status variable is passed to us (this is used for
851 unconditional deallocation generated by the front-end at end of
854 If a runtime-message is possible, `expr' must point to the original
855 expression being deallocated for its locus and variable name. */
857 gfc_deallocate_with_status (tree pointer
, tree status
, bool can_fail
,
860 stmtblock_t null
, non_null
;
861 tree cond
, tmp
, error
;
863 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, pointer
,
864 build_int_cst (TREE_TYPE (pointer
), 0));
866 /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
867 we emit a runtime error. */
868 gfc_start_block (&null
);
873 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
&& expr
->symtree
);
875 varname
= gfc_build_cstring_const (expr
->symtree
->name
);
876 varname
= gfc_build_addr_expr (pchar_type_node
, varname
);
878 error
= gfc_trans_runtime_error (true, &expr
->where
,
879 "Attempt to DEALLOCATE unallocated '%s'",
883 error
= build_empty_stmt (input_location
);
885 if (status
!= NULL_TREE
&& !integer_zerop (status
))
887 tree status_type
= TREE_TYPE (TREE_TYPE (status
));
890 cond2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
891 status
, build_int_cst (TREE_TYPE (status
), 0));
892 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
893 fold_build1_loc (input_location
, INDIRECT_REF
,
894 status_type
, status
),
895 build_int_cst (status_type
, 1));
896 error
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
900 gfc_add_expr_to_block (&null
, error
);
902 /* When POINTER is not NULL, we free it. */
903 gfc_start_block (&non_null
);
904 tmp
= build_call_expr_loc (input_location
,
905 builtin_decl_explicit (BUILT_IN_FREE
), 1,
906 fold_convert (pvoid_type_node
, pointer
));
907 gfc_add_expr_to_block (&non_null
, tmp
);
909 if (status
!= NULL_TREE
&& !integer_zerop (status
))
911 /* We set STATUS to zero if it is present. */
912 tree status_type
= TREE_TYPE (TREE_TYPE (status
));
915 cond2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
916 status
, build_int_cst (TREE_TYPE (status
), 0));
917 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
918 fold_build1_loc (input_location
, INDIRECT_REF
,
919 status_type
, status
),
920 build_int_cst (status_type
, 0));
921 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
922 tmp
, build_empty_stmt (input_location
));
923 gfc_add_expr_to_block (&non_null
, tmp
);
926 return fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
927 gfc_finish_block (&null
),
928 gfc_finish_block (&non_null
));
932 /* Generate code for deallocation of allocatable scalars (variables or
933 components). Before the object itself is freed, any allocatable
934 subcomponents are being deallocated. */
937 gfc_deallocate_scalar_with_status (tree pointer
, tree status
, bool can_fail
,
938 gfc_expr
* expr
, gfc_typespec ts
)
940 stmtblock_t null
, non_null
;
941 tree cond
, tmp
, error
;
943 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, pointer
,
944 build_int_cst (TREE_TYPE (pointer
), 0));
946 /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
947 we emit a runtime error. */
948 gfc_start_block (&null
);
953 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
&& expr
->symtree
);
955 varname
= gfc_build_cstring_const (expr
->symtree
->name
);
956 varname
= gfc_build_addr_expr (pchar_type_node
, varname
);
958 error
= gfc_trans_runtime_error (true, &expr
->where
,
959 "Attempt to DEALLOCATE unallocated '%s'",
963 error
= build_empty_stmt (input_location
);
965 if (status
!= NULL_TREE
&& !integer_zerop (status
))
967 tree status_type
= TREE_TYPE (TREE_TYPE (status
));
970 cond2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
971 status
, build_int_cst (TREE_TYPE (status
), 0));
972 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
973 fold_build1_loc (input_location
, INDIRECT_REF
,
974 status_type
, status
),
975 build_int_cst (status_type
, 1));
976 error
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
980 gfc_add_expr_to_block (&null
, error
);
982 /* When POINTER is not NULL, we free it. */
983 gfc_start_block (&non_null
);
985 /* Free allocatable components. */
986 if (ts
.type
== BT_DERIVED
&& ts
.u
.derived
->attr
.alloc_comp
)
988 tmp
= build_fold_indirect_ref_loc (input_location
, pointer
);
989 tmp
= gfc_deallocate_alloc_comp (ts
.u
.derived
, tmp
, 0);
990 gfc_add_expr_to_block (&non_null
, tmp
);
992 else if (ts
.type
== BT_CLASS
993 && ts
.u
.derived
->components
->ts
.u
.derived
->attr
.alloc_comp
)
995 tmp
= build_fold_indirect_ref_loc (input_location
, pointer
);
996 tmp
= gfc_deallocate_alloc_comp (ts
.u
.derived
->components
->ts
.u
.derived
,
998 gfc_add_expr_to_block (&non_null
, tmp
);
1001 tmp
= build_call_expr_loc (input_location
,
1002 builtin_decl_explicit (BUILT_IN_FREE
), 1,
1003 fold_convert (pvoid_type_node
, pointer
));
1004 gfc_add_expr_to_block (&non_null
, tmp
);
1006 if (status
!= NULL_TREE
&& !integer_zerop (status
))
1008 /* We set STATUS to zero if it is present. */
1009 tree status_type
= TREE_TYPE (TREE_TYPE (status
));
1012 cond2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1013 status
, build_int_cst (TREE_TYPE (status
), 0));
1014 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
1015 fold_build1_loc (input_location
, INDIRECT_REF
,
1016 status_type
, status
),
1017 build_int_cst (status_type
, 0));
1018 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond2
,
1019 tmp
, build_empty_stmt (input_location
));
1020 gfc_add_expr_to_block (&non_null
, tmp
);
1023 return fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
1024 gfc_finish_block (&null
),
1025 gfc_finish_block (&non_null
));
1029 /* Reallocate MEM so it has SIZE bytes of data. This behaves like the
1030 following pseudo-code:
1033 internal_realloc (void *mem, size_t size)
1035 res = realloc (mem, size);
1036 if (!res && size != 0)
1037 _gfortran_os_error ("Allocation would exceed memory limit");
1045 gfc_call_realloc (stmtblock_t
* block
, tree mem
, tree size
)
1047 tree msg
, res
, nonzero
, zero
, null_result
, tmp
;
1048 tree type
= TREE_TYPE (mem
);
1050 size
= gfc_evaluate_now (size
, block
);
1052 if (TREE_TYPE (size
) != TREE_TYPE (size_type_node
))
1053 size
= fold_convert (size_type_node
, size
);
1055 /* Create a variable to hold the result. */
1056 res
= gfc_create_var (type
, NULL
);
1058 /* Call realloc and check the result. */
1059 tmp
= build_call_expr_loc (input_location
,
1060 builtin_decl_explicit (BUILT_IN_REALLOC
), 2,
1061 fold_convert (pvoid_type_node
, mem
), size
);
1062 gfc_add_modify (block
, res
, fold_convert (type
, tmp
));
1063 null_result
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
1064 res
, build_int_cst (pvoid_type_node
, 0));
1065 nonzero
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, size
,
1066 build_int_cst (size_type_node
, 0));
1067 null_result
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, boolean_type_node
,
1068 null_result
, nonzero
);
1069 msg
= gfc_build_addr_expr (pchar_type_node
, gfc_build_localized_cstring_const
1070 ("Allocation would exceed memory limit"));
1071 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1073 build_call_expr_loc (input_location
,
1074 gfor_fndecl_os_error
, 1, msg
),
1075 build_empty_stmt (input_location
));
1076 gfc_add_expr_to_block (block
, tmp
);
1078 /* if (size == 0) then the result is NULL. */
1079 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, type
, res
,
1080 build_int_cst (type
, 0));
1081 zero
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
, boolean_type_node
,
1083 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, zero
, tmp
,
1084 build_empty_stmt (input_location
));
1085 gfc_add_expr_to_block (block
, tmp
);
1091 /* Add an expression to another one, either at the front or the back. */
1094 add_expr_to_chain (tree
* chain
, tree expr
, bool front
)
1096 if (expr
== NULL_TREE
|| IS_EMPTY_STMT (expr
))
1101 if (TREE_CODE (*chain
) != STATEMENT_LIST
)
1107 append_to_statement_list (tmp
, chain
);
1112 tree_stmt_iterator i
;
1114 i
= tsi_start (*chain
);
1115 tsi_link_before (&i
, expr
, TSI_CONTINUE_LINKING
);
1118 append_to_statement_list (expr
, chain
);
1125 /* Add a statement at the end of a block. */
1128 gfc_add_expr_to_block (stmtblock_t
* block
, tree expr
)
1131 add_expr_to_chain (&block
->head
, expr
, false);
1135 /* Add a statement at the beginning of a block. */
1138 gfc_prepend_expr_to_block (stmtblock_t
* block
, tree expr
)
1141 add_expr_to_chain (&block
->head
, expr
, true);
1145 /* Add a block the end of a block. */
1148 gfc_add_block_to_block (stmtblock_t
* block
, stmtblock_t
* append
)
1150 gcc_assert (append
);
1151 gcc_assert (!append
->has_scope
);
1153 gfc_add_expr_to_block (block
, append
->head
);
1154 append
->head
= NULL_TREE
;
1158 /* Save the current locus. The structure may not be complete, and should
1159 only be used with gfc_restore_backend_locus. */
1162 gfc_save_backend_locus (locus
* loc
)
1164 loc
->lb
= XCNEW (gfc_linebuf
);
1165 loc
->lb
->location
= input_location
;
1166 loc
->lb
->file
= gfc_current_backend_file
;
1170 /* Set the current locus. */
1173 gfc_set_backend_locus (locus
* loc
)
1175 gfc_current_backend_file
= loc
->lb
->file
;
1176 input_location
= loc
->lb
->location
;
1180 /* Restore the saved locus. Only used in conjonction with
1181 gfc_save_backend_locus, to free the memory when we are done. */
1184 gfc_restore_backend_locus (locus
* loc
)
1186 gfc_set_backend_locus (loc
);
1191 /* Translate an executable statement. The tree cond is used by gfc_trans_do.
1192 This static function is wrapped by gfc_trans_code_cond and
1196 trans_code (gfc_code
* code
, tree cond
)
1202 return build_empty_stmt (input_location
);
1204 gfc_start_block (&block
);
1206 /* Translate statements one by one into GENERIC trees until we reach
1207 the end of this gfc_code branch. */
1208 for (; code
; code
= code
->next
)
1210 if (code
->here
!= 0)
1212 res
= gfc_trans_label_here (code
);
1213 gfc_add_expr_to_block (&block
, res
);
1216 gfc_set_backend_locus (&code
->loc
);
1221 case EXEC_END_BLOCK
:
1222 case EXEC_END_NESTED_BLOCK
:
1223 case EXEC_END_PROCEDURE
:
1228 if (code
->expr1
->ts
.type
== BT_CLASS
)
1229 res
= gfc_trans_class_assign (code
->expr1
, code
->expr2
, code
->op
);
1231 res
= gfc_trans_assign (code
);
1234 case EXEC_LABEL_ASSIGN
:
1235 res
= gfc_trans_label_assign (code
);
1238 case EXEC_POINTER_ASSIGN
:
1239 if (code
->expr1
->ts
.type
== BT_CLASS
)
1240 res
= gfc_trans_class_assign (code
->expr1
, code
->expr2
, code
->op
);
1242 res
= gfc_trans_pointer_assign (code
);
1245 case EXEC_INIT_ASSIGN
:
1246 if (code
->expr1
->ts
.type
== BT_CLASS
)
1247 res
= gfc_trans_class_init_assign (code
);
1249 res
= gfc_trans_init_assign (code
);
1257 res
= gfc_trans_critical (code
);
1261 res
= gfc_trans_cycle (code
);
1265 res
= gfc_trans_exit (code
);
1269 res
= gfc_trans_goto (code
);
1273 res
= gfc_trans_entry (code
);
1277 res
= gfc_trans_pause (code
);
1281 case EXEC_ERROR_STOP
:
1282 res
= gfc_trans_stop (code
, code
->op
== EXEC_ERROR_STOP
);
1286 /* For MVBITS we've got the special exception that we need a
1287 dependency check, too. */
1289 bool is_mvbits
= false;
1291 if (code
->resolved_isym
)
1293 res
= gfc_conv_intrinsic_subroutine (code
);
1294 if (res
!= NULL_TREE
)
1298 if (code
->resolved_isym
1299 && code
->resolved_isym
->id
== GFC_ISYM_MVBITS
)
1302 res
= gfc_trans_call (code
, is_mvbits
, NULL_TREE
,
1308 res
= gfc_trans_call (code
, false, NULL_TREE
,
1312 case EXEC_ASSIGN_CALL
:
1313 res
= gfc_trans_call (code
, true, NULL_TREE
,
1318 res
= gfc_trans_return (code
);
1322 res
= gfc_trans_if (code
);
1325 case EXEC_ARITHMETIC_IF
:
1326 res
= gfc_trans_arithmetic_if (code
);
1330 res
= gfc_trans_block_construct (code
);
1334 res
= gfc_trans_do (code
, cond
);
1337 case EXEC_DO_CONCURRENT
:
1338 res
= gfc_trans_do_concurrent (code
);
1342 res
= gfc_trans_do_while (code
);
1346 res
= gfc_trans_select (code
);
1349 case EXEC_SELECT_TYPE
:
1350 /* Do nothing. SELECT TYPE statements should be transformed into
1351 an ordinary SELECT CASE at resolution stage.
1352 TODO: Add an error message here once this is done. */
1357 res
= gfc_trans_flush (code
);
1361 case EXEC_SYNC_IMAGES
:
1362 case EXEC_SYNC_MEMORY
:
1363 res
= gfc_trans_sync (code
, code
->op
);
1368 res
= gfc_trans_lock_unlock (code
, code
->op
);
1372 res
= gfc_trans_forall (code
);
1376 res
= gfc_trans_where (code
);
1380 res
= gfc_trans_allocate (code
);
1383 case EXEC_DEALLOCATE
:
1384 res
= gfc_trans_deallocate (code
);
1388 res
= gfc_trans_open (code
);
1392 res
= gfc_trans_close (code
);
1396 res
= gfc_trans_read (code
);
1400 res
= gfc_trans_write (code
);
1404 res
= gfc_trans_iolength (code
);
1407 case EXEC_BACKSPACE
:
1408 res
= gfc_trans_backspace (code
);
1412 res
= gfc_trans_endfile (code
);
1416 res
= gfc_trans_inquire (code
);
1420 res
= gfc_trans_wait (code
);
1424 res
= gfc_trans_rewind (code
);
1428 res
= gfc_trans_transfer (code
);
1432 res
= gfc_trans_dt_end (code
);
1435 case EXEC_OMP_ATOMIC
:
1436 case EXEC_OMP_BARRIER
:
1437 case EXEC_OMP_CRITICAL
:
1439 case EXEC_OMP_FLUSH
:
1440 case EXEC_OMP_MASTER
:
1441 case EXEC_OMP_ORDERED
:
1442 case EXEC_OMP_PARALLEL
:
1443 case EXEC_OMP_PARALLEL_DO
:
1444 case EXEC_OMP_PARALLEL_SECTIONS
:
1445 case EXEC_OMP_PARALLEL_WORKSHARE
:
1446 case EXEC_OMP_SECTIONS
:
1447 case EXEC_OMP_SINGLE
:
1449 case EXEC_OMP_TASKWAIT
:
1450 case EXEC_OMP_TASKYIELD
:
1451 case EXEC_OMP_WORKSHARE
:
1452 res
= gfc_trans_omp_directive (code
);
1456 internal_error ("gfc_trans_code(): Bad statement code");
1459 gfc_set_backend_locus (&code
->loc
);
1461 if (res
!= NULL_TREE
&& ! IS_EMPTY_STMT (res
))
1463 if (TREE_CODE (res
) != STATEMENT_LIST
)
1464 SET_EXPR_LOCATION (res
, input_location
);
1466 /* Add the new statement to the block. */
1467 gfc_add_expr_to_block (&block
, res
);
1471 /* Return the finished block. */
1472 return gfc_finish_block (&block
);
1476 /* Translate an executable statement with condition, cond. The condition is
1477 used by gfc_trans_do to test for IO result conditions inside implied
1478 DO loops of READ and WRITE statements. See build_dt in trans-io.c. */
1481 gfc_trans_code_cond (gfc_code
* code
, tree cond
)
1483 return trans_code (code
, cond
);
1486 /* Translate an executable statement without condition. */
1489 gfc_trans_code (gfc_code
* code
)
1491 return trans_code (code
, NULL_TREE
);
1495 /* This function is called after a complete program unit has been parsed
1499 gfc_generate_code (gfc_namespace
* ns
)
1502 if (ns
->is_block_data
)
1504 gfc_generate_block_data (ns
);
1508 gfc_generate_function_code (ns
);
1512 /* This function is called after a complete module has been parsed
1516 gfc_generate_module_code (gfc_namespace
* ns
)
1519 struct module_htab_entry
*entry
;
1521 gcc_assert (ns
->proc_name
->backend_decl
== NULL
);
1522 ns
->proc_name
->backend_decl
1523 = build_decl (ns
->proc_name
->declared_at
.lb
->location
,
1524 NAMESPACE_DECL
, get_identifier (ns
->proc_name
->name
),
1526 entry
= gfc_find_module (ns
->proc_name
->name
);
1527 if (entry
->namespace_decl
)
1528 /* Buggy sourcecode, using a module before defining it? */
1529 htab_empty (entry
->decls
);
1530 entry
->namespace_decl
= ns
->proc_name
->backend_decl
;
1532 gfc_generate_module_vars (ns
);
1534 /* We need to generate all module function prototypes first, to allow
1536 for (n
= ns
->contained
; n
; n
= n
->sibling
)
1543 gfc_create_function_decl (n
, false);
1544 DECL_CONTEXT (n
->proc_name
->backend_decl
) = ns
->proc_name
->backend_decl
;
1545 gfc_module_add_decl (entry
, n
->proc_name
->backend_decl
);
1546 for (el
= ns
->entries
; el
; el
= el
->next
)
1548 DECL_CONTEXT (el
->sym
->backend_decl
) = ns
->proc_name
->backend_decl
;
1549 gfc_module_add_decl (entry
, el
->sym
->backend_decl
);
1553 for (n
= ns
->contained
; n
; n
= n
->sibling
)
1558 gfc_generate_function_code (n
);
1563 /* Initialize an init/cleanup block with existing code. */
1566 gfc_start_wrapped_block (gfc_wrapped_block
* block
, tree code
)
1570 block
->init
= NULL_TREE
;
1572 block
->cleanup
= NULL_TREE
;
1576 /* Add a new pair of initializers/clean-up code. */
1579 gfc_add_init_cleanup (gfc_wrapped_block
* block
, tree init
, tree cleanup
)
1583 /* The new pair of init/cleanup should be "wrapped around" the existing
1584 block of code, thus the initialization is added to the front and the
1585 cleanup to the back. */
1586 add_expr_to_chain (&block
->init
, init
, true);
1587 add_expr_to_chain (&block
->cleanup
, cleanup
, false);
1591 /* Finish up a wrapped block by building a corresponding try-finally expr. */
1594 gfc_finish_wrapped_block (gfc_wrapped_block
* block
)
1600 /* Build the final expression. For this, just add init and body together,
1601 and put clean-up with that into a TRY_FINALLY_EXPR. */
1602 result
= block
->init
;
1603 add_expr_to_chain (&result
, block
->code
, false);
1605 result
= build2_loc (input_location
, TRY_FINALLY_EXPR
, void_type_node
,
1606 result
, block
->cleanup
);
1608 /* Clear the block. */
1609 block
->init
= NULL_TREE
;
1610 block
->code
= NULL_TREE
;
1611 block
->cleanup
= NULL_TREE
;
1617 /* Helper function for marking a boolean expression tree as unlikely. */
1620 gfc_unlikely (tree cond
)
1624 cond
= fold_convert (long_integer_type_node
, cond
);
1625 tmp
= build_zero_cst (long_integer_type_node
);
1626 cond
= build_call_expr_loc (input_location
,
1627 builtin_decl_explicit (BUILT_IN_EXPECT
),
1629 cond
= fold_convert (boolean_type_node
, cond
);
1634 /* Helper function for marking a boolean expression tree as likely. */
1637 gfc_likely (tree cond
)
1641 cond
= fold_convert (long_integer_type_node
, cond
);
1642 tmp
= build_one_cst (long_integer_type_node
);
1643 cond
= build_call_expr_loc (input_location
,
1644 builtin_decl_explicit (BUILT_IN_EXPECT
),
1646 cond
= fold_convert (boolean_type_node
, cond
);