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 /* Wrap a node in a TREE_LIST node and add it to the end of a list. */
69 gfc_chainon_list (tree list, tree add)
73 l = tree_cons (NULL_TREE, add, NULL_TREE);
75 return chainon (list, l);
79 /* Strip off a legitimate source ending from the input
80 string NAME of length LEN. */
83 remove_suffix (char *name, int len)
87 for (i = 2; i < 8 && len > i; i++)
89 if (name[len - i] == '.')
98 /* Creates a variable declaration with a given TYPE. */
101 gfc_create_var_np (tree type, const char *prefix)
105 t = create_tmp_var_raw (type, prefix);
107 /* No warnings for anonymous variables. */
109 TREE_NO_WARNING (t) = 1;
115 /* Like above, but also adds it to the current scope. */
118 gfc_create_var (tree type, const char *prefix)
122 tmp = gfc_create_var_np (type, prefix);
130 /* If the expression is not constant, evaluate it now. We assign the
131 result of the expression to an artificially created variable VAR, and
132 return a pointer to the VAR_DECL node for this variable. */
135 gfc_evaluate_now_loc (location_t loc, tree expr, stmtblock_t * pblock)
139 if (CONSTANT_CLASS_P (expr))
142 var = gfc_create_var (TREE_TYPE (expr), NULL);
143 gfc_add_modify_loc (loc, pblock, var, expr);
150 gfc_evaluate_now (tree expr, stmtblock_t * pblock)
152 return gfc_evaluate_now_loc (input_location, expr, pblock);
156 /* Build a MODIFY_EXPR node and add it to a given statement block PBLOCK.
157 A MODIFY_EXPR is an assignment:
161 gfc_add_modify_loc (location_t loc, stmtblock_t * pblock, tree lhs, tree rhs)
165 #ifdef ENABLE_CHECKING
167 t1 = TREE_TYPE (rhs);
168 t2 = TREE_TYPE (lhs);
169 /* Make sure that the types of the rhs and the lhs are the same
170 for scalar assignments. We should probably have something
171 similar for aggregates, but right now removing that check just
172 breaks everything. */
174 || AGGREGATE_TYPE_P (TREE_TYPE (lhs)));
177 tmp = fold_build2_loc (loc, MODIFY_EXPR, void_type_node, lhs,
179 gfc_add_expr_to_block (pblock, tmp);
184 gfc_add_modify (stmtblock_t * pblock, tree lhs, tree rhs)
186 gfc_add_modify_loc (input_location, pblock, lhs, rhs);
190 /* Create a new scope/binding level and initialize a block. Care must be
191 taken when translating expressions as any temporaries will be placed in
192 the innermost scope. */
195 gfc_start_block (stmtblock_t * block)
197 /* Start a new binding level. */
199 block->has_scope = 1;
201 /* The block is empty. */
202 block->head = NULL_TREE;
206 /* Initialize a block without creating a new scope. */
209 gfc_init_block (stmtblock_t * block)
211 block->head = NULL_TREE;
212 block->has_scope = 0;
216 /* Sometimes we create a scope but it turns out that we don't actually
217 need it. This function merges the scope of BLOCK with its parent.
218 Only variable decls will be merged, you still need to add the code. */
221 gfc_merge_block_scope (stmtblock_t * block)
226 gcc_assert (block->has_scope);
227 block->has_scope = 0;
229 /* Remember the decls in this scope. */
233 /* Add them to the parent scope. */
234 while (decl != NULL_TREE)
236 next = DECL_CHAIN (decl);
237 DECL_CHAIN (decl) = NULL_TREE;
245 /* Finish a scope containing a block of statements. */
248 gfc_finish_block (stmtblock_t * stmtblock)
254 expr = stmtblock->head;
256 expr = build_empty_stmt (input_location);
258 stmtblock->head = NULL_TREE;
260 if (stmtblock->has_scope)
266 block = poplevel (1, 0, 0);
267 expr = build3_v (BIND_EXPR, decl, expr, block);
277 /* Build an ADDR_EXPR and cast the result to TYPE. If TYPE is NULL, the
278 natural type is used. */
281 gfc_build_addr_expr (tree type, tree t)
283 tree base_type = TREE_TYPE (t);
286 if (type && POINTER_TYPE_P (type)
287 && TREE_CODE (base_type) == ARRAY_TYPE
288 && TYPE_MAIN_VARIANT (TREE_TYPE (type))
289 == TYPE_MAIN_VARIANT (TREE_TYPE (base_type)))
291 tree min_val = size_zero_node;
292 tree type_domain = TYPE_DOMAIN (base_type);
293 if (type_domain && TYPE_MIN_VALUE (type_domain))
294 min_val = TYPE_MIN_VALUE (type_domain);
295 t = fold (build4_loc (input_location, ARRAY_REF, TREE_TYPE (type),
296 t, min_val, NULL_TREE, NULL_TREE));
300 natural_type = build_pointer_type (base_type);
302 if (TREE_CODE (t) == INDIRECT_REF)
306 t = TREE_OPERAND (t, 0);
307 natural_type = TREE_TYPE (t);
311 tree base = get_base_address (t);
312 if (base && DECL_P (base))
313 TREE_ADDRESSABLE (base) = 1;
314 t = fold_build1_loc (input_location, ADDR_EXPR, natural_type, t);
317 if (type && natural_type != type)
318 t = convert (type, t);
324 /* Build an ARRAY_REF with its natural type. */
327 gfc_build_array_ref (tree base, tree offset, tree decl)
329 tree type = TREE_TYPE (base);
332 gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
333 type = TREE_TYPE (type);
336 TREE_ADDRESSABLE (base) = 1;
338 /* Strip NON_LVALUE_EXPR nodes. */
339 STRIP_TYPE_NOPS (offset);
341 /* If the array reference is to a pointer, whose target contains a
342 subreference, use the span that is stored with the backend decl
343 and reference the element with pointer arithmetic. */
344 if (decl && (TREE_CODE (decl) == FIELD_DECL
345 || TREE_CODE (decl) == VAR_DECL
346 || TREE_CODE (decl) == PARM_DECL)
347 && GFC_DECL_SUBREF_ARRAY_P (decl)
348 && !integer_zerop (GFC_DECL_SPAN(decl)))
350 offset = fold_build2_loc (input_location, MULT_EXPR,
351 gfc_array_index_type,
352 offset, GFC_DECL_SPAN(decl));
353 tmp = gfc_build_addr_expr (pvoid_type_node, base);
354 tmp = fold_build2_loc (input_location, POINTER_PLUS_EXPR,
355 pvoid_type_node, tmp,
356 fold_convert (sizetype, offset));
357 tmp = fold_convert (build_pointer_type (type), tmp);
358 if (!TYPE_STRING_FLAG (type))
359 tmp = build_fold_indirect_ref_loc (input_location, tmp);
363 /* Otherwise use a straightforward array reference. */
364 return build4_loc (input_location, ARRAY_REF, type, base, offset,
365 NULL_TREE, NULL_TREE);
369 /* Generate a call to print a runtime error possibly including multiple
370 arguments and a locus. */
373 trans_runtime_error_vararg (bool error, locus* where, const char* msgid,
386 /* Compute the number of extra arguments from the format string. */
387 for (p = msgid, nargs = 0; *p; p++)
395 /* The code to generate the error. */
396 gfc_start_block (&block);
400 line = LOCATION_LINE (where->lb->location);
401 asprintf (&message, "At line %d of file %s", line,
402 where->lb->file->filename);
405 asprintf (&message, "In file '%s', around line %d",
406 gfc_source_file, input_line + 1);
408 arg = gfc_build_addr_expr (pchar_type_node,
409 gfc_build_localized_cstring_const (message));
412 asprintf (&message, "%s", _(msgid));
413 arg2 = gfc_build_addr_expr (pchar_type_node,
414 gfc_build_localized_cstring_const (message));
417 /* Build the argument array. */
418 argarray = XALLOCAVEC (tree, nargs + 2);
421 for (i = 0; i < nargs; i++)
422 argarray[2 + i] = va_arg (ap, tree);
424 /* Build the function call to runtime_(warning,error)_at; because of the
425 variable number of arguments, we can't use build_call_expr_loc dinput_location,
428 fntype = TREE_TYPE (gfor_fndecl_runtime_error_at);
430 fntype = TREE_TYPE (gfor_fndecl_runtime_warning_at);
432 loc = where ? where->lb->location : input_location;
433 tmp = fold_builtin_call_array (loc, TREE_TYPE (fntype),
434 fold_build1_loc (loc, ADDR_EXPR,
435 build_pointer_type (fntype),
437 ? gfor_fndecl_runtime_error_at
438 : gfor_fndecl_runtime_warning_at),
439 nargs + 2, argarray);
440 gfc_add_expr_to_block (&block, tmp);
442 return gfc_finish_block (&block);
447 gfc_trans_runtime_error (bool error, locus* where, const char* msgid, ...)
452 va_start (ap, msgid);
453 result = trans_runtime_error_vararg (error, where, msgid, ap);
459 /* Generate a runtime error if COND is true. */
462 gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock,
463 locus * where, const char * msgid, ...)
471 if (integer_zerop (cond))
476 tmpvar = gfc_create_var (boolean_type_node, "print_warning");
477 TREE_STATIC (tmpvar) = 1;
478 DECL_INITIAL (tmpvar) = boolean_true_node;
479 gfc_add_expr_to_block (pblock, tmpvar);
482 gfc_start_block (&block);
484 /* The code to generate the error. */
485 va_start (ap, msgid);
486 gfc_add_expr_to_block (&block,
487 trans_runtime_error_vararg (error, where,
491 gfc_add_modify (&block, tmpvar, boolean_false_node);
493 body = gfc_finish_block (&block);
495 if (integer_onep (cond))
497 gfc_add_expr_to_block (pblock, body);
501 /* Tell the compiler that this isn't likely. */
503 cond = fold_build2_loc (where->lb->location, TRUTH_AND_EXPR,
504 long_integer_type_node, tmpvar, cond);
506 cond = fold_convert (long_integer_type_node, cond);
508 tmp = build_int_cst (long_integer_type_node, 0);
509 cond = build_call_expr_loc (where->lb->location,
510 built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
511 cond = fold_convert (boolean_type_node, cond);
513 tmp = fold_build3_loc (where->lb->location, COND_EXPR, void_type_node,
515 build_empty_stmt (where->lb->location));
516 gfc_add_expr_to_block (pblock, tmp);
521 /* Call malloc to allocate size bytes of memory, with special conditions:
522 + if size == 0, return a malloced area of size 1,
523 + if malloc returns NULL, issue a runtime error. */
525 gfc_call_malloc (stmtblock_t * block, tree type, tree size)
527 tree tmp, msg, malloc_result, null_result, res;
530 size = gfc_evaluate_now (size, block);
532 if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
533 size = fold_convert (size_type_node, size);
535 /* Create a variable to hold the result. */
536 res = gfc_create_var (prvoid_type_node, NULL);
539 gfc_start_block (&block2);
541 size = fold_build2_loc (input_location, MAX_EXPR, size_type_node, size,
542 build_int_cst (size_type_node, 1));
544 gfc_add_modify (&block2, res,
545 fold_convert (prvoid_type_node,
546 build_call_expr_loc (input_location,
547 built_in_decls[BUILT_IN_MALLOC], 1, size)));
549 /* Optionally check whether malloc was successful. */
550 if (gfc_option.rtcheck & GFC_RTCHECK_MEM)
552 null_result = fold_build2_loc (input_location, EQ_EXPR,
553 boolean_type_node, res,
554 build_int_cst (pvoid_type_node, 0));
555 msg = gfc_build_addr_expr (pchar_type_node,
556 gfc_build_localized_cstring_const ("Memory allocation failed"));
557 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
559 build_call_expr_loc (input_location,
560 gfor_fndecl_os_error, 1, msg),
561 build_empty_stmt (input_location));
562 gfc_add_expr_to_block (&block2, tmp);
565 malloc_result = gfc_finish_block (&block2);
567 gfc_add_expr_to_block (block, malloc_result);
570 res = fold_convert (type, res);
575 /* Allocate memory, using an optional status argument.
577 This function follows the following pseudo-code:
580 allocate (size_t size, integer_type* stat)
587 newmem = malloc (MAX (size, 1));
591 *stat = LIBERROR_ALLOCATION;
593 runtime_error ("Allocation would exceed memory limit");
598 gfc_allocate_with_status (stmtblock_t * block, tree size, tree status)
600 stmtblock_t alloc_block;
601 tree res, tmp, msg, cond;
602 tree status_type = status ? TREE_TYPE (TREE_TYPE (status)) : NULL_TREE;
604 /* Evaluate size only once, and make sure it has the right type. */
605 size = gfc_evaluate_now (size, block);
606 if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
607 size = fold_convert (size_type_node, size);
609 /* Create a variable to hold the result. */
610 res = gfc_create_var (prvoid_type_node, NULL);
612 /* Set the optional status variable to zero. */
613 if (status != NULL_TREE && !integer_zerop (status))
615 tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
616 fold_build1_loc (input_location, INDIRECT_REF,
617 status_type, status),
618 build_int_cst (status_type, 0));
619 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
620 fold_build2_loc (input_location, NE_EXPR,
621 boolean_type_node, status,
622 build_int_cst (TREE_TYPE (status), 0)),
623 tmp, build_empty_stmt (input_location));
624 gfc_add_expr_to_block (block, tmp);
627 /* The allocation itself. */
628 gfc_start_block (&alloc_block);
629 gfc_add_modify (&alloc_block, res,
630 fold_convert (prvoid_type_node,
631 build_call_expr_loc (input_location,
632 built_in_decls[BUILT_IN_MALLOC], 1,
633 fold_build2_loc (input_location,
634 MAX_EXPR, size_type_node, size,
635 build_int_cst (size_type_node,
638 msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
639 ("Allocation would exceed memory limit"));
640 tmp = build_call_expr_loc (input_location,
641 gfor_fndecl_os_error, 1, msg);
643 if (status != NULL_TREE && !integer_zerop (status))
645 /* Set the status variable if it's present. */
648 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
649 status, build_int_cst (TREE_TYPE (status), 0));
650 tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
651 fold_build1_loc (input_location, INDIRECT_REF,
652 status_type, status),
653 build_int_cst (status_type, LIBERROR_ALLOCATION));
654 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
658 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
659 fold_build2_loc (input_location, EQ_EXPR,
660 boolean_type_node, res,
661 build_int_cst (prvoid_type_node, 0)),
662 tmp, build_empty_stmt (input_location));
663 gfc_add_expr_to_block (&alloc_block, tmp);
664 gfc_add_expr_to_block (block, gfc_finish_block (&alloc_block));
670 /* Generate code for an ALLOCATE statement when the argument is an
671 allocatable array. If the array is currently allocated, it is an
672 error to allocate it again.
674 This function follows the following pseudo-code:
677 allocate_array (void *mem, size_t size, integer_type *stat)
680 return allocate (size, stat);
686 mem = allocate (size, stat);
687 *stat = LIBERROR_ALLOCATION;
691 runtime_error ("Attempting to allocate already allocated variable");
695 expr must be set to the original expression being allocated for its locus
696 and variable name in case a runtime error has to be printed. */
698 gfc_allocate_array_with_status (stmtblock_t * block, tree mem, tree size,
699 tree status, gfc_expr* expr)
701 stmtblock_t alloc_block;
702 tree res, tmp, null_mem, alloc, error;
703 tree type = TREE_TYPE (mem);
705 if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
706 size = fold_convert (size_type_node, size);
708 /* Create a variable to hold the result. */
709 res = gfc_create_var (type, NULL);
710 null_mem = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, mem,
711 build_int_cst (type, 0));
713 /* If mem is NULL, we call gfc_allocate_with_status. */
714 gfc_start_block (&alloc_block);
715 tmp = gfc_allocate_with_status (&alloc_block, size, status);
716 gfc_add_modify (&alloc_block, res, fold_convert (type, tmp));
717 alloc = gfc_finish_block (&alloc_block);
719 /* Otherwise, we issue a runtime error or set the status variable. */
724 gcc_assert (expr->expr_type == EXPR_VARIABLE && expr->symtree);
725 varname = gfc_build_cstring_const (expr->symtree->name);
726 varname = gfc_build_addr_expr (pchar_type_node, varname);
728 error = gfc_trans_runtime_error (true, &expr->where,
729 "Attempting to allocate already"
730 " allocated variable '%s'",
734 error = gfc_trans_runtime_error (true, NULL,
735 "Attempting to allocate already allocated"
738 if (status != NULL_TREE && !integer_zerop (status))
740 tree status_type = TREE_TYPE (TREE_TYPE (status));
741 stmtblock_t set_status_block;
743 gfc_start_block (&set_status_block);
744 tmp = build_call_expr_loc (input_location,
745 built_in_decls[BUILT_IN_FREE], 1,
746 fold_convert (pvoid_type_node, mem));
747 gfc_add_expr_to_block (&set_status_block, tmp);
749 tmp = gfc_allocate_with_status (&set_status_block, size, status);
750 gfc_add_modify (&set_status_block, res, fold_convert (type, tmp));
752 gfc_add_modify (&set_status_block,
753 fold_build1_loc (input_location, INDIRECT_REF,
754 status_type, status),
755 build_int_cst (status_type, LIBERROR_ALLOCATION));
757 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
758 status, build_int_cst (status_type, 0));
759 error = fold_build3_loc (input_location, COND_EXPR, void_type_node, tmp,
760 error, gfc_finish_block (&set_status_block));
763 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, null_mem,
765 gfc_add_expr_to_block (block, tmp);
771 /* Free a given variable, if it's not NULL. */
773 gfc_call_free (tree var)
776 tree tmp, cond, call;
778 if (TREE_TYPE (var) != TREE_TYPE (pvoid_type_node))
779 var = fold_convert (pvoid_type_node, var);
781 gfc_start_block (&block);
782 var = gfc_evaluate_now (var, &block);
783 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, var,
784 build_int_cst (pvoid_type_node, 0));
785 call = build_call_expr_loc (input_location,
786 built_in_decls[BUILT_IN_FREE], 1, var);
787 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, call,
788 build_empty_stmt (input_location));
789 gfc_add_expr_to_block (&block, tmp);
791 return gfc_finish_block (&block);
796 /* User-deallocate; we emit the code directly from the front-end, and the
797 logic is the same as the previous library function:
800 deallocate (void *pointer, GFC_INTEGER_4 * stat)
807 runtime_error ("Attempt to DEALLOCATE unallocated memory.");
817 In this front-end version, status doesn't have to be GFC_INTEGER_4.
818 Moreover, if CAN_FAIL is true, then we will not emit a runtime error,
819 even when no status variable is passed to us (this is used for
820 unconditional deallocation generated by the front-end at end of
823 If a runtime-message is possible, `expr' must point to the original
824 expression being deallocated for its locus and variable name. */
826 gfc_deallocate_with_status (tree pointer, tree status, bool can_fail,
829 stmtblock_t null, non_null;
830 tree cond, tmp, error;
832 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer,
833 build_int_cst (TREE_TYPE (pointer), 0));
835 /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
836 we emit a runtime error. */
837 gfc_start_block (&null);
842 gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree);
844 varname = gfc_build_cstring_const (expr->symtree->name);
845 varname = gfc_build_addr_expr (pchar_type_node, varname);
847 error = gfc_trans_runtime_error (true, &expr->where,
848 "Attempt to DEALLOCATE unallocated '%s'",
852 error = build_empty_stmt (input_location);
854 if (status != NULL_TREE && !integer_zerop (status))
856 tree status_type = TREE_TYPE (TREE_TYPE (status));
859 cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
860 status, build_int_cst (TREE_TYPE (status), 0));
861 tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
862 fold_build1_loc (input_location, INDIRECT_REF,
863 status_type, status),
864 build_int_cst (status_type, 1));
865 error = fold_build3_loc (input_location, COND_EXPR, void_type_node,
869 gfc_add_expr_to_block (&null, error);
871 /* When POINTER is not NULL, we free it. */
872 gfc_start_block (&non_null);
873 tmp = build_call_expr_loc (input_location,
874 built_in_decls[BUILT_IN_FREE], 1,
875 fold_convert (pvoid_type_node, pointer));
876 gfc_add_expr_to_block (&non_null, tmp);
878 if (status != NULL_TREE && !integer_zerop (status))
880 /* We set STATUS to zero if it is present. */
881 tree status_type = TREE_TYPE (TREE_TYPE (status));
884 cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
885 status, build_int_cst (TREE_TYPE (status), 0));
886 tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
887 fold_build1_loc (input_location, INDIRECT_REF,
888 status_type, status),
889 build_int_cst (status_type, 0));
890 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
891 tmp, build_empty_stmt (input_location));
892 gfc_add_expr_to_block (&non_null, tmp);
895 return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
896 gfc_finish_block (&null),
897 gfc_finish_block (&non_null));
901 /* Generate code for deallocation of allocatable scalars (variables or
902 components). Before the object itself is freed, any allocatable
903 subcomponents are being deallocated. */
906 gfc_deallocate_scalar_with_status (tree pointer, tree status, bool can_fail,
907 gfc_expr* expr, gfc_typespec ts)
909 stmtblock_t null, non_null;
910 tree cond, tmp, error;
912 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer,
913 build_int_cst (TREE_TYPE (pointer), 0));
915 /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
916 we emit a runtime error. */
917 gfc_start_block (&null);
922 gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree);
924 varname = gfc_build_cstring_const (expr->symtree->name);
925 varname = gfc_build_addr_expr (pchar_type_node, varname);
927 error = gfc_trans_runtime_error (true, &expr->where,
928 "Attempt to DEALLOCATE unallocated '%s'",
932 error = build_empty_stmt (input_location);
934 if (status != NULL_TREE && !integer_zerop (status))
936 tree status_type = TREE_TYPE (TREE_TYPE (status));
939 cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
940 status, build_int_cst (TREE_TYPE (status), 0));
941 tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
942 fold_build1_loc (input_location, INDIRECT_REF,
943 status_type, status),
944 build_int_cst (status_type, 1));
945 error = fold_build3_loc (input_location, COND_EXPR, void_type_node,
949 gfc_add_expr_to_block (&null, error);
951 /* When POINTER is not NULL, we free it. */
952 gfc_start_block (&non_null);
954 /* Free allocatable components. */
955 if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
957 tmp = build_fold_indirect_ref_loc (input_location, pointer);
958 tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
959 gfc_add_expr_to_block (&non_null, tmp);
961 else if (ts.type == BT_CLASS
962 && ts.u.derived->components->ts.u.derived->attr.alloc_comp)
964 tmp = build_fold_indirect_ref_loc (input_location, pointer);
965 tmp = gfc_deallocate_alloc_comp (ts.u.derived->components->ts.u.derived,
967 gfc_add_expr_to_block (&non_null, tmp);
970 tmp = build_call_expr_loc (input_location,
971 built_in_decls[BUILT_IN_FREE], 1,
972 fold_convert (pvoid_type_node, pointer));
973 gfc_add_expr_to_block (&non_null, tmp);
975 if (status != NULL_TREE && !integer_zerop (status))
977 /* We set STATUS to zero if it is present. */
978 tree status_type = TREE_TYPE (TREE_TYPE (status));
981 cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
982 status, build_int_cst (TREE_TYPE (status), 0));
983 tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
984 fold_build1_loc (input_location, INDIRECT_REF,
985 status_type, status),
986 build_int_cst (status_type, 0));
987 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
988 tmp, build_empty_stmt (input_location));
989 gfc_add_expr_to_block (&non_null, tmp);
992 return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
993 gfc_finish_block (&null),
994 gfc_finish_block (&non_null));
998 /* Reallocate MEM so it has SIZE bytes of data. This behaves like the
999 following pseudo-code:
1002 internal_realloc (void *mem, size_t size)
1004 res = realloc (mem, size);
1005 if (!res && size != 0)
1006 _gfortran_os_error ("Allocation would exceed memory limit");
1014 gfc_call_realloc (stmtblock_t * block, tree mem, tree size)
1016 tree msg, res, nonzero, zero, null_result, tmp;
1017 tree type = TREE_TYPE (mem);
1019 size = gfc_evaluate_now (size, block);
1021 if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
1022 size = fold_convert (size_type_node, size);
1024 /* Create a variable to hold the result. */
1025 res = gfc_create_var (type, NULL);
1027 /* Call realloc and check the result. */
1028 tmp = build_call_expr_loc (input_location,
1029 built_in_decls[BUILT_IN_REALLOC], 2,
1030 fold_convert (pvoid_type_node, mem), size);
1031 gfc_add_modify (block, res, fold_convert (type, tmp));
1032 null_result = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
1033 res, build_int_cst (pvoid_type_node, 0));
1034 nonzero = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, size,
1035 build_int_cst (size_type_node, 0));
1036 null_result = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
1037 null_result, nonzero);
1038 msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
1039 ("Allocation would exceed memory limit"));
1040 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1042 build_call_expr_loc (input_location,
1043 gfor_fndecl_os_error, 1, msg),
1044 build_empty_stmt (input_location));
1045 gfc_add_expr_to_block (block, tmp);
1047 /* if (size == 0) then the result is NULL. */
1048 tmp = fold_build2_loc (input_location, MODIFY_EXPR, type, res,
1049 build_int_cst (type, 0));
1050 zero = fold_build1_loc (input_location, TRUTH_NOT_EXPR, boolean_type_node,
1052 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, zero, tmp,
1053 build_empty_stmt (input_location));
1054 gfc_add_expr_to_block (block, tmp);
1060 /* Add an expression to another one, either at the front or the back. */
1063 add_expr_to_chain (tree* chain, tree expr, bool front)
1065 if (expr == NULL_TREE || IS_EMPTY_STMT (expr))
1070 if (TREE_CODE (*chain) != STATEMENT_LIST)
1076 append_to_statement_list (tmp, chain);
1081 tree_stmt_iterator i;
1083 i = tsi_start (*chain);
1084 tsi_link_before (&i, expr, TSI_CONTINUE_LINKING);
1087 append_to_statement_list (expr, chain);
1093 /* Add a statement to a block. */
1096 gfc_add_expr_to_block (stmtblock_t * block, tree expr)
1099 add_expr_to_chain (&block->head, expr, false);
1103 /* Add a block the end of a block. */
1106 gfc_add_block_to_block (stmtblock_t * block, stmtblock_t * append)
1108 gcc_assert (append);
1109 gcc_assert (!append->has_scope);
1111 gfc_add_expr_to_block (block, append->head);
1112 append->head = NULL_TREE;
1116 /* Save the current locus. The structure may not be complete, and should
1117 only be used with gfc_restore_backend_locus. */
1120 gfc_save_backend_locus (locus * loc)
1122 loc->lb = XCNEW (gfc_linebuf);
1123 loc->lb->location = input_location;
1124 loc->lb->file = gfc_current_backend_file;
1128 /* Set the current locus. */
1131 gfc_set_backend_locus (locus * loc)
1133 gfc_current_backend_file = loc->lb->file;
1134 input_location = loc->lb->location;
1138 /* Restore the saved locus. Only used in conjonction with
1139 gfc_save_backend_locus, to free the memory when we are done. */
1142 gfc_restore_backend_locus (locus * loc)
1144 gfc_set_backend_locus (loc);
1149 /* Translate an executable statement. The tree cond is used by gfc_trans_do.
1150 This static function is wrapped by gfc_trans_code_cond and
1154 trans_code (gfc_code * code, tree cond)
1160 return build_empty_stmt (input_location);
1162 gfc_start_block (&block);
1164 /* Translate statements one by one into GENERIC trees until we reach
1165 the end of this gfc_code branch. */
1166 for (; code; code = code->next)
1168 if (code->here != 0)
1170 res = gfc_trans_label_here (code);
1171 gfc_add_expr_to_block (&block, res);
1174 gfc_set_backend_locus (&code->loc);
1179 case EXEC_END_BLOCK:
1180 case EXEC_END_PROCEDURE:
1185 if (code->expr1->ts.type == BT_CLASS)
1186 res = gfc_trans_class_assign (code->expr1, code->expr2, code->op);
1188 res = gfc_trans_assign (code);
1191 case EXEC_LABEL_ASSIGN:
1192 res = gfc_trans_label_assign (code);
1195 case EXEC_POINTER_ASSIGN:
1196 if (code->expr1->ts.type == BT_CLASS)
1197 res = gfc_trans_class_assign (code->expr1, code->expr2, code->op);
1199 res = gfc_trans_pointer_assign (code);
1202 case EXEC_INIT_ASSIGN:
1203 if (code->expr1->ts.type == BT_CLASS)
1204 res = gfc_trans_class_init_assign (code);
1206 res = gfc_trans_init_assign (code);
1214 res = gfc_trans_critical (code);
1218 res = gfc_trans_cycle (code);
1222 res = gfc_trans_exit (code);
1226 res = gfc_trans_goto (code);
1230 res = gfc_trans_entry (code);
1234 res = gfc_trans_pause (code);
1238 case EXEC_ERROR_STOP:
1239 res = gfc_trans_stop (code, code->op == EXEC_ERROR_STOP);
1243 /* For MVBITS we've got the special exception that we need a
1244 dependency check, too. */
1246 bool is_mvbits = false;
1247 if (code->resolved_isym
1248 && code->resolved_isym->id == GFC_ISYM_MVBITS)
1250 if (code->resolved_isym
1251 && code->resolved_isym->id == GFC_ISYM_MOVE_ALLOC)
1252 res = gfc_conv_intrinsic_move_alloc (code);
1254 res = gfc_trans_call (code, is_mvbits, NULL_TREE,
1260 res = gfc_trans_call (code, false, NULL_TREE,
1264 case EXEC_ASSIGN_CALL:
1265 res = gfc_trans_call (code, true, NULL_TREE,
1270 res = gfc_trans_return (code);
1274 res = gfc_trans_if (code);
1277 case EXEC_ARITHMETIC_IF:
1278 res = gfc_trans_arithmetic_if (code);
1282 res = gfc_trans_block_construct (code);
1286 res = gfc_trans_do (code, cond);
1290 res = gfc_trans_do_while (code);
1294 res = gfc_trans_select (code);
1297 case EXEC_SELECT_TYPE:
1298 /* Do nothing. SELECT TYPE statements should be transformed into
1299 an ordinary SELECT CASE at resolution stage.
1300 TODO: Add an error message here once this is done. */
1305 res = gfc_trans_flush (code);
1309 case EXEC_SYNC_IMAGES:
1310 case EXEC_SYNC_MEMORY:
1311 res = gfc_trans_sync (code, code->op);
1315 res = gfc_trans_forall (code);
1319 res = gfc_trans_where (code);
1323 res = gfc_trans_allocate (code);
1326 case EXEC_DEALLOCATE:
1327 res = gfc_trans_deallocate (code);
1331 res = gfc_trans_open (code);
1335 res = gfc_trans_close (code);
1339 res = gfc_trans_read (code);
1343 res = gfc_trans_write (code);
1347 res = gfc_trans_iolength (code);
1350 case EXEC_BACKSPACE:
1351 res = gfc_trans_backspace (code);
1355 res = gfc_trans_endfile (code);
1359 res = gfc_trans_inquire (code);
1363 res = gfc_trans_wait (code);
1367 res = gfc_trans_rewind (code);
1371 res = gfc_trans_transfer (code);
1375 res = gfc_trans_dt_end (code);
1378 case EXEC_OMP_ATOMIC:
1379 case EXEC_OMP_BARRIER:
1380 case EXEC_OMP_CRITICAL:
1382 case EXEC_OMP_FLUSH:
1383 case EXEC_OMP_MASTER:
1384 case EXEC_OMP_ORDERED:
1385 case EXEC_OMP_PARALLEL:
1386 case EXEC_OMP_PARALLEL_DO:
1387 case EXEC_OMP_PARALLEL_SECTIONS:
1388 case EXEC_OMP_PARALLEL_WORKSHARE:
1389 case EXEC_OMP_SECTIONS:
1390 case EXEC_OMP_SINGLE:
1392 case EXEC_OMP_TASKWAIT:
1393 case EXEC_OMP_WORKSHARE:
1394 res = gfc_trans_omp_directive (code);
1398 internal_error ("gfc_trans_code(): Bad statement code");
1401 gfc_set_backend_locus (&code->loc);
1403 if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
1405 if (TREE_CODE (res) != STATEMENT_LIST)
1406 SET_EXPR_LOCATION (res, input_location);
1408 /* Add the new statement to the block. */
1409 gfc_add_expr_to_block (&block, res);
1413 /* Return the finished block. */
1414 return gfc_finish_block (&block);
1418 /* Translate an executable statement with condition, cond. The condition is
1419 used by gfc_trans_do to test for IO result conditions inside implied
1420 DO loops of READ and WRITE statements. See build_dt in trans-io.c. */
1423 gfc_trans_code_cond (gfc_code * code, tree cond)
1425 return trans_code (code, cond);
1428 /* Translate an executable statement without condition. */
1431 gfc_trans_code (gfc_code * code)
1433 return trans_code (code, NULL_TREE);
1437 /* This function is called after a complete program unit has been parsed
1441 gfc_generate_code (gfc_namespace * ns)
1444 if (ns->is_block_data)
1446 gfc_generate_block_data (ns);
1450 gfc_generate_function_code (ns);
1454 /* This function is called after a complete module has been parsed
1458 gfc_generate_module_code (gfc_namespace * ns)
1461 struct module_htab_entry *entry;
1463 gcc_assert (ns->proc_name->backend_decl == NULL);
1464 ns->proc_name->backend_decl
1465 = build_decl (ns->proc_name->declared_at.lb->location,
1466 NAMESPACE_DECL, get_identifier (ns->proc_name->name),
1468 entry = gfc_find_module (ns->proc_name->name);
1469 if (entry->namespace_decl)
1470 /* Buggy sourcecode, using a module before defining it? */
1471 htab_empty (entry->decls);
1472 entry->namespace_decl = ns->proc_name->backend_decl;
1474 gfc_generate_module_vars (ns);
1476 /* We need to generate all module function prototypes first, to allow
1478 for (n = ns->contained; n; n = n->sibling)
1485 gfc_create_function_decl (n, false);
1486 DECL_CONTEXT (n->proc_name->backend_decl) = ns->proc_name->backend_decl;
1487 gfc_module_add_decl (entry, n->proc_name->backend_decl);
1488 for (el = ns->entries; el; el = el->next)
1490 DECL_CONTEXT (el->sym->backend_decl) = ns->proc_name->backend_decl;
1491 gfc_module_add_decl (entry, el->sym->backend_decl);
1495 for (n = ns->contained; n; n = n->sibling)
1500 gfc_generate_function_code (n);
1505 /* Initialize an init/cleanup block with existing code. */
1508 gfc_start_wrapped_block (gfc_wrapped_block* block, tree code)
1512 block->init = NULL_TREE;
1514 block->cleanup = NULL_TREE;
1518 /* Add a new pair of initializers/clean-up code. */
1521 gfc_add_init_cleanup (gfc_wrapped_block* block, tree init, tree cleanup)
1525 /* The new pair of init/cleanup should be "wrapped around" the existing
1526 block of code, thus the initialization is added to the front and the
1527 cleanup to the back. */
1528 add_expr_to_chain (&block->init, init, true);
1529 add_expr_to_chain (&block->cleanup, cleanup, false);
1533 /* Finish up a wrapped block by building a corresponding try-finally expr. */
1536 gfc_finish_wrapped_block (gfc_wrapped_block* block)
1542 /* Build the final expression. For this, just add init and body together,
1543 and put clean-up with that into a TRY_FINALLY_EXPR. */
1544 result = block->init;
1545 add_expr_to_chain (&result, block->code, false);
1547 result = build2_loc (input_location, TRY_FINALLY_EXPR, void_type_node,
1548 result, block->cleanup);
1550 /* Clear the block. */
1551 block->init = NULL_TREE;
1552 block->code = NULL_TREE;
1553 block->cleanup = NULL_TREE;