1 /* Code translation -- generate GCC trees from gfc_code.
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free
3 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"
27 #include "tree-iterator.h"
35 #include "trans-stmt.h"
36 #include "trans-array.h"
37 #include "trans-types.h"
38 #include "trans-const.h"
40 /* Naming convention for backend interface code:
42 gfc_trans_* translate gfc_code into STMT trees.
44 gfc_conv_* expression conversion
46 gfc_get_* get a backend tree representation of a decl or type */
48 static gfc_file
*gfc_current_backend_file
;
50 const char gfc_msg_bounds
[] = N_("Array bound mismatch");
51 const char gfc_msg_fault
[] = N_("Array reference out of bounds");
52 const char gfc_msg_wrong_return
[] = N_("Incorrect function return value");
55 /* Advance along TREE_CHAIN n times. */
58 gfc_advance_chain (tree t
, int n
)
62 gcc_assert (t
!= NULL_TREE
);
69 /* Wrap a node in a TREE_LIST node and add it to the end of a list. */
72 gfc_chainon_list (tree list
, tree add
)
76 l
= tree_cons (NULL_TREE
, add
, NULL_TREE
);
78 return chainon (list
, l
);
82 /* Strip off a legitimate source ending from the input
83 string NAME of length LEN. */
86 remove_suffix (char *name
, int len
)
90 for (i
= 2; i
< 8 && len
> i
; i
++)
92 if (name
[len
- i
] == '.')
101 /* Creates a variable declaration with a given TYPE. */
104 gfc_create_var_np (tree type
, const char *prefix
)
108 t
= create_tmp_var_raw (type
, prefix
);
110 /* No warnings for anonymous variables. */
112 TREE_NO_WARNING (t
) = 1;
118 /* Like above, but also adds it to the current scope. */
121 gfc_create_var (tree type
, const char *prefix
)
125 tmp
= gfc_create_var_np (type
, prefix
);
133 /* If the expression is not constant, evaluate it now. We assign the
134 result of the expression to an artificially created variable VAR, and
135 return a pointer to the VAR_DECL node for this variable. */
138 gfc_evaluate_now (tree expr
, stmtblock_t
* pblock
)
142 if (CONSTANT_CLASS_P (expr
))
145 var
= gfc_create_var (TREE_TYPE (expr
), NULL
);
146 gfc_add_modify (pblock
, var
, expr
);
152 /* Build a MODIFY_EXPR node and add it to a given statement block PBLOCK.
153 A MODIFY_EXPR is an assignment:
157 gfc_add_modify (stmtblock_t
* pblock
, tree lhs
, tree rhs
)
161 #ifdef ENABLE_CHECKING
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. */
166 gcc_assert (TREE_TYPE (rhs
) == TREE_TYPE (lhs
)
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 (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 directly. */
418 fntype
= TREE_TYPE (gfor_fndecl_runtime_error_at
);
420 fntype
= TREE_TYPE (gfor_fndecl_runtime_warning_at
);
422 tmp
= fold_builtin_call_array (TREE_TYPE (fntype
),
423 fold_build1 (ADDR_EXPR
,
424 build_pointer_type (fntype
),
426 ? gfor_fndecl_runtime_error_at
427 : gfor_fndecl_runtime_warning_at
),
428 nargs
+ 2, argarray
);
429 gfc_add_expr_to_block (&block
, tmp
);
431 return gfc_finish_block (&block
);
435 /* Generate a runtime error if COND is true. */
438 gfc_trans_runtime_check (bool error
, bool once
, tree cond
, stmtblock_t
* pblock
,
439 locus
* where
, const char * msgid
, ...)
447 if (integer_zerop (cond
))
452 tmpvar
= gfc_create_var (boolean_type_node
, "print_warning");
453 TREE_STATIC (tmpvar
) = 1;
454 DECL_INITIAL (tmpvar
) = boolean_true_node
;
455 gfc_add_expr_to_block (pblock
, tmpvar
);
458 gfc_start_block (&block
);
460 /* The code to generate the error. */
461 va_start (ap
, msgid
);
462 gfc_add_expr_to_block (&block
,
463 gfc_trans_runtime_error_vararg (error
, where
,
467 gfc_add_modify (&block
, tmpvar
, boolean_false_node
);
469 body
= gfc_finish_block (&block
);
471 if (integer_onep (cond
))
473 gfc_add_expr_to_block (pblock
, body
);
477 /* Tell the compiler that this isn't likely. */
479 cond
= fold_build2 (TRUTH_AND_EXPR
, long_integer_type_node
, tmpvar
,
482 cond
= fold_convert (long_integer_type_node
, cond
);
484 tmp
= build_int_cst (long_integer_type_node
, 0);
485 cond
= build_call_expr (built_in_decls
[BUILT_IN_EXPECT
], 2, cond
, tmp
);
486 cond
= fold_convert (boolean_type_node
, cond
);
488 tmp
= build3_v (COND_EXPR
, cond
, body
, build_empty_stmt (input_location
));
489 gfc_add_expr_to_block (pblock
, tmp
);
494 /* Call malloc to allocate size bytes of memory, with special conditions:
495 + if size < 0, generate a runtime error,
496 + if size == 0, return a malloced area of size 1,
497 + if malloc returns NULL, issue a runtime error. */
499 gfc_call_malloc (stmtblock_t
* block
, tree type
, tree size
)
501 tree tmp
, msg
, negative
, malloc_result
, null_result
, res
;
504 size
= gfc_evaluate_now (size
, block
);
506 if (TREE_TYPE (size
) != TREE_TYPE (size_type_node
))
507 size
= fold_convert (size_type_node
, size
);
509 /* Create a variable to hold the result. */
510 res
= gfc_create_var (pvoid_type_node
, NULL
);
513 negative
= fold_build2 (LT_EXPR
, boolean_type_node
, size
,
514 build_int_cst (size_type_node
, 0));
515 msg
= gfc_build_addr_expr (pchar_type_node
, gfc_build_localized_cstring_const
516 ("Attempt to allocate a negative amount of memory."));
517 tmp
= fold_build3 (COND_EXPR
, void_type_node
, negative
,
518 build_call_expr (gfor_fndecl_runtime_error
, 1, msg
),
519 build_empty_stmt (input_location
));
520 gfc_add_expr_to_block (block
, tmp
);
522 /* Call malloc and check the result. */
523 gfc_start_block (&block2
);
525 size
= fold_build2 (MAX_EXPR
, size_type_node
, size
,
526 build_int_cst (size_type_node
, 1));
528 gfc_add_modify (&block2
, res
,
529 build_call_expr (built_in_decls
[BUILT_IN_MALLOC
], 1,
531 null_result
= fold_build2 (EQ_EXPR
, boolean_type_node
, res
,
532 build_int_cst (pvoid_type_node
, 0));
533 msg
= gfc_build_addr_expr (pchar_type_node
, gfc_build_localized_cstring_const
534 ("Memory allocation failed"));
535 tmp
= fold_build3 (COND_EXPR
, void_type_node
, null_result
,
536 build_call_expr (gfor_fndecl_os_error
, 1, msg
),
537 build_empty_stmt (input_location
));
538 gfc_add_expr_to_block (&block2
, tmp
);
539 malloc_result
= gfc_finish_block (&block2
);
541 gfc_add_expr_to_block (block
, malloc_result
);
544 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 (pvoid_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 (gfor_fndecl_runtime_error
, 1, msg
);
620 if (status
!= NULL_TREE
&& !integer_zerop (status
))
622 /* Set the status variable if it's present. */
623 stmtblock_t set_status_block
;
625 gfc_start_block (&set_status_block
);
626 gfc_add_modify (&set_status_block
,
627 fold_build1 (INDIRECT_REF
, status_type
, status
),
628 build_int_cst (status_type
, LIBERROR_ALLOCATION
));
629 gfc_add_modify (&set_status_block
, res
,
630 build_int_cst (pvoid_type_node
, 0));
632 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, status
,
633 build_int_cst (TREE_TYPE (status
), 0));
634 error
= fold_build3 (COND_EXPR
, void_type_node
, tmp
, error
,
635 gfc_finish_block (&set_status_block
));
638 /* The allocation itself. */
639 gfc_start_block (&alloc_block
);
640 gfc_add_modify (&alloc_block
, res
,
641 build_call_expr (built_in_decls
[BUILT_IN_MALLOC
], 1,
642 fold_build2 (MAX_EXPR
, size_type_node
,
644 build_int_cst (size_type_node
, 1))));
646 msg
= gfc_build_addr_expr (pchar_type_node
, gfc_build_localized_cstring_const
648 tmp
= build_call_expr (gfor_fndecl_os_error
, 1, msg
);
650 if (status
!= NULL_TREE
&& !integer_zerop (status
))
652 /* Set the status variable if it's present. */
655 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
, status
,
656 build_int_cst (TREE_TYPE (status
), 0));
657 tmp2
= fold_build2 (MODIFY_EXPR
, status_type
,
658 fold_build1 (INDIRECT_REF
, status_type
, status
),
659 build_int_cst (status_type
, LIBERROR_ALLOCATION
));
660 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond
, tmp
,
664 tmp
= fold_build3 (COND_EXPR
, void_type_node
,
665 fold_build2 (EQ_EXPR
, boolean_type_node
, res
,
666 build_int_cst (pvoid_type_node
, 0)),
667 tmp
, build_empty_stmt (input_location
));
668 gfc_add_expr_to_block (&alloc_block
, tmp
);
670 cond
= fold_build2 (LT_EXPR
, boolean_type_node
, size
,
671 build_int_cst (TREE_TYPE (size
), 0));
672 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond
, error
,
673 gfc_finish_block (&alloc_block
));
674 gfc_add_expr_to_block (block
, tmp
);
680 /* Generate code for an ALLOCATE statement when the argument is an
681 allocatable array. If the array is currently allocated, it is an
682 error to allocate it again.
684 This function follows the following pseudo-code:
687 allocate_array (void *mem, size_t size, integer_type *stat)
690 return allocate (size, stat);
696 mem = allocate (size, stat);
697 *stat = LIBERROR_ALLOCATION;
701 runtime_error ("Attempting to allocate already allocated array");
704 expr must be set to the original expression being allocated for its locus
705 and variable name in case a runtime error has to be printed. */
707 gfc_allocate_array_with_status (stmtblock_t
* block
, tree mem
, tree size
,
708 tree status
, gfc_expr
* expr
)
710 stmtblock_t alloc_block
;
711 tree res
, tmp
, null_mem
, alloc
, error
;
712 tree type
= TREE_TYPE (mem
);
714 if (TREE_TYPE (size
) != TREE_TYPE (size_type_node
))
715 size
= fold_convert (size_type_node
, size
);
717 /* Create a variable to hold the result. */
718 res
= gfc_create_var (pvoid_type_node
, NULL
);
719 null_mem
= fold_build2 (EQ_EXPR
, boolean_type_node
, mem
,
720 build_int_cst (type
, 0));
722 /* If mem is NULL, we call gfc_allocate_with_status. */
723 gfc_start_block (&alloc_block
);
724 tmp
= gfc_allocate_with_status (&alloc_block
, size
, status
);
725 gfc_add_modify (&alloc_block
, res
, fold_convert (type
, tmp
));
726 alloc
= gfc_finish_block (&alloc_block
);
728 /* Otherwise, we issue a runtime error or set the status variable. */
733 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
&& expr
->symtree
);
734 varname
= gfc_build_cstring_const (expr
->symtree
->name
);
735 varname
= gfc_build_addr_expr (pchar_type_node
, varname
);
737 error
= gfc_trans_runtime_error (true, &expr
->where
,
738 "Attempting to allocate already"
739 " allocated array '%s'",
743 error
= gfc_trans_runtime_error (true, NULL
,
744 "Attempting to allocate already allocated"
747 if (status
!= NULL_TREE
&& !integer_zerop (status
))
749 tree status_type
= TREE_TYPE (TREE_TYPE (status
));
750 stmtblock_t set_status_block
;
752 gfc_start_block (&set_status_block
);
753 tmp
= build_call_expr (built_in_decls
[BUILT_IN_FREE
], 1,
754 fold_convert (pvoid_type_node
, mem
));
755 gfc_add_expr_to_block (&set_status_block
, tmp
);
757 tmp
= gfc_allocate_with_status (&set_status_block
, size
, status
);
758 gfc_add_modify (&set_status_block
, res
, fold_convert (type
, tmp
));
760 gfc_add_modify (&set_status_block
,
761 fold_build1 (INDIRECT_REF
, status_type
, status
),
762 build_int_cst (status_type
, LIBERROR_ALLOCATION
));
764 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, status
,
765 build_int_cst (status_type
, 0));
766 error
= fold_build3 (COND_EXPR
, void_type_node
, tmp
, error
,
767 gfc_finish_block (&set_status_block
));
770 tmp
= fold_build3 (COND_EXPR
, void_type_node
, null_mem
, alloc
, error
);
771 gfc_add_expr_to_block (block
, tmp
);
777 /* Free a given variable, if it's not NULL. */
779 gfc_call_free (tree var
)
782 tree tmp
, cond
, call
;
784 if (TREE_TYPE (var
) != TREE_TYPE (pvoid_type_node
))
785 var
= fold_convert (pvoid_type_node
, var
);
787 gfc_start_block (&block
);
788 var
= gfc_evaluate_now (var
, &block
);
789 cond
= fold_build2 (NE_EXPR
, boolean_type_node
, var
,
790 build_int_cst (pvoid_type_node
, 0));
791 call
= build_call_expr (built_in_decls
[BUILT_IN_FREE
], 1, var
);
792 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond
, call
,
793 build_empty_stmt (input_location
));
794 gfc_add_expr_to_block (&block
, tmp
);
796 return gfc_finish_block (&block
);
801 /* User-deallocate; we emit the code directly from the front-end, and the
802 logic is the same as the previous library function:
805 deallocate (void *pointer, GFC_INTEGER_4 * stat)
812 runtime_error ("Attempt to DEALLOCATE unallocated memory.");
822 In this front-end version, status doesn't have to be GFC_INTEGER_4.
823 Moreover, if CAN_FAIL is true, then we will not emit a runtime error,
824 even when no status variable is passed to us (this is used for
825 unconditional deallocation generated by the front-end at end of
828 If a runtime-message is possible, `expr' must point to the original
829 expression being deallocated for its locus and variable name. */
831 gfc_deallocate_with_status (tree pointer
, tree status
, bool can_fail
,
834 stmtblock_t null
, non_null
;
835 tree cond
, tmp
, error
;
837 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
, pointer
,
838 build_int_cst (TREE_TYPE (pointer
), 0));
840 /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
841 we emit a runtime error. */
842 gfc_start_block (&null
);
847 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
&& expr
->symtree
);
849 varname
= gfc_build_cstring_const (expr
->symtree
->name
);
850 varname
= gfc_build_addr_expr (pchar_type_node
, varname
);
852 error
= gfc_trans_runtime_error (true, &expr
->where
,
853 "Attempt to DEALLOCATE unallocated '%s'",
857 error
= build_empty_stmt (input_location
);
859 if (status
!= NULL_TREE
&& !integer_zerop (status
))
861 tree status_type
= TREE_TYPE (TREE_TYPE (status
));
864 cond2
= fold_build2 (NE_EXPR
, boolean_type_node
, status
,
865 build_int_cst (TREE_TYPE (status
), 0));
866 tmp
= fold_build2 (MODIFY_EXPR
, status_type
,
867 fold_build1 (INDIRECT_REF
, status_type
, status
),
868 build_int_cst (status_type
, 1));
869 error
= fold_build3 (COND_EXPR
, void_type_node
, cond2
, tmp
, error
);
872 gfc_add_expr_to_block (&null
, error
);
874 /* When POINTER is not NULL, we free it. */
875 gfc_start_block (&non_null
);
876 tmp
= build_call_expr (built_in_decls
[BUILT_IN_FREE
], 1,
877 fold_convert (pvoid_type_node
, pointer
));
878 gfc_add_expr_to_block (&non_null
, tmp
);
880 if (status
!= NULL_TREE
&& !integer_zerop (status
))
882 /* We set STATUS to zero if it is present. */
883 tree status_type
= TREE_TYPE (TREE_TYPE (status
));
886 cond2
= fold_build2 (NE_EXPR
, boolean_type_node
, status
,
887 build_int_cst (TREE_TYPE (status
), 0));
888 tmp
= fold_build2 (MODIFY_EXPR
, status_type
,
889 fold_build1 (INDIRECT_REF
, status_type
, status
),
890 build_int_cst (status_type
, 0));
891 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond2
, tmp
,
892 build_empty_stmt (input_location
));
893 gfc_add_expr_to_block (&non_null
, tmp
);
896 return fold_build3 (COND_EXPR
, void_type_node
, cond
,
897 gfc_finish_block (&null
), gfc_finish_block (&non_null
));
901 /* Reallocate MEM so it has SIZE bytes of data. This behaves like the
902 following pseudo-code:
905 internal_realloc (void *mem, size_t size)
908 runtime_error ("Attempt to allocate a negative amount of memory.");
909 res = realloc (mem, size);
910 if (!res && size != 0)
911 _gfortran_os_error ("Out of memory");
919 gfc_call_realloc (stmtblock_t
* block
, tree mem
, tree size
)
921 tree msg
, res
, negative
, nonzero
, zero
, null_result
, tmp
;
922 tree type
= TREE_TYPE (mem
);
924 size
= gfc_evaluate_now (size
, block
);
926 if (TREE_TYPE (size
) != TREE_TYPE (size_type_node
))
927 size
= fold_convert (size_type_node
, size
);
929 /* Create a variable to hold the result. */
930 res
= gfc_create_var (type
, NULL
);
933 negative
= fold_build2 (LT_EXPR
, boolean_type_node
, size
,
934 build_int_cst (size_type_node
, 0));
935 msg
= gfc_build_addr_expr (pchar_type_node
, gfc_build_localized_cstring_const
936 ("Attempt to allocate a negative amount of memory."));
937 tmp
= fold_build3 (COND_EXPR
, void_type_node
, negative
,
938 build_call_expr (gfor_fndecl_runtime_error
, 1, msg
),
939 build_empty_stmt (input_location
));
940 gfc_add_expr_to_block (block
, tmp
);
942 /* Call realloc and check the result. */
943 tmp
= build_call_expr (built_in_decls
[BUILT_IN_REALLOC
], 2,
944 fold_convert (pvoid_type_node
, mem
), size
);
945 gfc_add_modify (block
, res
, fold_convert (type
, tmp
));
946 null_result
= fold_build2 (EQ_EXPR
, boolean_type_node
, res
,
947 build_int_cst (pvoid_type_node
, 0));
948 nonzero
= fold_build2 (NE_EXPR
, boolean_type_node
, size
,
949 build_int_cst (size_type_node
, 0));
950 null_result
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
, null_result
,
952 msg
= gfc_build_addr_expr (pchar_type_node
, gfc_build_localized_cstring_const
954 tmp
= fold_build3 (COND_EXPR
, void_type_node
, null_result
,
955 build_call_expr (gfor_fndecl_os_error
, 1, msg
),
956 build_empty_stmt (input_location
));
957 gfc_add_expr_to_block (block
, tmp
);
959 /* if (size == 0) then the result is NULL. */
960 tmp
= fold_build2 (MODIFY_EXPR
, type
, res
, build_int_cst (type
, 0));
961 zero
= fold_build1 (TRUTH_NOT_EXPR
, boolean_type_node
, nonzero
);
962 tmp
= fold_build3 (COND_EXPR
, void_type_node
, zero
, tmp
,
963 build_empty_stmt (input_location
));
964 gfc_add_expr_to_block (block
, tmp
);
969 /* Add a statement to a block. */
972 gfc_add_expr_to_block (stmtblock_t
* block
, tree expr
)
976 if (expr
== NULL_TREE
|| IS_EMPTY_STMT (expr
))
981 if (TREE_CODE (block
->head
) != STATEMENT_LIST
)
986 block
->head
= NULL_TREE
;
987 append_to_statement_list (tmp
, &block
->head
);
989 append_to_statement_list (expr
, &block
->head
);
992 /* Don't bother creating a list if we only have a single statement. */
997 /* Add a block the end of a block. */
1000 gfc_add_block_to_block (stmtblock_t
* block
, stmtblock_t
* append
)
1002 gcc_assert (append
);
1003 gcc_assert (!append
->has_scope
);
1005 gfc_add_expr_to_block (block
, append
->head
);
1006 append
->head
= NULL_TREE
;
1010 /* Get the current locus. The structure may not be complete, and should
1011 only be used with gfc_set_backend_locus. */
1014 gfc_get_backend_locus (locus
* loc
)
1016 loc
->lb
= XCNEW (gfc_linebuf
);
1017 loc
->lb
->location
= input_location
;
1018 loc
->lb
->file
= gfc_current_backend_file
;
1022 /* Set the current locus. */
1025 gfc_set_backend_locus (locus
* loc
)
1027 gfc_current_backend_file
= loc
->lb
->file
;
1028 input_location
= loc
->lb
->location
;
1032 /* Translate an executable statement. */
1035 gfc_trans_code (gfc_code
* code
)
1041 return build_empty_stmt (input_location
);
1043 gfc_start_block (&block
);
1045 /* Translate statements one by one into GENERIC trees until we reach
1046 the end of this gfc_code branch. */
1047 for (; code
; code
= code
->next
)
1049 if (code
->here
!= 0)
1051 res
= gfc_trans_label_here (code
);
1052 gfc_add_expr_to_block (&block
, res
);
1058 case EXEC_END_BLOCK
:
1059 case EXEC_END_PROCEDURE
:
1064 res
= gfc_trans_assign (code
);
1067 case EXEC_LABEL_ASSIGN
:
1068 res
= gfc_trans_label_assign (code
);
1071 case EXEC_POINTER_ASSIGN
:
1072 res
= gfc_trans_pointer_assign (code
);
1075 case EXEC_INIT_ASSIGN
:
1076 res
= gfc_trans_init_assign (code
);
1084 res
= gfc_trans_cycle (code
);
1088 res
= gfc_trans_exit (code
);
1092 res
= gfc_trans_goto (code
);
1096 res
= gfc_trans_entry (code
);
1100 res
= gfc_trans_pause (code
);
1104 res
= gfc_trans_stop (code
);
1108 /* For MVBITS we've got the special exception that we need a
1109 dependency check, too. */
1111 bool is_mvbits
= false;
1112 if (code
->resolved_isym
1113 && code
->resolved_isym
->id
== GFC_ISYM_MVBITS
)
1115 res
= gfc_trans_call (code
, is_mvbits
, NULL_TREE
,
1121 res
= gfc_trans_call (code
, false, NULL_TREE
,
1125 case EXEC_ASSIGN_CALL
:
1126 res
= gfc_trans_call (code
, true, NULL_TREE
,
1131 res
= gfc_trans_return (code
);
1135 res
= gfc_trans_if (code
);
1138 case EXEC_ARITHMETIC_IF
:
1139 res
= gfc_trans_arithmetic_if (code
);
1143 res
= gfc_trans_do (code
);
1147 res
= gfc_trans_do_while (code
);
1151 res
= gfc_trans_select (code
);
1155 res
= gfc_trans_flush (code
);
1159 res
= gfc_trans_forall (code
);
1163 res
= gfc_trans_where (code
);
1167 res
= gfc_trans_allocate (code
);
1170 case EXEC_DEALLOCATE
:
1171 res
= gfc_trans_deallocate (code
);
1175 res
= gfc_trans_open (code
);
1179 res
= gfc_trans_close (code
);
1183 res
= gfc_trans_read (code
);
1187 res
= gfc_trans_write (code
);
1191 res
= gfc_trans_iolength (code
);
1194 case EXEC_BACKSPACE
:
1195 res
= gfc_trans_backspace (code
);
1199 res
= gfc_trans_endfile (code
);
1203 res
= gfc_trans_inquire (code
);
1207 res
= gfc_trans_wait (code
);
1211 res
= gfc_trans_rewind (code
);
1215 res
= gfc_trans_transfer (code
);
1219 res
= gfc_trans_dt_end (code
);
1222 case EXEC_OMP_ATOMIC
:
1223 case EXEC_OMP_BARRIER
:
1224 case EXEC_OMP_CRITICAL
:
1226 case EXEC_OMP_FLUSH
:
1227 case EXEC_OMP_MASTER
:
1228 case EXEC_OMP_ORDERED
:
1229 case EXEC_OMP_PARALLEL
:
1230 case EXEC_OMP_PARALLEL_DO
:
1231 case EXEC_OMP_PARALLEL_SECTIONS
:
1232 case EXEC_OMP_PARALLEL_WORKSHARE
:
1233 case EXEC_OMP_SECTIONS
:
1234 case EXEC_OMP_SINGLE
:
1236 case EXEC_OMP_TASKWAIT
:
1237 case EXEC_OMP_WORKSHARE
:
1238 res
= gfc_trans_omp_directive (code
);
1242 internal_error ("gfc_trans_code(): Bad statement code");
1245 gfc_set_backend_locus (&code
->loc
);
1247 if (res
!= NULL_TREE
&& ! IS_EMPTY_STMT (res
))
1249 if (TREE_CODE (res
) == STATEMENT_LIST
)
1250 tree_annotate_all_with_location (&res
, input_location
);
1252 SET_EXPR_LOCATION (res
, input_location
);
1254 /* Add the new statement to the block. */
1255 gfc_add_expr_to_block (&block
, res
);
1259 /* Return the finished block. */
1260 return gfc_finish_block (&block
);
1264 /* This function is called after a complete program unit has been parsed
1268 gfc_generate_code (gfc_namespace
* ns
)
1271 if (ns
->is_block_data
)
1273 gfc_generate_block_data (ns
);
1277 gfc_generate_function_code (ns
);
1281 /* This function is called after a complete module has been parsed
1285 gfc_generate_module_code (gfc_namespace
* ns
)
1288 struct module_htab_entry
*entry
;
1290 gcc_assert (ns
->proc_name
->backend_decl
== NULL
);
1291 ns
->proc_name
->backend_decl
1292 = build_decl (ns
->proc_name
->declared_at
.lb
->location
,
1293 NAMESPACE_DECL
, get_identifier (ns
->proc_name
->name
),
1295 entry
= gfc_find_module (ns
->proc_name
->name
);
1296 if (entry
->namespace_decl
)
1297 /* Buggy sourcecode, using a module before defining it? */
1298 htab_empty (entry
->decls
);
1299 entry
->namespace_decl
= ns
->proc_name
->backend_decl
;
1301 gfc_generate_module_vars (ns
);
1303 /* We need to generate all module function prototypes first, to allow
1305 for (n
= ns
->contained
; n
; n
= n
->sibling
)
1312 gfc_create_function_decl (n
);
1313 gcc_assert (DECL_CONTEXT (n
->proc_name
->backend_decl
) == NULL_TREE
);
1314 DECL_CONTEXT (n
->proc_name
->backend_decl
) = ns
->proc_name
->backend_decl
;
1315 gfc_module_add_decl (entry
, n
->proc_name
->backend_decl
);
1316 for (el
= ns
->entries
; el
; el
= el
->next
)
1318 gcc_assert (DECL_CONTEXT (el
->sym
->backend_decl
) == NULL_TREE
);
1319 DECL_CONTEXT (el
->sym
->backend_decl
) = ns
->proc_name
->backend_decl
;
1320 gfc_module_add_decl (entry
, el
->sym
->backend_decl
);
1324 for (n
= ns
->contained
; n
; n
= n
->sibling
)
1329 gfc_generate_function_code (n
);