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
163 t1 = TREE_TYPE (rhs);
164 t2 = TREE_TYPE (lhs);
165 /* Make sure that the types of the rhs and the lhs are the same
166 for scalar assignments. We should probably have something
167 similar for aggregates, but right now removing that check just
168 breaks everything. */
170 || AGGREGATE_TYPE_P (TREE_TYPE (lhs)));
173 tmp = fold_build2 (MODIFY_EXPR, void_type_node, lhs, rhs);
174 gfc_add_expr_to_block (pblock, tmp);
178 /* Create a new scope/binding level and initialize a block. Care must be
179 taken when translating expressions as any temporaries will be placed in
180 the innermost scope. */
183 gfc_start_block (stmtblock_t * block)
185 /* Start a new binding level. */
187 block->has_scope = 1;
189 /* The block is empty. */
190 block->head = NULL_TREE;
194 /* Initialize a block without creating a new scope. */
197 gfc_init_block (stmtblock_t * block)
199 block->head = NULL_TREE;
200 block->has_scope = 0;
204 /* Sometimes we create a scope but it turns out that we don't actually
205 need it. This function merges the scope of BLOCK with its parent.
206 Only variable decls will be merged, you still need to add the code. */
209 gfc_merge_block_scope (stmtblock_t * block)
214 gcc_assert (block->has_scope);
215 block->has_scope = 0;
217 /* Remember the decls in this scope. */
221 /* Add them to the parent scope. */
222 while (decl != NULL_TREE)
224 next = TREE_CHAIN (decl);
225 TREE_CHAIN (decl) = NULL_TREE;
233 /* Finish a scope containing a block of statements. */
236 gfc_finish_block (stmtblock_t * stmtblock)
242 expr = stmtblock->head;
244 expr = build_empty_stmt (input_location);
246 stmtblock->head = NULL_TREE;
248 if (stmtblock->has_scope)
254 block = poplevel (1, 0, 0);
255 expr = build3_v (BIND_EXPR, decl, expr, block);
265 /* Build an ADDR_EXPR and cast the result to TYPE. If TYPE is NULL, the
266 natural type is used. */
269 gfc_build_addr_expr (tree type, tree t)
271 tree base_type = TREE_TYPE (t);
274 if (type && POINTER_TYPE_P (type)
275 && TREE_CODE (base_type) == ARRAY_TYPE
276 && TYPE_MAIN_VARIANT (TREE_TYPE (type))
277 == TYPE_MAIN_VARIANT (TREE_TYPE (base_type)))
279 tree min_val = size_zero_node;
280 tree type_domain = TYPE_DOMAIN (base_type);
281 if (type_domain && TYPE_MIN_VALUE (type_domain))
282 min_val = TYPE_MIN_VALUE (type_domain);
283 t = fold (build4 (ARRAY_REF, TREE_TYPE (type),
284 t, min_val, NULL_TREE, NULL_TREE));
288 natural_type = build_pointer_type (base_type);
290 if (TREE_CODE (t) == INDIRECT_REF)
294 t = TREE_OPERAND (t, 0);
295 natural_type = TREE_TYPE (t);
299 tree base = get_base_address (t);
300 if (base && DECL_P (base))
301 TREE_ADDRESSABLE (base) = 1;
302 t = fold_build1 (ADDR_EXPR, natural_type, t);
305 if (type && natural_type != type)
306 t = convert (type, t);
312 /* Build an ARRAY_REF with its natural type. */
315 gfc_build_array_ref (tree base, tree offset, tree decl)
317 tree type = TREE_TYPE (base);
320 gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
321 type = TREE_TYPE (type);
324 TREE_ADDRESSABLE (base) = 1;
326 /* Strip NON_LVALUE_EXPR nodes. */
327 STRIP_TYPE_NOPS (offset);
329 /* If the array reference is to a pointer, whose target contains a
330 subreference, use the span that is stored with the backend decl
331 and reference the element with pointer arithmetic. */
332 if (decl && (TREE_CODE (decl) == FIELD_DECL
333 || TREE_CODE (decl) == VAR_DECL
334 || TREE_CODE (decl) == PARM_DECL)
335 && GFC_DECL_SUBREF_ARRAY_P (decl)
336 && !integer_zerop (GFC_DECL_SPAN(decl)))
338 offset = fold_build2 (MULT_EXPR, gfc_array_index_type,
339 offset, GFC_DECL_SPAN(decl));
340 tmp = gfc_build_addr_expr (pvoid_type_node, base);
341 tmp = fold_build2 (POINTER_PLUS_EXPR, pvoid_type_node,
342 tmp, fold_convert (sizetype, offset));
343 tmp = fold_convert (build_pointer_type (type), tmp);
344 if (!TYPE_STRING_FLAG (type))
345 tmp = build_fold_indirect_ref_loc (input_location, tmp);
349 /* Otherwise use a straightforward array reference. */
350 return build4 (ARRAY_REF, type, base, offset, NULL_TREE, NULL_TREE);
354 /* Generate a call to print a runtime error possibly including multiple
355 arguments and a locus. */
358 gfc_trans_runtime_error (bool error, locus* where, const char* msgid, ...)
362 va_start (ap, msgid);
363 return gfc_trans_runtime_error_vararg (error, where, msgid, ap);
367 gfc_trans_runtime_error_vararg (bool error, locus* where, const char* msgid,
379 /* Compute the number of extra arguments from the format string. */
380 for (p = msgid, nargs = 0; *p; p++)
388 /* The code to generate the error. */
389 gfc_start_block (&block);
393 line = LOCATION_LINE (where->lb->location);
394 asprintf (&message, "At line %d of file %s", line,
395 where->lb->file->filename);
398 asprintf (&message, "In file '%s', around line %d",
399 gfc_source_file, input_line + 1);
401 arg = gfc_build_addr_expr (pchar_type_node,
402 gfc_build_localized_cstring_const (message));
405 asprintf (&message, "%s", _(msgid));
406 arg2 = gfc_build_addr_expr (pchar_type_node,
407 gfc_build_localized_cstring_const (message));
410 /* Build the argument array. */
411 argarray = (tree *) alloca (sizeof (tree) * (nargs + 2));
414 for (i = 0; i < nargs; i++)
415 argarray[2 + i] = va_arg (ap, tree);
418 /* Build the function call to runtime_(warning,error)_at; because of the
419 variable number of arguments, we can't use build_call_expr_loc dinput_location,
422 fntype = TREE_TYPE (gfor_fndecl_runtime_error_at);
424 fntype = TREE_TYPE (gfor_fndecl_runtime_warning_at);
426 tmp = fold_builtin_call_array (input_location, TREE_TYPE (fntype),
427 fold_build1 (ADDR_EXPR,
428 build_pointer_type (fntype),
430 ? gfor_fndecl_runtime_error_at
431 : gfor_fndecl_runtime_warning_at),
432 nargs + 2, argarray);
433 gfc_add_expr_to_block (&block, tmp);
435 return gfc_finish_block (&block);
439 /* Generate a runtime error if COND is true. */
442 gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock,
443 locus * where, const char * msgid, ...)
451 if (integer_zerop (cond))
456 tmpvar = gfc_create_var (boolean_type_node, "print_warning");
457 TREE_STATIC (tmpvar) = 1;
458 DECL_INITIAL (tmpvar) = boolean_true_node;
459 gfc_add_expr_to_block (pblock, tmpvar);
462 gfc_start_block (&block);
464 /* The code to generate the error. */
465 va_start (ap, msgid);
466 gfc_add_expr_to_block (&block,
467 gfc_trans_runtime_error_vararg (error, where,
471 gfc_add_modify (&block, tmpvar, boolean_false_node);
473 body = gfc_finish_block (&block);
475 if (integer_onep (cond))
477 gfc_add_expr_to_block (pblock, body);
481 /* Tell the compiler that this isn't likely. */
483 cond = fold_build2 (TRUTH_AND_EXPR, long_integer_type_node, tmpvar,
486 cond = fold_convert (long_integer_type_node, cond);
488 tmp = build_int_cst (long_integer_type_node, 0);
489 cond = build_call_expr_loc (input_location,
490 built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
491 cond = fold_convert (boolean_type_node, cond);
493 tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt (input_location));
494 gfc_add_expr_to_block (pblock, tmp);
499 /* Call malloc to allocate size bytes of memory, with special conditions:
500 + if size <= 0, return a malloced area of size 1,
501 + if malloc returns NULL, issue a runtime error. */
503 gfc_call_malloc (stmtblock_t * block, tree type, tree size)
505 tree tmp, msg, malloc_result, null_result, res;
508 size = gfc_evaluate_now (size, block);
510 if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
511 size = fold_convert (size_type_node, size);
513 /* Create a variable to hold the result. */
514 res = gfc_create_var (prvoid_type_node, NULL);
517 gfc_start_block (&block2);
519 size = fold_build2 (MAX_EXPR, size_type_node, size,
520 build_int_cst (size_type_node, 1));
522 gfc_add_modify (&block2, res,
523 fold_convert (prvoid_type_node,
524 build_call_expr_loc (input_location,
525 built_in_decls[BUILT_IN_MALLOC], 1, size)));
527 /* Optionally check whether malloc was successful. */
528 if (gfc_option.rtcheck & GFC_RTCHECK_MEM)
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,
533 gfc_build_localized_cstring_const ("Memory allocation failed"));
534 tmp = fold_build3 (COND_EXPR, void_type_node, null_result,
535 build_call_expr_loc (input_location,
536 gfor_fndecl_os_error, 1, msg),
537 build_empty_stmt (input_location));
538 gfc_add_expr_to_block (&block2, tmp);
541 malloc_result = gfc_finish_block (&block2);
543 gfc_add_expr_to_block (block, malloc_result);
546 res = fold_convert (type, res);
551 /* Allocate memory, using an optional status argument.
553 This function follows the following pseudo-code:
556 allocate (size_t size, integer_type* stat)
563 // The only time this can happen is the size wraps around.
568 *stat = LIBERROR_ALLOCATION;
572 runtime_error ("Attempt to allocate negative amount of memory. "
573 "Possible integer overflow");
577 newmem = malloc (MAX (size, 1));
581 *stat = LIBERROR_ALLOCATION;
583 runtime_error ("Out of memory");
590 gfc_allocate_with_status (stmtblock_t * block, tree size, tree status)
592 stmtblock_t alloc_block;
593 tree res, tmp, error, msg, cond;
594 tree status_type = status ? TREE_TYPE (TREE_TYPE (status)) : NULL_TREE;
596 /* Evaluate size only once, and make sure it has the right type. */
597 size = gfc_evaluate_now (size, block);
598 if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
599 size = fold_convert (size_type_node, size);
601 /* Create a variable to hold the result. */
602 res = gfc_create_var (prvoid_type_node, NULL);
604 /* Set the optional status variable to zero. */
605 if (status != NULL_TREE && !integer_zerop (status))
607 tmp = fold_build2 (MODIFY_EXPR, status_type,
608 fold_build1 (INDIRECT_REF, status_type, status),
609 build_int_cst (status_type, 0));
610 tmp = fold_build3 (COND_EXPR, void_type_node,
611 fold_build2 (NE_EXPR, boolean_type_node, status,
612 build_int_cst (TREE_TYPE (status), 0)),
613 tmp, build_empty_stmt (input_location));
614 gfc_add_expr_to_block (block, tmp);
617 /* Generate the block of code handling (size < 0). */
618 msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
619 ("Attempt to allocate negative amount of memory. "
620 "Possible integer overflow"));
621 error = build_call_expr_loc (input_location,
622 gfor_fndecl_runtime_error, 1, msg);
624 if (status != NULL_TREE && !integer_zerop (status))
626 /* Set the status variable if it's present. */
627 stmtblock_t set_status_block;
629 gfc_start_block (&set_status_block);
630 gfc_add_modify (&set_status_block,
631 fold_build1 (INDIRECT_REF, status_type, status),
632 build_int_cst (status_type, LIBERROR_ALLOCATION));
633 gfc_add_modify (&set_status_block, res,
634 build_int_cst (prvoid_type_node, 0));
636 tmp = fold_build2 (EQ_EXPR, boolean_type_node, status,
637 build_int_cst (TREE_TYPE (status), 0));
638 error = fold_build3 (COND_EXPR, void_type_node, tmp, error,
639 gfc_finish_block (&set_status_block));
642 /* The allocation itself. */
643 gfc_start_block (&alloc_block);
644 gfc_add_modify (&alloc_block, res,
645 fold_convert (prvoid_type_node,
646 build_call_expr_loc (input_location,
647 built_in_decls[BUILT_IN_MALLOC], 1,
648 fold_build2 (MAX_EXPR, size_type_node,
650 build_int_cst (size_type_node, 1)))));
652 msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
654 tmp = build_call_expr_loc (input_location,
655 gfor_fndecl_os_error, 1, msg);
657 if (status != NULL_TREE && !integer_zerop (status))
659 /* Set the status variable if it's present. */
662 cond = fold_build2 (EQ_EXPR, boolean_type_node, status,
663 build_int_cst (TREE_TYPE (status), 0));
664 tmp2 = fold_build2 (MODIFY_EXPR, status_type,
665 fold_build1 (INDIRECT_REF, status_type, status),
666 build_int_cst (status_type, LIBERROR_ALLOCATION));
667 tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
671 tmp = fold_build3 (COND_EXPR, void_type_node,
672 fold_build2 (EQ_EXPR, boolean_type_node, res,
673 build_int_cst (prvoid_type_node, 0)),
674 tmp, build_empty_stmt (input_location));
675 gfc_add_expr_to_block (&alloc_block, tmp);
677 cond = fold_build2 (LT_EXPR, boolean_type_node, size,
678 build_int_cst (TREE_TYPE (size), 0));
679 tmp = fold_build3 (COND_EXPR, void_type_node, cond, error,
680 gfc_finish_block (&alloc_block));
681 gfc_add_expr_to_block (block, tmp);
687 /* Generate code for an ALLOCATE statement when the argument is an
688 allocatable array. If the array is currently allocated, it is an
689 error to allocate it again.
691 This function follows the following pseudo-code:
694 allocate_array (void *mem, size_t size, integer_type *stat)
697 return allocate (size, stat);
703 mem = allocate (size, stat);
704 *stat = LIBERROR_ALLOCATION;
708 runtime_error ("Attempting to allocate already allocated array");
712 expr must be set to the original expression being allocated for its locus
713 and variable name in case a runtime error has to be printed. */
715 gfc_allocate_array_with_status (stmtblock_t * block, tree mem, tree size,
716 tree status, gfc_expr* expr)
718 stmtblock_t alloc_block;
719 tree res, tmp, null_mem, alloc, error;
720 tree type = TREE_TYPE (mem);
722 if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
723 size = fold_convert (size_type_node, size);
725 /* Create a variable to hold the result. */
726 res = gfc_create_var (type, NULL);
727 null_mem = fold_build2 (EQ_EXPR, boolean_type_node, mem,
728 build_int_cst (type, 0));
730 /* If mem is NULL, we call gfc_allocate_with_status. */
731 gfc_start_block (&alloc_block);
732 tmp = gfc_allocate_with_status (&alloc_block, size, status);
733 gfc_add_modify (&alloc_block, res, fold_convert (type, tmp));
734 alloc = gfc_finish_block (&alloc_block);
736 /* Otherwise, we issue a runtime error or set the status variable. */
741 gcc_assert (expr->expr_type == EXPR_VARIABLE && expr->symtree);
742 varname = gfc_build_cstring_const (expr->symtree->name);
743 varname = gfc_build_addr_expr (pchar_type_node, varname);
745 error = gfc_trans_runtime_error (true, &expr->where,
746 "Attempting to allocate already"
747 " allocated array '%s'",
751 error = gfc_trans_runtime_error (true, NULL,
752 "Attempting to allocate already allocated"
755 if (status != NULL_TREE && !integer_zerop (status))
757 tree status_type = TREE_TYPE (TREE_TYPE (status));
758 stmtblock_t set_status_block;
760 gfc_start_block (&set_status_block);
761 tmp = build_call_expr_loc (input_location,
762 built_in_decls[BUILT_IN_FREE], 1,
763 fold_convert (pvoid_type_node, mem));
764 gfc_add_expr_to_block (&set_status_block, tmp);
766 tmp = gfc_allocate_with_status (&set_status_block, size, status);
767 gfc_add_modify (&set_status_block, res, fold_convert (type, tmp));
769 gfc_add_modify (&set_status_block,
770 fold_build1 (INDIRECT_REF, status_type, status),
771 build_int_cst (status_type, LIBERROR_ALLOCATION));
773 tmp = fold_build2 (EQ_EXPR, boolean_type_node, status,
774 build_int_cst (status_type, 0));
775 error = fold_build3 (COND_EXPR, void_type_node, tmp, error,
776 gfc_finish_block (&set_status_block));
779 tmp = fold_build3 (COND_EXPR, void_type_node, null_mem, alloc, error);
780 gfc_add_expr_to_block (block, tmp);
786 /* Free a given variable, if it's not NULL. */
788 gfc_call_free (tree var)
791 tree tmp, cond, call;
793 if (TREE_TYPE (var) != TREE_TYPE (pvoid_type_node))
794 var = fold_convert (pvoid_type_node, var);
796 gfc_start_block (&block);
797 var = gfc_evaluate_now (var, &block);
798 cond = fold_build2 (NE_EXPR, boolean_type_node, var,
799 build_int_cst (pvoid_type_node, 0));
800 call = build_call_expr_loc (input_location,
801 built_in_decls[BUILT_IN_FREE], 1, var);
802 tmp = fold_build3 (COND_EXPR, void_type_node, cond, call,
803 build_empty_stmt (input_location));
804 gfc_add_expr_to_block (&block, tmp);
806 return gfc_finish_block (&block);
811 /* User-deallocate; we emit the code directly from the front-end, and the
812 logic is the same as the previous library function:
815 deallocate (void *pointer, GFC_INTEGER_4 * stat)
822 runtime_error ("Attempt to DEALLOCATE unallocated memory.");
832 In this front-end version, status doesn't have to be GFC_INTEGER_4.
833 Moreover, if CAN_FAIL is true, then we will not emit a runtime error,
834 even when no status variable is passed to us (this is used for
835 unconditional deallocation generated by the front-end at end of
838 If a runtime-message is possible, `expr' must point to the original
839 expression being deallocated for its locus and variable name. */
841 gfc_deallocate_with_status (tree pointer, tree status, bool can_fail,
844 stmtblock_t null, non_null;
845 tree cond, tmp, error;
847 cond = fold_build2 (EQ_EXPR, boolean_type_node, pointer,
848 build_int_cst (TREE_TYPE (pointer), 0));
850 /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
851 we emit a runtime error. */
852 gfc_start_block (&null);
857 gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree);
859 varname = gfc_build_cstring_const (expr->symtree->name);
860 varname = gfc_build_addr_expr (pchar_type_node, varname);
862 error = gfc_trans_runtime_error (true, &expr->where,
863 "Attempt to DEALLOCATE unallocated '%s'",
867 error = build_empty_stmt (input_location);
869 if (status != NULL_TREE && !integer_zerop (status))
871 tree status_type = TREE_TYPE (TREE_TYPE (status));
874 cond2 = fold_build2 (NE_EXPR, boolean_type_node, status,
875 build_int_cst (TREE_TYPE (status), 0));
876 tmp = fold_build2 (MODIFY_EXPR, status_type,
877 fold_build1 (INDIRECT_REF, status_type, status),
878 build_int_cst (status_type, 1));
879 error = fold_build3 (COND_EXPR, void_type_node, cond2, tmp, error);
882 gfc_add_expr_to_block (&null, error);
884 /* When POINTER is not NULL, we free it. */
885 gfc_start_block (&non_null);
886 tmp = build_call_expr_loc (input_location,
887 built_in_decls[BUILT_IN_FREE], 1,
888 fold_convert (pvoid_type_node, pointer));
889 gfc_add_expr_to_block (&non_null, tmp);
891 if (status != NULL_TREE && !integer_zerop (status))
893 /* We set STATUS to zero if it is present. */
894 tree status_type = TREE_TYPE (TREE_TYPE (status));
897 cond2 = fold_build2 (NE_EXPR, boolean_type_node, status,
898 build_int_cst (TREE_TYPE (status), 0));
899 tmp = fold_build2 (MODIFY_EXPR, status_type,
900 fold_build1 (INDIRECT_REF, status_type, status),
901 build_int_cst (status_type, 0));
902 tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp,
903 build_empty_stmt (input_location));
904 gfc_add_expr_to_block (&non_null, tmp);
907 return fold_build3 (COND_EXPR, void_type_node, cond,
908 gfc_finish_block (&null), gfc_finish_block (&non_null));
912 /* Reallocate MEM so it has SIZE bytes of data. This behaves like the
913 following pseudo-code:
916 internal_realloc (void *mem, size_t size)
919 runtime_error ("Attempt to allocate a negative amount of memory.");
920 res = realloc (mem, size);
921 if (!res && size != 0)
922 _gfortran_os_error ("Out of memory");
930 gfc_call_realloc (stmtblock_t * block, tree mem, tree size)
932 tree msg, res, negative, nonzero, zero, null_result, tmp;
933 tree type = TREE_TYPE (mem);
935 size = gfc_evaluate_now (size, block);
937 if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
938 size = fold_convert (size_type_node, size);
940 /* Create a variable to hold the result. */
941 res = gfc_create_var (type, NULL);
944 negative = fold_build2 (LT_EXPR, boolean_type_node, size,
945 build_int_cst (size_type_node, 0));
946 msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
947 ("Attempt to allocate a negative amount of memory."));
948 tmp = fold_build3 (COND_EXPR, void_type_node, negative,
949 build_call_expr_loc (input_location,
950 gfor_fndecl_runtime_error, 1, msg),
951 build_empty_stmt (input_location));
952 gfc_add_expr_to_block (block, tmp);
954 /* Call realloc and check the result. */
955 tmp = build_call_expr_loc (input_location,
956 built_in_decls[BUILT_IN_REALLOC], 2,
957 fold_convert (pvoid_type_node, mem), size);
958 gfc_add_modify (block, res, fold_convert (type, tmp));
959 null_result = fold_build2 (EQ_EXPR, boolean_type_node, res,
960 build_int_cst (pvoid_type_node, 0));
961 nonzero = fold_build2 (NE_EXPR, boolean_type_node, size,
962 build_int_cst (size_type_node, 0));
963 null_result = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, null_result,
965 msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
967 tmp = fold_build3 (COND_EXPR, void_type_node, null_result,
968 build_call_expr_loc (input_location,
969 gfor_fndecl_os_error, 1, msg),
970 build_empty_stmt (input_location));
971 gfc_add_expr_to_block (block, tmp);
973 /* if (size == 0) then the result is NULL. */
974 tmp = fold_build2 (MODIFY_EXPR, type, res, build_int_cst (type, 0));
975 zero = fold_build1 (TRUTH_NOT_EXPR, boolean_type_node, nonzero);
976 tmp = fold_build3 (COND_EXPR, void_type_node, zero, tmp,
977 build_empty_stmt (input_location));
978 gfc_add_expr_to_block (block, tmp);
983 /* Add a statement to a block. */
986 gfc_add_expr_to_block (stmtblock_t * block, tree expr)
990 if (expr == NULL_TREE || IS_EMPTY_STMT (expr))
995 if (TREE_CODE (block->head) != STATEMENT_LIST)
1000 block->head = NULL_TREE;
1001 append_to_statement_list (tmp, &block->head);
1003 append_to_statement_list (expr, &block->head);
1006 /* Don't bother creating a list if we only have a single statement. */
1011 /* Add a block the end of a block. */
1014 gfc_add_block_to_block (stmtblock_t * block, stmtblock_t * append)
1016 gcc_assert (append);
1017 gcc_assert (!append->has_scope);
1019 gfc_add_expr_to_block (block, append->head);
1020 append->head = NULL_TREE;
1024 /* Get the current locus. The structure may not be complete, and should
1025 only be used with gfc_set_backend_locus. */
1028 gfc_get_backend_locus (locus * loc)
1030 loc->lb = XCNEW (gfc_linebuf);
1031 loc->lb->location = input_location;
1032 loc->lb->file = gfc_current_backend_file;
1036 /* Set the current locus. */
1039 gfc_set_backend_locus (locus * loc)
1041 gfc_current_backend_file = loc->lb->file;
1042 input_location = loc->lb->location;
1046 /* Translate an executable statement. The tree cond is used by gfc_trans_do.
1047 This static function is wrapped by gfc_trans_code_cond and
1051 trans_code (gfc_code * code, tree cond)
1057 return build_empty_stmt (input_location);
1059 gfc_start_block (&block);
1061 /* Translate statements one by one into GENERIC trees until we reach
1062 the end of this gfc_code branch. */
1063 for (; code; code = code->next)
1065 if (code->here != 0)
1067 res = gfc_trans_label_here (code);
1068 gfc_add_expr_to_block (&block, res);
1074 case EXEC_END_BLOCK:
1075 case EXEC_END_PROCEDURE:
1080 if (code->expr1->ts.type == BT_CLASS)
1081 res = gfc_trans_class_assign (code);
1083 res = gfc_trans_assign (code);
1086 case EXEC_LABEL_ASSIGN:
1087 res = gfc_trans_label_assign (code);
1090 case EXEC_POINTER_ASSIGN:
1091 if (code->expr1->ts.type == BT_CLASS)
1092 res = gfc_trans_class_assign (code);
1094 res = gfc_trans_pointer_assign (code);
1097 case EXEC_INIT_ASSIGN:
1098 if (code->expr1->ts.type == BT_CLASS)
1099 res = gfc_trans_class_assign (code);
1101 res = gfc_trans_init_assign (code);
1109 res = gfc_trans_cycle (code);
1113 res = gfc_trans_exit (code);
1117 res = gfc_trans_goto (code);
1121 res = gfc_trans_entry (code);
1125 res = gfc_trans_pause (code);
1129 res = gfc_trans_stop (code);
1133 /* For MVBITS we've got the special exception that we need a
1134 dependency check, too. */
1136 bool is_mvbits = false;
1137 if (code->resolved_isym
1138 && code->resolved_isym->id == GFC_ISYM_MVBITS)
1140 res = gfc_trans_call (code, is_mvbits, NULL_TREE,
1146 res = gfc_trans_call (code, false, NULL_TREE,
1150 case EXEC_ASSIGN_CALL:
1151 res = gfc_trans_call (code, true, NULL_TREE,
1156 res = gfc_trans_return (code);
1160 res = gfc_trans_if (code);
1163 case EXEC_ARITHMETIC_IF:
1164 res = gfc_trans_arithmetic_if (code);
1168 res = gfc_trans_block_construct (code);
1172 res = gfc_trans_do (code, cond);
1176 res = gfc_trans_do_while (code);
1180 res = gfc_trans_select (code);
1183 case EXEC_SELECT_TYPE:
1184 /* Do nothing. SELECT TYPE statements should be transformed into
1185 an ordinary SELECT CASE at resolution stage.
1186 TODO: Add an error message here once this is done. */
1191 res = gfc_trans_flush (code);
1195 res = gfc_trans_forall (code);
1199 res = gfc_trans_where (code);
1203 res = gfc_trans_allocate (code);
1206 case EXEC_DEALLOCATE:
1207 res = gfc_trans_deallocate (code);
1211 res = gfc_trans_open (code);
1215 res = gfc_trans_close (code);
1219 res = gfc_trans_read (code);
1223 res = gfc_trans_write (code);
1227 res = gfc_trans_iolength (code);
1230 case EXEC_BACKSPACE:
1231 res = gfc_trans_backspace (code);
1235 res = gfc_trans_endfile (code);
1239 res = gfc_trans_inquire (code);
1243 res = gfc_trans_wait (code);
1247 res = gfc_trans_rewind (code);
1251 res = gfc_trans_transfer (code);
1255 res = gfc_trans_dt_end (code);
1258 case EXEC_OMP_ATOMIC:
1259 case EXEC_OMP_BARRIER:
1260 case EXEC_OMP_CRITICAL:
1262 case EXEC_OMP_FLUSH:
1263 case EXEC_OMP_MASTER:
1264 case EXEC_OMP_ORDERED:
1265 case EXEC_OMP_PARALLEL:
1266 case EXEC_OMP_PARALLEL_DO:
1267 case EXEC_OMP_PARALLEL_SECTIONS:
1268 case EXEC_OMP_PARALLEL_WORKSHARE:
1269 case EXEC_OMP_SECTIONS:
1270 case EXEC_OMP_SINGLE:
1272 case EXEC_OMP_TASKWAIT:
1273 case EXEC_OMP_WORKSHARE:
1274 res = gfc_trans_omp_directive (code);
1278 internal_error ("gfc_trans_code(): Bad statement code");
1281 gfc_set_backend_locus (&code->loc);
1283 if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
1285 if (TREE_CODE (res) != STATEMENT_LIST)
1286 SET_EXPR_LOCATION (res, input_location);
1288 /* Add the new statement to the block. */
1289 gfc_add_expr_to_block (&block, res);
1293 /* Return the finished block. */
1294 return gfc_finish_block (&block);
1298 /* Translate an executable statement with condition, cond. The condition is
1299 used by gfc_trans_do to test for IO result conditions inside implied
1300 DO loops of READ and WRITE statements. See build_dt in trans-io.c. */
1303 gfc_trans_code_cond (gfc_code * code, tree cond)
1305 return trans_code (code, cond);
1308 /* Translate an executable statement without condition. */
1311 gfc_trans_code (gfc_code * code)
1313 return trans_code (code, NULL_TREE);
1317 /* This function is called after a complete program unit has been parsed
1321 gfc_generate_code (gfc_namespace * ns)
1324 if (ns->is_block_data)
1326 gfc_generate_block_data (ns);
1330 gfc_generate_function_code (ns);
1334 /* This function is called after a complete module has been parsed
1338 gfc_generate_module_code (gfc_namespace * ns)
1341 struct module_htab_entry *entry;
1343 gcc_assert (ns->proc_name->backend_decl == NULL);
1344 ns->proc_name->backend_decl
1345 = build_decl (ns->proc_name->declared_at.lb->location,
1346 NAMESPACE_DECL, get_identifier (ns->proc_name->name),
1348 entry = gfc_find_module (ns->proc_name->name);
1349 if (entry->namespace_decl)
1350 /* Buggy sourcecode, using a module before defining it? */
1351 htab_empty (entry->decls);
1352 entry->namespace_decl = ns->proc_name->backend_decl;
1354 gfc_generate_module_vars (ns);
1356 /* We need to generate all module function prototypes first, to allow
1358 for (n = ns->contained; n; n = n->sibling)
1365 gfc_create_function_decl (n);
1366 gcc_assert (DECL_CONTEXT (n->proc_name->backend_decl) == NULL_TREE);
1367 DECL_CONTEXT (n->proc_name->backend_decl) = ns->proc_name->backend_decl;
1368 gfc_module_add_decl (entry, n->proc_name->backend_decl);
1369 for (el = ns->entries; el; el = el->next)
1371 gcc_assert (DECL_CONTEXT (el->sym->backend_decl) == NULL_TREE);
1372 DECL_CONTEXT (el->sym->backend_decl) = ns->proc_name->backend_decl;
1373 gfc_module_add_decl (entry, el->sym->backend_decl);
1377 for (n = ns->contained; n; n = n->sibling)
1382 gfc_generate_function_code (n);