1 /* Code translation -- generate GCC trees from gfc_code.
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software
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 ();
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
);
297 TREE_ADDRESSABLE (t
) = 1;
298 t
= fold_build1 (ADDR_EXPR
, natural_type
, t
);
301 if (type
&& natural_type
!= type
)
302 t
= convert (type
, t
);
308 /* Build an ARRAY_REF with its natural type. */
311 gfc_build_array_ref (tree base
, tree offset
, tree decl
)
313 tree type
= TREE_TYPE (base
);
316 gcc_assert (TREE_CODE (type
) == ARRAY_TYPE
);
317 type
= TREE_TYPE (type
);
320 TREE_ADDRESSABLE (base
) = 1;
322 /* Strip NON_LVALUE_EXPR nodes. */
323 STRIP_TYPE_NOPS (offset
);
325 /* If the array reference is to a pointer, whose target contains a
326 subreference, use the span that is stored with the backend decl
327 and reference the element with pointer arithmetic. */
328 if (decl
&& (TREE_CODE (decl
) == FIELD_DECL
329 || TREE_CODE (decl
) == VAR_DECL
330 || TREE_CODE (decl
) == PARM_DECL
)
331 && GFC_DECL_SUBREF_ARRAY_P (decl
)
332 && !integer_zerop (GFC_DECL_SPAN(decl
)))
334 offset
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
335 offset
, GFC_DECL_SPAN(decl
));
336 tmp
= gfc_build_addr_expr (pvoid_type_node
, base
);
337 tmp
= fold_build2 (POINTER_PLUS_EXPR
, pvoid_type_node
,
338 tmp
, fold_convert (sizetype
, offset
));
339 tmp
= fold_convert (build_pointer_type (type
), tmp
);
340 if (!TYPE_STRING_FLAG (type
))
341 tmp
= build_fold_indirect_ref (tmp
);
345 /* Otherwise use a straightforward array reference. */
346 return build4 (ARRAY_REF
, type
, base
, offset
, NULL_TREE
, NULL_TREE
);
350 /* Generate a call to print a runtime error possibly including multiple
351 arguments and a locus. */
354 gfc_trans_runtime_error (bool error
, locus
* where
, const char* msgid
, ...)
358 va_start (ap
, msgid
);
359 return gfc_trans_runtime_error_vararg (error
, where
, msgid
, ap
);
363 gfc_trans_runtime_error_vararg (bool error
, locus
* where
, const char* msgid
,
375 /* Compute the number of extra arguments from the format string. */
376 for (p
= msgid
, nargs
= 0; *p
; p
++)
384 /* The code to generate the error. */
385 gfc_start_block (&block
);
389 line
= LOCATION_LINE (where
->lb
->location
);
390 asprintf (&message
, "At line %d of file %s", line
,
391 where
->lb
->file
->filename
);
394 asprintf (&message
, "In file '%s', around line %d",
395 gfc_source_file
, input_line
+ 1);
397 arg
= gfc_build_addr_expr (pchar_type_node
,
398 gfc_build_localized_cstring_const (message
));
401 asprintf (&message
, "%s", _(msgid
));
402 arg2
= gfc_build_addr_expr (pchar_type_node
,
403 gfc_build_localized_cstring_const (message
));
406 /* Build the argument array. */
407 argarray
= (tree
*) alloca (sizeof (tree
) * (nargs
+ 2));
410 for (i
= 0; i
< nargs
; i
++)
411 argarray
[2 + i
] = va_arg (ap
, tree
);
414 /* Build the function call to runtime_(warning,error)_at; because of the
415 variable number of arguments, we can't use build_call_expr directly. */
417 fntype
= TREE_TYPE (gfor_fndecl_runtime_error_at
);
419 fntype
= TREE_TYPE (gfor_fndecl_runtime_warning_at
);
421 tmp
= fold_builtin_call_array (TREE_TYPE (fntype
),
422 fold_build1 (ADDR_EXPR
,
423 build_pointer_type (fntype
),
425 ? gfor_fndecl_runtime_error_at
426 : gfor_fndecl_runtime_warning_at
),
427 nargs
+ 2, argarray
);
428 gfc_add_expr_to_block (&block
, tmp
);
430 return gfc_finish_block (&block
);
434 /* Generate a runtime error if COND is true. */
437 gfc_trans_runtime_check (bool error
, bool once
, tree cond
, stmtblock_t
* pblock
,
438 locus
* where
, const char * msgid
, ...)
446 if (integer_zerop (cond
))
451 tmpvar
= gfc_create_var (boolean_type_node
, "print_warning");
452 TREE_STATIC (tmpvar
) = 1;
453 DECL_INITIAL (tmpvar
) = boolean_true_node
;
454 gfc_add_expr_to_block (pblock
, tmpvar
);
457 gfc_start_block (&block
);
459 /* The code to generate the error. */
460 va_start (ap
, msgid
);
461 gfc_add_expr_to_block (&block
,
462 gfc_trans_runtime_error_vararg (error
, where
,
466 gfc_add_modify (&block
, tmpvar
, boolean_false_node
);
468 body
= gfc_finish_block (&block
);
470 if (integer_onep (cond
))
472 gfc_add_expr_to_block (pblock
, body
);
476 /* Tell the compiler that this isn't likely. */
478 cond
= fold_build2 (TRUTH_AND_EXPR
, long_integer_type_node
, tmpvar
,
481 cond
= fold_convert (long_integer_type_node
, cond
);
483 tmp
= build_int_cst (long_integer_type_node
, 0);
484 cond
= build_call_expr (built_in_decls
[BUILT_IN_EXPECT
], 2, cond
, tmp
);
485 cond
= fold_convert (boolean_type_node
, cond
);
487 tmp
= build3_v (COND_EXPR
, cond
, body
, build_empty_stmt ());
488 gfc_add_expr_to_block (pblock
, tmp
);
493 /* Call malloc to allocate size bytes of memory, with special conditions:
494 + if size < 0, generate a runtime error,
495 + if size == 0, return a malloced area of size 1,
496 + if malloc returns NULL, issue a runtime error. */
498 gfc_call_malloc (stmtblock_t
* block
, tree type
, tree size
)
500 tree tmp
, msg
, negative
, malloc_result
, null_result
, res
;
503 size
= gfc_evaluate_now (size
, block
);
505 if (TREE_TYPE (size
) != TREE_TYPE (size_type_node
))
506 size
= fold_convert (size_type_node
, size
);
508 /* Create a variable to hold the result. */
509 res
= gfc_create_var (pvoid_type_node
, NULL
);
512 negative
= fold_build2 (LT_EXPR
, boolean_type_node
, size
,
513 build_int_cst (size_type_node
, 0));
514 msg
= gfc_build_addr_expr (pchar_type_node
, gfc_build_localized_cstring_const
515 ("Attempt to allocate a negative amount of memory."));
516 tmp
= fold_build3 (COND_EXPR
, void_type_node
, negative
,
517 build_call_expr (gfor_fndecl_runtime_error
, 1, msg
),
518 build_empty_stmt ());
519 gfc_add_expr_to_block (block
, tmp
);
521 /* Call malloc and check the result. */
522 gfc_start_block (&block2
);
524 size
= fold_build2 (MAX_EXPR
, size_type_node
, size
,
525 build_int_cst (size_type_node
, 1));
527 gfc_add_modify (&block2
, res
,
528 build_call_expr (built_in_decls
[BUILT_IN_MALLOC
], 1,
530 null_result
= fold_build2 (EQ_EXPR
, boolean_type_node
, res
,
531 build_int_cst (pvoid_type_node
, 0));
532 msg
= gfc_build_addr_expr (pchar_type_node
, gfc_build_localized_cstring_const
533 ("Memory allocation failed"));
534 tmp
= fold_build3 (COND_EXPR
, void_type_node
, null_result
,
535 build_call_expr (gfor_fndecl_os_error
, 1, msg
),
536 build_empty_stmt ());
537 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
);
547 /* Allocate memory, using an optional status argument.
549 This function follows the following pseudo-code:
552 allocate (size_t size, integer_type* stat)
559 // The only time this can happen is the size wraps around.
564 *stat = LIBERROR_ALLOCATION;
568 runtime_error ("Attempt to allocate negative amount of memory. "
569 "Possible integer overflow");
573 newmem = malloc (MAX (size, 1));
577 *stat = LIBERROR_ALLOCATION;
579 runtime_error ("Out of memory");
586 gfc_allocate_with_status (stmtblock_t
* block
, tree size
, tree status
)
588 stmtblock_t alloc_block
;
589 tree res
, tmp
, error
, msg
, cond
;
590 tree status_type
= status
? TREE_TYPE (TREE_TYPE (status
)) : NULL_TREE
;
592 /* Evaluate size only once, and make sure it has the right type. */
593 size
= gfc_evaluate_now (size
, block
);
594 if (TREE_TYPE (size
) != TREE_TYPE (size_type_node
))
595 size
= fold_convert (size_type_node
, size
);
597 /* Create a variable to hold the result. */
598 res
= gfc_create_var (pvoid_type_node
, NULL
);
600 /* Set the optional status variable to zero. */
601 if (status
!= NULL_TREE
&& !integer_zerop (status
))
603 tmp
= fold_build2 (MODIFY_EXPR
, status_type
,
604 fold_build1 (INDIRECT_REF
, status_type
, status
),
605 build_int_cst (status_type
, 0));
606 tmp
= fold_build3 (COND_EXPR
, void_type_node
,
607 fold_build2 (NE_EXPR
, boolean_type_node
,
608 status
, build_int_cst (status_type
, 0)),
609 tmp
, build_empty_stmt ());
610 gfc_add_expr_to_block (block
, tmp
);
613 /* Generate the block of code handling (size < 0). */
614 msg
= gfc_build_addr_expr (pchar_type_node
, gfc_build_localized_cstring_const
615 ("Attempt to allocate negative amount of memory. "
616 "Possible integer overflow"));
617 error
= build_call_expr (gfor_fndecl_runtime_error
, 1, msg
);
619 if (status
!= NULL_TREE
&& !integer_zerop (status
))
621 /* Set the status variable if it's present. */
622 stmtblock_t set_status_block
;
624 gfc_start_block (&set_status_block
);
625 gfc_add_modify (&set_status_block
,
626 fold_build1 (INDIRECT_REF
, status_type
, status
),
627 build_int_cst (status_type
, LIBERROR_ALLOCATION
));
628 gfc_add_modify (&set_status_block
, res
,
629 build_int_cst (pvoid_type_node
, 0));
631 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, status
,
632 build_int_cst (status_type
, 0));
633 error
= fold_build3 (COND_EXPR
, void_type_node
, tmp
, error
,
634 gfc_finish_block (&set_status_block
));
637 /* The allocation itself. */
638 gfc_start_block (&alloc_block
);
639 gfc_add_modify (&alloc_block
, res
,
640 build_call_expr (built_in_decls
[BUILT_IN_MALLOC
], 1,
641 fold_build2 (MAX_EXPR
, size_type_node
,
643 build_int_cst (size_type_node
, 1))));
645 msg
= gfc_build_addr_expr (pchar_type_node
, gfc_build_localized_cstring_const
647 tmp
= build_call_expr (gfor_fndecl_os_error
, 1, msg
);
649 if (status
!= NULL_TREE
&& !integer_zerop (status
))
651 /* Set the status variable if it's present. */
654 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
, status
,
655 build_int_cst (status_type
, 0));
656 tmp2
= fold_build2 (MODIFY_EXPR
, status_type
,
657 fold_build1 (INDIRECT_REF
, status_type
, status
),
658 build_int_cst (status_type
, LIBERROR_ALLOCATION
));
659 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond
, tmp
,
663 tmp
= fold_build3 (COND_EXPR
, void_type_node
,
664 fold_build2 (EQ_EXPR
, boolean_type_node
, res
,
665 build_int_cst (pvoid_type_node
, 0)),
666 tmp
, build_empty_stmt ());
667 gfc_add_expr_to_block (&alloc_block
, tmp
);
669 cond
= fold_build2 (LT_EXPR
, boolean_type_node
, size
,
670 build_int_cst (TREE_TYPE (size
), 0));
671 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond
, error
,
672 gfc_finish_block (&alloc_block
));
673 gfc_add_expr_to_block (block
, tmp
);
679 /* Generate code for an ALLOCATE statement when the argument is an
680 allocatable array. If the array is currently allocated, it is an
681 error to allocate it again.
683 This function follows the following pseudo-code:
686 allocate_array (void *mem, size_t size, integer_type *stat)
689 return allocate (size, stat);
695 mem = allocate (size, stat);
696 *stat = LIBERROR_ALLOCATION;
700 runtime_error ("Attempting to allocate already allocated array");
703 expr must be set to the original expression being allocated for its locus
704 and variable name in case a runtime error has to be printed. */
706 gfc_allocate_array_with_status (stmtblock_t
* block
, tree mem
, tree size
,
707 tree status
, gfc_expr
* expr
)
709 stmtblock_t alloc_block
;
710 tree res
, tmp
, null_mem
, alloc
, error
;
711 tree type
= TREE_TYPE (mem
);
713 if (TREE_TYPE (size
) != TREE_TYPE (size_type_node
))
714 size
= fold_convert (size_type_node
, size
);
716 /* Create a variable to hold the result. */
717 res
= gfc_create_var (pvoid_type_node
, NULL
);
718 null_mem
= fold_build2 (EQ_EXPR
, boolean_type_node
, mem
,
719 build_int_cst (type
, 0));
721 /* If mem is NULL, we call gfc_allocate_with_status. */
722 gfc_start_block (&alloc_block
);
723 tmp
= gfc_allocate_with_status (&alloc_block
, size
, status
);
724 gfc_add_modify (&alloc_block
, res
, fold_convert (type
, tmp
));
725 alloc
= gfc_finish_block (&alloc_block
);
727 /* Otherwise, we issue a runtime error or set the status variable. */
732 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
&& expr
->symtree
);
733 varname
= gfc_build_cstring_const (expr
->symtree
->name
);
734 varname
= gfc_build_addr_expr (pchar_type_node
, varname
);
736 error
= gfc_trans_runtime_error (true, &expr
->where
,
737 "Attempting to allocate already"
738 " allocated array '%s'",
742 error
= gfc_trans_runtime_error (true, NULL
,
743 "Attempting to allocate already allocated"
746 if (status
!= NULL_TREE
&& !integer_zerop (status
))
748 tree status_type
= TREE_TYPE (TREE_TYPE (status
));
749 stmtblock_t set_status_block
;
751 gfc_start_block (&set_status_block
);
752 tmp
= build_call_expr (built_in_decls
[BUILT_IN_FREE
], 1,
753 fold_convert (pvoid_type_node
, mem
));
754 gfc_add_expr_to_block (&set_status_block
, tmp
);
756 tmp
= gfc_allocate_with_status (&set_status_block
, size
, status
);
757 gfc_add_modify (&set_status_block
, res
, fold_convert (type
, tmp
));
759 gfc_add_modify (&set_status_block
,
760 fold_build1 (INDIRECT_REF
, status_type
, status
),
761 build_int_cst (status_type
, LIBERROR_ALLOCATION
));
763 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
, status
,
764 build_int_cst (status_type
, 0));
765 error
= fold_build3 (COND_EXPR
, void_type_node
, tmp
, error
,
766 gfc_finish_block (&set_status_block
));
769 tmp
= fold_build3 (COND_EXPR
, void_type_node
, null_mem
, alloc
, error
);
770 gfc_add_expr_to_block (block
, tmp
);
776 /* Free a given variable, if it's not NULL. */
778 gfc_call_free (tree var
)
781 tree tmp
, cond
, call
;
783 if (TREE_TYPE (var
) != TREE_TYPE (pvoid_type_node
))
784 var
= fold_convert (pvoid_type_node
, var
);
786 gfc_start_block (&block
);
787 var
= gfc_evaluate_now (var
, &block
);
788 cond
= fold_build2 (NE_EXPR
, boolean_type_node
, var
,
789 build_int_cst (pvoid_type_node
, 0));
790 call
= build_call_expr (built_in_decls
[BUILT_IN_FREE
], 1, var
);
791 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond
, call
,
792 build_empty_stmt ());
793 gfc_add_expr_to_block (&block
, tmp
);
795 return gfc_finish_block (&block
);
800 /* User-deallocate; we emit the code directly from the front-end, and the
801 logic is the same as the previous library function:
804 deallocate (void *pointer, GFC_INTEGER_4 * stat)
811 runtime_error ("Attempt to DEALLOCATE unallocated memory.");
821 In this front-end version, status doesn't have to be GFC_INTEGER_4.
822 Moreover, if CAN_FAIL is true, then we will not emit a runtime error,
823 even when no status variable is passed to us (this is used for
824 unconditional deallocation generated by the front-end at end of
827 If a runtime-message is possible, `expr' must point to the original
828 expression being deallocated for its locus and variable name. */
830 gfc_deallocate_with_status (tree pointer
, tree status
, bool can_fail
,
833 stmtblock_t null
, non_null
;
834 tree cond
, tmp
, error
;
836 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
, pointer
,
837 build_int_cst (TREE_TYPE (pointer
), 0));
839 /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
840 we emit a runtime error. */
841 gfc_start_block (&null
);
846 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
&& expr
->symtree
);
848 varname
= gfc_build_cstring_const (expr
->symtree
->name
);
849 varname
= gfc_build_addr_expr (pchar_type_node
, varname
);
851 error
= gfc_trans_runtime_error (true, &expr
->where
,
852 "Attempt to DEALLOCATE unallocated '%s'",
856 error
= build_empty_stmt ();
858 if (status
!= NULL_TREE
&& !integer_zerop (status
))
860 tree status_type
= TREE_TYPE (TREE_TYPE (status
));
863 cond2
= fold_build2 (NE_EXPR
, boolean_type_node
, status
,
864 build_int_cst (TREE_TYPE (status
), 0));
865 tmp
= fold_build2 (MODIFY_EXPR
, status_type
,
866 fold_build1 (INDIRECT_REF
, status_type
, status
),
867 build_int_cst (status_type
, 1));
868 error
= fold_build3 (COND_EXPR
, void_type_node
, cond2
, tmp
, error
);
871 gfc_add_expr_to_block (&null
, error
);
873 /* When POINTER is not NULL, we free it. */
874 gfc_start_block (&non_null
);
875 tmp
= build_call_expr (built_in_decls
[BUILT_IN_FREE
], 1,
876 fold_convert (pvoid_type_node
, pointer
));
877 gfc_add_expr_to_block (&non_null
, tmp
);
879 if (status
!= NULL_TREE
&& !integer_zerop (status
))
881 /* We set STATUS to zero if it is present. */
882 tree status_type
= TREE_TYPE (TREE_TYPE (status
));
885 cond2
= fold_build2 (NE_EXPR
, boolean_type_node
, status
,
886 build_int_cst (TREE_TYPE (status
), 0));
887 tmp
= fold_build2 (MODIFY_EXPR
, status_type
,
888 fold_build1 (INDIRECT_REF
, status_type
, status
),
889 build_int_cst (status_type
, 0));
890 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond2
, tmp
,
891 build_empty_stmt ());
892 gfc_add_expr_to_block (&non_null
, tmp
);
895 return fold_build3 (COND_EXPR
, void_type_node
, cond
,
896 gfc_finish_block (&null
), gfc_finish_block (&non_null
));
900 /* Reallocate MEM so it has SIZE bytes of data. This behaves like the
901 following pseudo-code:
904 internal_realloc (void *mem, size_t size)
907 runtime_error ("Attempt to allocate a negative amount of memory.");
908 res = realloc (mem, size);
909 if (!res && size != 0)
910 _gfortran_os_error ("Out of memory");
918 gfc_call_realloc (stmtblock_t
* block
, tree mem
, tree size
)
920 tree msg
, res
, negative
, nonzero
, zero
, null_result
, tmp
;
921 tree type
= TREE_TYPE (mem
);
923 size
= gfc_evaluate_now (size
, block
);
925 if (TREE_TYPE (size
) != TREE_TYPE (size_type_node
))
926 size
= fold_convert (size_type_node
, size
);
928 /* Create a variable to hold the result. */
929 res
= gfc_create_var (type
, NULL
);
932 negative
= fold_build2 (LT_EXPR
, boolean_type_node
, size
,
933 build_int_cst (size_type_node
, 0));
934 msg
= gfc_build_addr_expr (pchar_type_node
, gfc_build_localized_cstring_const
935 ("Attempt to allocate a negative amount of memory."));
936 tmp
= fold_build3 (COND_EXPR
, void_type_node
, negative
,
937 build_call_expr (gfor_fndecl_runtime_error
, 1, msg
),
938 build_empty_stmt ());
939 gfc_add_expr_to_block (block
, tmp
);
941 /* Call realloc and check the result. */
942 tmp
= build_call_expr (built_in_decls
[BUILT_IN_REALLOC
], 2,
943 fold_convert (pvoid_type_node
, mem
), size
);
944 gfc_add_modify (block
, res
, fold_convert (type
, tmp
));
945 null_result
= fold_build2 (EQ_EXPR
, boolean_type_node
, res
,
946 build_int_cst (pvoid_type_node
, 0));
947 nonzero
= fold_build2 (NE_EXPR
, boolean_type_node
, size
,
948 build_int_cst (size_type_node
, 0));
949 null_result
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
, null_result
,
951 msg
= gfc_build_addr_expr (pchar_type_node
, gfc_build_localized_cstring_const
953 tmp
= fold_build3 (COND_EXPR
, void_type_node
, null_result
,
954 build_call_expr (gfor_fndecl_os_error
, 1, msg
),
955 build_empty_stmt ());
956 gfc_add_expr_to_block (block
, tmp
);
958 /* if (size == 0) then the result is NULL. */
959 tmp
= fold_build2 (MODIFY_EXPR
, type
, res
, build_int_cst (type
, 0));
960 zero
= fold_build1 (TRUTH_NOT_EXPR
, boolean_type_node
, nonzero
);
961 tmp
= fold_build3 (COND_EXPR
, void_type_node
, zero
, tmp
,
962 build_empty_stmt ());
963 gfc_add_expr_to_block (block
, tmp
);
968 /* Add a statement to a block. */
971 gfc_add_expr_to_block (stmtblock_t
* block
, tree expr
)
975 if (expr
== NULL_TREE
|| IS_EMPTY_STMT (expr
))
980 if (TREE_CODE (block
->head
) != STATEMENT_LIST
)
985 block
->head
= NULL_TREE
;
986 append_to_statement_list (tmp
, &block
->head
);
988 append_to_statement_list (expr
, &block
->head
);
991 /* Don't bother creating a list if we only have a single statement. */
996 /* Add a block the end of a block. */
999 gfc_add_block_to_block (stmtblock_t
* block
, stmtblock_t
* append
)
1001 gcc_assert (append
);
1002 gcc_assert (!append
->has_scope
);
1004 gfc_add_expr_to_block (block
, append
->head
);
1005 append
->head
= NULL_TREE
;
1009 /* Get the current locus. The structure may not be complete, and should
1010 only be used with gfc_set_backend_locus. */
1013 gfc_get_backend_locus (locus
* loc
)
1015 loc
->lb
= XCNEW (gfc_linebuf
);
1016 loc
->lb
->location
= input_location
;
1017 loc
->lb
->file
= gfc_current_backend_file
;
1021 /* Set the current locus. */
1024 gfc_set_backend_locus (locus
* loc
)
1026 gfc_current_backend_file
= loc
->lb
->file
;
1027 input_location
= loc
->lb
->location
;
1031 /* Translate an executable statement. */
1034 gfc_trans_code (gfc_code
* code
)
1040 return build_empty_stmt ();
1042 gfc_start_block (&block
);
1044 /* Translate statements one by one into GENERIC trees until we reach
1045 the end of this gfc_code branch. */
1046 for (; code
; code
= code
->next
)
1048 if (code
->here
!= 0)
1050 res
= gfc_trans_label_here (code
);
1051 gfc_add_expr_to_block (&block
, res
);
1061 res
= gfc_trans_assign (code
);
1064 case EXEC_LABEL_ASSIGN
:
1065 res
= gfc_trans_label_assign (code
);
1068 case EXEC_POINTER_ASSIGN
:
1069 res
= gfc_trans_pointer_assign (code
);
1072 case EXEC_INIT_ASSIGN
:
1073 res
= gfc_trans_init_assign (code
);
1081 res
= gfc_trans_cycle (code
);
1085 res
= gfc_trans_exit (code
);
1089 res
= gfc_trans_goto (code
);
1093 res
= gfc_trans_entry (code
);
1097 res
= gfc_trans_pause (code
);
1101 res
= gfc_trans_stop (code
);
1105 res
= gfc_trans_call (code
, false);
1108 case EXEC_ASSIGN_CALL
:
1109 res
= gfc_trans_call (code
, true);
1113 res
= gfc_trans_return (code
);
1117 res
= gfc_trans_if (code
);
1120 case EXEC_ARITHMETIC_IF
:
1121 res
= gfc_trans_arithmetic_if (code
);
1125 res
= gfc_trans_do (code
);
1129 res
= gfc_trans_do_while (code
);
1133 res
= gfc_trans_select (code
);
1137 res
= gfc_trans_flush (code
);
1141 res
= gfc_trans_forall (code
);
1145 res
= gfc_trans_where (code
);
1149 res
= gfc_trans_allocate (code
);
1152 case EXEC_DEALLOCATE
:
1153 res
= gfc_trans_deallocate (code
);
1157 res
= gfc_trans_open (code
);
1161 res
= gfc_trans_close (code
);
1165 res
= gfc_trans_read (code
);
1169 res
= gfc_trans_write (code
);
1173 res
= gfc_trans_iolength (code
);
1176 case EXEC_BACKSPACE
:
1177 res
= gfc_trans_backspace (code
);
1181 res
= gfc_trans_endfile (code
);
1185 res
= gfc_trans_inquire (code
);
1189 res
= gfc_trans_wait (code
);
1193 res
= gfc_trans_rewind (code
);
1197 res
= gfc_trans_transfer (code
);
1201 res
= gfc_trans_dt_end (code
);
1204 case EXEC_OMP_ATOMIC
:
1205 case EXEC_OMP_BARRIER
:
1206 case EXEC_OMP_CRITICAL
:
1208 case EXEC_OMP_FLUSH
:
1209 case EXEC_OMP_MASTER
:
1210 case EXEC_OMP_ORDERED
:
1211 case EXEC_OMP_PARALLEL
:
1212 case EXEC_OMP_PARALLEL_DO
:
1213 case EXEC_OMP_PARALLEL_SECTIONS
:
1214 case EXEC_OMP_PARALLEL_WORKSHARE
:
1215 case EXEC_OMP_SECTIONS
:
1216 case EXEC_OMP_SINGLE
:
1218 case EXEC_OMP_TASKWAIT
:
1219 case EXEC_OMP_WORKSHARE
:
1220 res
= gfc_trans_omp_directive (code
);
1224 internal_error ("gfc_trans_code(): Bad statement code");
1227 gfc_set_backend_locus (&code
->loc
);
1229 if (res
!= NULL_TREE
&& ! IS_EMPTY_STMT (res
))
1231 if (TREE_CODE (res
) == STATEMENT_LIST
)
1232 tree_annotate_all_with_location (&res
, input_location
);
1234 SET_EXPR_LOCATION (res
, input_location
);
1236 /* Add the new statement to the block. */
1237 gfc_add_expr_to_block (&block
, res
);
1241 /* Return the finished block. */
1242 return gfc_finish_block (&block
);
1246 /* This function is called after a complete program unit has been parsed
1250 gfc_generate_code (gfc_namespace
* ns
)
1252 if (ns
->is_block_data
)
1254 gfc_generate_block_data (ns
);
1258 gfc_generate_function_code (ns
);
1262 /* This function is called after a complete module has been parsed
1266 gfc_generate_module_code (gfc_namespace
* ns
)
1269 struct module_htab_entry
*entry
;
1271 gcc_assert (ns
->proc_name
->backend_decl
== NULL
);
1272 ns
->proc_name
->backend_decl
1273 = build_decl (NAMESPACE_DECL
, get_identifier (ns
->proc_name
->name
),
1275 gfc_set_decl_location (ns
->proc_name
->backend_decl
,
1276 &ns
->proc_name
->declared_at
);
1277 entry
= gfc_find_module (ns
->proc_name
->name
);
1278 if (entry
->namespace_decl
)
1279 /* Buggy sourcecode, using a module before defining it? */
1280 htab_empty (entry
->decls
);
1281 entry
->namespace_decl
= ns
->proc_name
->backend_decl
;
1283 gfc_generate_module_vars (ns
);
1285 /* We need to generate all module function prototypes first, to allow
1287 for (n
= ns
->contained
; n
; n
= n
->sibling
)
1294 gfc_create_function_decl (n
);
1295 gcc_assert (DECL_CONTEXT (n
->proc_name
->backend_decl
) == NULL_TREE
);
1296 DECL_CONTEXT (n
->proc_name
->backend_decl
) = ns
->proc_name
->backend_decl
;
1297 gfc_module_add_decl (entry
, n
->proc_name
->backend_decl
);
1298 for (el
= ns
->entries
; el
; el
= el
->next
)
1300 gcc_assert (DECL_CONTEXT (el
->sym
->backend_decl
) == NULL_TREE
);
1301 DECL_CONTEXT (el
->sym
->backend_decl
) = ns
->proc_name
->backend_decl
;
1302 gfc_module_add_decl (entry
, el
->sym
->backend_decl
);
1306 for (n
= ns
->contained
; n
; n
= n
->sibling
)
1311 gfc_generate_function_code (n
);