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"
26 #include "tree-gimple.h"
34 #include "trans-stmt.h"
35 #include "trans-array.h"
36 #include "trans-types.h"
37 #include "trans-const.h"
39 /* Naming convention for backend interface code:
41 gfc_trans_* translate gfc_code into STMT trees.
43 gfc_conv_* expression conversion
45 gfc_get_* get a backend tree representation of a decl or type */
47 static gfc_file *gfc_current_backend_file;
49 const char gfc_msg_bounds[] = N_("Array bound mismatch");
50 const char gfc_msg_fault[] = N_("Array reference out of bounds");
51 const char gfc_msg_wrong_return[] = N_("Incorrect function return value");
54 /* Advance along TREE_CHAIN n times. */
57 gfc_advance_chain (tree t, int n)
61 gcc_assert (t != NULL_TREE);
68 /* Wrap a node in a TREE_LIST node and add it to the end of a list. */
71 gfc_chainon_list (tree list, tree add)
75 l = tree_cons (NULL_TREE, add, NULL_TREE);
77 return chainon (list, l);
81 /* Strip off a legitimate source ending from the input
82 string NAME of length LEN. */
85 remove_suffix (char *name, int len)
89 for (i = 2; i < 8 && len > i; i++)
91 if (name[len - i] == '.')
100 /* Creates a variable declaration with a given TYPE. */
103 gfc_create_var_np (tree type, const char *prefix)
107 t = create_tmp_var_raw (type, prefix);
109 /* No warnings for anonymous variables. */
111 TREE_NO_WARNING (t) = 1;
117 /* Like above, but also adds it to the current scope. */
120 gfc_create_var (tree type, const char *prefix)
124 tmp = gfc_create_var_np (type, prefix);
132 /* If the an expression is not constant, evaluate it now. We assign the
133 result of the expression to an artificially created variable VAR, and
134 return a pointer to the VAR_DECL node for this variable. */
137 gfc_evaluate_now (tree expr, stmtblock_t * pblock)
141 if (CONSTANT_CLASS_P (expr))
144 var = gfc_create_var (TREE_TYPE (expr), NULL);
145 gfc_add_modify_expr (pblock, var, expr);
151 /* Build a MODIFY_EXPR (or GIMPLE_MODIFY_STMT) node and add it to a
152 given statement block PBLOCK. A MODIFY_EXPR is an assignment:
156 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 (tuples_p ? GIMPLE_MODIFY_STMT : MODIFY_EXPR,
171 void_type_node, lhs, rhs);
172 gfc_add_expr_to_block (pblock, tmp);
176 /* Create a new scope/binding level and initialize a block. Care must be
177 taken when translating expressions as any temporaries will be placed in
178 the innermost scope. */
181 gfc_start_block (stmtblock_t * block)
183 /* Start a new binding level. */
185 block->has_scope = 1;
187 /* The block is empty. */
188 block->head = NULL_TREE;
192 /* Initialize a block without creating a new scope. */
195 gfc_init_block (stmtblock_t * block)
197 block->head = NULL_TREE;
198 block->has_scope = 0;
202 /* Sometimes we create a scope but it turns out that we don't actually
203 need it. This function merges the scope of BLOCK with its parent.
204 Only variable decls will be merged, you still need to add the code. */
207 gfc_merge_block_scope (stmtblock_t * block)
212 gcc_assert (block->has_scope);
213 block->has_scope = 0;
215 /* Remember the decls in this scope. */
219 /* Add them to the parent scope. */
220 while (decl != NULL_TREE)
222 next = TREE_CHAIN (decl);
223 TREE_CHAIN (decl) = NULL_TREE;
231 /* Finish a scope containing a block of statements. */
234 gfc_finish_block (stmtblock_t * stmtblock)
240 expr = stmtblock->head;
242 expr = build_empty_stmt ();
244 stmtblock->head = NULL_TREE;
246 if (stmtblock->has_scope)
252 block = poplevel (1, 0, 0);
253 expr = build3_v (BIND_EXPR, decl, expr, block);
263 /* Build an ADDR_EXPR and cast the result to TYPE. If TYPE is NULL, the
264 natural type is used. */
267 gfc_build_addr_expr (tree type, tree t)
269 tree base_type = TREE_TYPE (t);
272 if (type && POINTER_TYPE_P (type)
273 && TREE_CODE (base_type) == ARRAY_TYPE
274 && TYPE_MAIN_VARIANT (TREE_TYPE (type))
275 == TYPE_MAIN_VARIANT (TREE_TYPE (base_type)))
277 tree min_val = size_zero_node;
278 tree type_domain = TYPE_DOMAIN (base_type);
279 if (type_domain && TYPE_MIN_VALUE (type_domain))
280 min_val = TYPE_MIN_VALUE (type_domain);
281 t = fold (build4 (ARRAY_REF, TREE_TYPE (type),
282 t, min_val, NULL_TREE, NULL_TREE));
286 natural_type = build_pointer_type (base_type);
288 if (TREE_CODE (t) == INDIRECT_REF)
292 t = TREE_OPERAND (t, 0);
293 natural_type = TREE_TYPE (t);
298 TREE_ADDRESSABLE (t) = 1;
299 t = fold_build1 (ADDR_EXPR, natural_type, t);
302 if (type && natural_type != type)
303 t = convert (type, t);
309 /* Build an ARRAY_REF with its natural type. */
312 gfc_build_array_ref (tree base, tree offset, tree decl)
314 tree type = TREE_TYPE (base);
317 gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
318 type = TREE_TYPE (type);
321 TREE_ADDRESSABLE (base) = 1;
323 /* Strip NON_LVALUE_EXPR nodes. */
324 STRIP_TYPE_NOPS (offset);
326 /* If the array reference is to a pointer, whose target contains a
327 subreference, use the span that is stored with the backend decl
328 and reference the element with pointer arithmetic. */
329 if (decl && (TREE_CODE (decl) == FIELD_DECL
330 || TREE_CODE (decl) == VAR_DECL
331 || TREE_CODE (decl) == PARM_DECL)
332 && GFC_DECL_SUBREF_ARRAY_P (decl)
333 && !integer_zerop (GFC_DECL_SPAN(decl)))
335 offset = fold_build2 (MULT_EXPR, gfc_array_index_type,
336 offset, GFC_DECL_SPAN(decl));
337 tmp = gfc_build_addr_expr (pvoid_type_node, base);
338 tmp = fold_build2 (POINTER_PLUS_EXPR, pvoid_type_node,
339 tmp, fold_convert (sizetype, offset));
340 tmp = fold_convert (build_pointer_type (type), tmp);
341 if (!TYPE_STRING_FLAG (type))
342 tmp = build_fold_indirect_ref (tmp);
346 /* Otherwise use a straightforward array reference. */
347 return build4 (ARRAY_REF, type, base, offset, NULL_TREE, NULL_TREE);
351 /* Generate a runtime error if COND is true. */
354 gfc_trans_runtime_check (tree cond, stmtblock_t * pblock, locus * where,
355 const char * msgid, ...)
368 if (integer_zerop (cond))
371 /* Compute the number of extra arguments from the format string. */
372 for (p = msgid, nargs = 0; *p; p++)
380 /* The code to generate the error. */
381 gfc_start_block (&block);
385 line = LOCATION_LINE (where->lb->location);
386 asprintf (&message, "At line %d of file %s", line,
387 where->lb->file->filename);
390 asprintf (&message, "In file '%s', around line %d",
391 gfc_source_file, input_line + 1);
393 arg = gfc_build_addr_expr (pchar_type_node,
394 gfc_build_localized_cstring_const (message));
397 asprintf (&message, "%s", _(msgid));
398 arg2 = gfc_build_addr_expr (pchar_type_node,
399 gfc_build_localized_cstring_const (message));
402 /* Build the argument array. */
403 argarray = (tree *) alloca (sizeof (tree) * (nargs + 2));
406 va_start (ap, msgid);
407 for (i = 0; i < nargs; i++)
408 argarray[2+i] = va_arg (ap, tree);
411 /* Build the function call to runtime_error_at; because of the variable
412 number of arguments, we can't use build_call_expr directly. */
413 fntype = TREE_TYPE (gfor_fndecl_runtime_error_at);
414 tmp = fold_builtin_call_array (TREE_TYPE (fntype),
415 fold_build1 (ADDR_EXPR,
416 build_pointer_type (fntype),
417 gfor_fndecl_runtime_error_at),
418 nargs + 2, argarray);
419 gfc_add_expr_to_block (&block, tmp);
421 body = gfc_finish_block (&block);
423 if (integer_onep (cond))
425 gfc_add_expr_to_block (pblock, body);
429 /* Tell the compiler that this isn't likely. */
430 cond = fold_convert (long_integer_type_node, cond);
431 tmp = build_int_cst (long_integer_type_node, 0);
432 cond = build_call_expr (built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
433 cond = fold_convert (boolean_type_node, cond);
435 tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt ());
436 gfc_add_expr_to_block (pblock, tmp);
441 /* Call malloc to allocate size bytes of memory, with special conditions:
442 + if size < 0, generate a runtime error,
443 + if size == 0, return a NULL pointer,
444 + if malloc returns NULL, issue a runtime error. */
446 gfc_call_malloc (stmtblock_t * block, tree type, tree size)
448 tree tmp, msg, negative, zero, malloc_result, null_result, res;
451 size = gfc_evaluate_now (size, block);
453 if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
454 size = fold_convert (size_type_node, size);
456 /* Create a variable to hold the result. */
457 res = gfc_create_var (pvoid_type_node, NULL);
460 negative = fold_build2 (LT_EXPR, boolean_type_node, size,
461 build_int_cst (size_type_node, 0));
462 msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
463 ("Attempt to allocate a negative amount of memory."));
464 tmp = fold_build3 (COND_EXPR, void_type_node, negative,
465 build_call_expr (gfor_fndecl_runtime_error, 1, msg),
466 build_empty_stmt ());
467 gfc_add_expr_to_block (block, tmp);
469 /* Call malloc and check the result. */
470 gfc_start_block (&block2);
471 gfc_add_modify_expr (&block2, res,
472 build_call_expr (built_in_decls[BUILT_IN_MALLOC], 1,
474 null_result = fold_build2 (EQ_EXPR, boolean_type_node, res,
475 build_int_cst (pvoid_type_node, 0));
476 msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
477 ("Memory allocation failed"));
478 tmp = fold_build3 (COND_EXPR, void_type_node, null_result,
479 build_call_expr (gfor_fndecl_os_error, 1, msg),
480 build_empty_stmt ());
481 gfc_add_expr_to_block (&block2, tmp);
482 malloc_result = gfc_finish_block (&block2);
485 zero = fold_build2 (EQ_EXPR, boolean_type_node, size,
486 build_int_cst (size_type_node, 0));
487 tmp = fold_build2 (MODIFY_EXPR, pvoid_type_node, res,
488 build_int_cst (pvoid_type_node, 0));
489 tmp = fold_build3 (COND_EXPR, void_type_node, zero, tmp, malloc_result);
490 gfc_add_expr_to_block (block, tmp);
493 res = fold_convert (type, res);
497 /* Allocate memory, using an optional status argument.
499 This function follows the following pseudo-code:
502 allocate (size_t size, integer_type* stat)
509 // The only time this can happen is the size wraps around.
514 *stat = LIBERROR_ALLOCATION;
518 runtime_error ("Attempt to allocate negative amount of memory. "
519 "Possible integer overflow");
523 newmem = malloc (MAX (size, 1));
527 *stat = LIBERROR_ALLOCATION;
529 runtime_error ("Out of memory");
536 gfc_allocate_with_status (stmtblock_t * block, tree size, tree status)
538 stmtblock_t alloc_block;
539 tree res, tmp, error, msg, cond;
540 tree status_type = status ? TREE_TYPE (TREE_TYPE (status)) : NULL_TREE;
542 /* Evaluate size only once, and make sure it has the right type. */
543 size = gfc_evaluate_now (size, block);
544 if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
545 size = fold_convert (size_type_node, size);
547 /* Create a variable to hold the result. */
548 res = gfc_create_var (pvoid_type_node, NULL);
550 /* Set the optional status variable to zero. */
551 if (status != NULL_TREE && !integer_zerop (status))
553 tmp = fold_build2 (MODIFY_EXPR, status_type,
554 fold_build1 (INDIRECT_REF, status_type, status),
555 build_int_cst (status_type, 0));
556 tmp = fold_build3 (COND_EXPR, void_type_node,
557 fold_build2 (NE_EXPR, boolean_type_node,
558 status, build_int_cst (status_type, 0)),
559 tmp, build_empty_stmt ());
560 gfc_add_expr_to_block (block, tmp);
563 /* Generate the block of code handling (size < 0). */
564 msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
565 ("Attempt to allocate negative amount of memory. "
566 "Possible integer overflow"));
567 error = build_call_expr (gfor_fndecl_runtime_error, 1, msg);
569 if (status != NULL_TREE && !integer_zerop (status))
571 /* Set the status variable if it's present. */
572 stmtblock_t set_status_block;
574 gfc_start_block (&set_status_block);
575 gfc_add_modify_expr (&set_status_block,
576 fold_build1 (INDIRECT_REF, status_type, status),
577 build_int_cst (status_type, LIBERROR_ALLOCATION));
578 gfc_add_modify_expr (&set_status_block, res,
579 build_int_cst (pvoid_type_node, 0));
581 tmp = fold_build2 (EQ_EXPR, boolean_type_node, status,
582 build_int_cst (status_type, 0));
583 error = fold_build3 (COND_EXPR, void_type_node, tmp, error,
584 gfc_finish_block (&set_status_block));
587 /* The allocation itself. */
588 gfc_start_block (&alloc_block);
589 gfc_add_modify_expr (&alloc_block, res,
590 build_call_expr (built_in_decls[BUILT_IN_MALLOC], 1,
591 fold_build2 (MAX_EXPR, size_type_node,
593 build_int_cst (size_type_node, 1))));
595 msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
597 tmp = build_call_expr (gfor_fndecl_os_error, 1, msg);
599 if (status != NULL_TREE && !integer_zerop (status))
601 /* Set the status variable if it's present. */
604 cond = fold_build2 (EQ_EXPR, boolean_type_node, status,
605 build_int_cst (status_type, 0));
606 tmp2 = fold_build2 (MODIFY_EXPR, status_type,
607 fold_build1 (INDIRECT_REF, status_type, status),
608 build_int_cst (status_type, LIBERROR_ALLOCATION));
609 tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
613 tmp = fold_build3 (COND_EXPR, void_type_node,
614 fold_build2 (EQ_EXPR, boolean_type_node, res,
615 build_int_cst (pvoid_type_node, 0)),
616 tmp, build_empty_stmt ());
617 gfc_add_expr_to_block (&alloc_block, tmp);
619 cond = fold_build2 (LT_EXPR, boolean_type_node, size,
620 build_int_cst (TREE_TYPE (size), 0));
621 tmp = fold_build3 (COND_EXPR, void_type_node, cond, error,
622 gfc_finish_block (&alloc_block));
623 gfc_add_expr_to_block (block, tmp);
629 /* Generate code for an ALLOCATE statement when the argument is an
630 allocatable array. If the array is currently allocated, it is an
631 error to allocate it again.
633 This function follows the following pseudo-code:
636 allocate_array (void *mem, size_t size, integer_type *stat)
639 return allocate (size, stat);
645 mem = allocate (size, stat);
646 *stat = LIBERROR_ALLOCATION;
650 runtime_error ("Attempting to allocate already allocated array");
653 gfc_allocate_array_with_status (stmtblock_t * block, tree mem, tree size,
656 stmtblock_t alloc_block;
657 tree res, tmp, null_mem, alloc, error, msg;
658 tree type = TREE_TYPE (mem);
660 if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
661 size = fold_convert (size_type_node, size);
663 /* Create a variable to hold the result. */
664 res = gfc_create_var (pvoid_type_node, NULL);
665 null_mem = fold_build2 (EQ_EXPR, boolean_type_node, mem,
666 build_int_cst (type, 0));
668 /* If mem is NULL, we call gfc_allocate_with_status. */
669 gfc_start_block (&alloc_block);
670 tmp = gfc_allocate_with_status (&alloc_block, size, status);
671 gfc_add_modify_expr (&alloc_block, res, fold_convert (type, tmp));
672 alloc = gfc_finish_block (&alloc_block);
674 /* Otherwise, we issue a runtime error or set the status variable. */
675 msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
676 ("Attempting to allocate already allocated array"));
677 error = build_call_expr (gfor_fndecl_runtime_error, 1, msg);
679 if (status != NULL_TREE && !integer_zerop (status))
681 tree status_type = TREE_TYPE (TREE_TYPE (status));
682 stmtblock_t set_status_block;
684 gfc_start_block (&set_status_block);
685 tmp = build_call_expr (built_in_decls[BUILT_IN_FREE], 1,
686 fold_convert (pvoid_type_node, mem));
687 gfc_add_expr_to_block (&set_status_block, tmp);
689 tmp = gfc_allocate_with_status (&set_status_block, size, status);
690 gfc_add_modify_expr (&set_status_block, res, fold_convert (type, tmp));
692 gfc_add_modify_expr (&set_status_block,
693 fold_build1 (INDIRECT_REF, status_type, status),
694 build_int_cst (status_type, LIBERROR_ALLOCATION));
696 tmp = fold_build2 (EQ_EXPR, boolean_type_node, status,
697 build_int_cst (status_type, 0));
698 error = fold_build3 (COND_EXPR, void_type_node, tmp, error,
699 gfc_finish_block (&set_status_block));
702 tmp = fold_build3 (COND_EXPR, void_type_node, null_mem, alloc, error);
703 gfc_add_expr_to_block (block, tmp);
709 /* Free a given variable, if it's not NULL. */
711 gfc_call_free (tree var)
714 tree tmp, cond, call;
716 if (TREE_TYPE (var) != TREE_TYPE (pvoid_type_node))
717 var = fold_convert (pvoid_type_node, var);
719 gfc_start_block (&block);
720 var = gfc_evaluate_now (var, &block);
721 cond = fold_build2 (NE_EXPR, boolean_type_node, var,
722 build_int_cst (pvoid_type_node, 0));
723 call = build_call_expr (built_in_decls[BUILT_IN_FREE], 1, var);
724 tmp = fold_build3 (COND_EXPR, void_type_node, cond, call,
725 build_empty_stmt ());
726 gfc_add_expr_to_block (&block, tmp);
728 return gfc_finish_block (&block);
733 /* User-deallocate; we emit the code directly from the front-end, and the
734 logic is the same as the previous library function:
737 deallocate (void *pointer, GFC_INTEGER_4 * stat)
744 runtime_error ("Attempt to DEALLOCATE unallocated memory.");
754 In this front-end version, status doesn't have to be GFC_INTEGER_4.
755 Moreover, if CAN_FAIL is true, then we will not emit a runtime error,
756 even when no status variable is passed to us (this is used for
757 unconditional deallocation generated by the front-end at end of
760 gfc_deallocate_with_status (tree pointer, tree status, bool can_fail)
762 stmtblock_t null, non_null;
763 tree cond, tmp, error, msg;
765 cond = fold_build2 (EQ_EXPR, boolean_type_node, pointer,
766 build_int_cst (TREE_TYPE (pointer), 0));
768 /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
769 we emit a runtime error. */
770 gfc_start_block (&null);
773 msg = gfc_build_addr_expr (pchar_type_node,
774 gfc_build_localized_cstring_const
775 ("Attempt to DEALLOCATE unallocated memory."));
776 error = build_call_expr (gfor_fndecl_runtime_error, 1, msg);
779 error = build_empty_stmt ();
781 if (status != NULL_TREE && !integer_zerop (status))
783 tree status_type = TREE_TYPE (TREE_TYPE (status));
786 cond2 = fold_build2 (NE_EXPR, boolean_type_node, status,
787 build_int_cst (TREE_TYPE (status), 0));
788 tmp = fold_build2 (MODIFY_EXPR, status_type,
789 fold_build1 (INDIRECT_REF, status_type, status),
790 build_int_cst (status_type, 1));
791 error = fold_build3 (COND_EXPR, void_type_node, cond2, tmp, error);
794 gfc_add_expr_to_block (&null, error);
796 /* When POINTER is not NULL, we free it. */
797 gfc_start_block (&non_null);
798 tmp = build_call_expr (built_in_decls[BUILT_IN_FREE], 1,
799 fold_convert (pvoid_type_node, pointer));
800 gfc_add_expr_to_block (&non_null, tmp);
802 if (status != NULL_TREE && !integer_zerop (status))
804 /* We set STATUS to zero if it is present. */
805 tree status_type = TREE_TYPE (TREE_TYPE (status));
808 cond2 = fold_build2 (NE_EXPR, boolean_type_node, status,
809 build_int_cst (TREE_TYPE (status), 0));
810 tmp = fold_build2 (MODIFY_EXPR, status_type,
811 fold_build1 (INDIRECT_REF, status_type, status),
812 build_int_cst (status_type, 0));
813 tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp,
814 build_empty_stmt ());
815 gfc_add_expr_to_block (&non_null, tmp);
818 return fold_build3 (COND_EXPR, void_type_node, cond,
819 gfc_finish_block (&null), gfc_finish_block (&non_null));
823 /* Reallocate MEM so it has SIZE bytes of data. This behaves like the
824 following pseudo-code:
827 internal_realloc (void *mem, size_t size)
830 runtime_error ("Attempt to allocate a negative amount of memory.");
831 res = realloc (mem, size);
832 if (!res && size != 0)
833 _gfortran_os_error ("Out of memory");
841 gfc_call_realloc (stmtblock_t * block, tree mem, tree size)
843 tree msg, res, negative, nonzero, zero, null_result, tmp;
844 tree type = TREE_TYPE (mem);
846 size = gfc_evaluate_now (size, block);
848 if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
849 size = fold_convert (size_type_node, size);
851 /* Create a variable to hold the result. */
852 res = gfc_create_var (type, NULL);
855 negative = fold_build2 (LT_EXPR, boolean_type_node, size,
856 build_int_cst (size_type_node, 0));
857 msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
858 ("Attempt to allocate a negative amount of memory."));
859 tmp = fold_build3 (COND_EXPR, void_type_node, negative,
860 build_call_expr (gfor_fndecl_runtime_error, 1, msg),
861 build_empty_stmt ());
862 gfc_add_expr_to_block (block, tmp);
864 /* Call realloc and check the result. */
865 tmp = build_call_expr (built_in_decls[BUILT_IN_REALLOC], 2,
866 fold_convert (pvoid_type_node, mem), size);
867 gfc_add_modify_expr (block, res, fold_convert (type, tmp));
868 null_result = fold_build2 (EQ_EXPR, boolean_type_node, res,
869 build_int_cst (pvoid_type_node, 0));
870 nonzero = fold_build2 (NE_EXPR, boolean_type_node, size,
871 build_int_cst (size_type_node, 0));
872 null_result = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, null_result,
874 msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
876 tmp = fold_build3 (COND_EXPR, void_type_node, null_result,
877 build_call_expr (gfor_fndecl_os_error, 1, msg),
878 build_empty_stmt ());
879 gfc_add_expr_to_block (block, tmp);
881 /* if (size == 0) then the result is NULL. */
882 tmp = fold_build2 (MODIFY_EXPR, type, res, build_int_cst (type, 0));
883 zero = fold_build1 (TRUTH_NOT_EXPR, boolean_type_node, nonzero);
884 tmp = fold_build3 (COND_EXPR, void_type_node, zero, tmp,
885 build_empty_stmt ());
886 gfc_add_expr_to_block (block, tmp);
891 /* Add a statement to a block. */
894 gfc_add_expr_to_block (stmtblock_t * block, tree expr)
898 if (expr == NULL_TREE || IS_EMPTY_STMT (expr))
903 if (TREE_CODE (block->head) != STATEMENT_LIST)
908 block->head = NULL_TREE;
909 append_to_statement_list (tmp, &block->head);
911 append_to_statement_list (expr, &block->head);
914 /* Don't bother creating a list if we only have a single statement. */
919 /* Add a block the end of a block. */
922 gfc_add_block_to_block (stmtblock_t * block, stmtblock_t * append)
925 gcc_assert (!append->has_scope);
927 gfc_add_expr_to_block (block, append->head);
928 append->head = NULL_TREE;
932 /* Get the current locus. The structure may not be complete, and should
933 only be used with gfc_set_backend_locus. */
936 gfc_get_backend_locus (locus * loc)
938 loc->lb = gfc_getmem (sizeof (gfc_linebuf));
939 loc->lb->location = input_location;
940 loc->lb->file = gfc_current_backend_file;
944 /* Set the current locus. */
947 gfc_set_backend_locus (locus * loc)
949 gfc_current_backend_file = loc->lb->file;
950 input_location = loc->lb->location;
954 /* Translate an executable statement. */
957 gfc_trans_code (gfc_code * code)
963 return build_empty_stmt ();
965 gfc_start_block (&block);
967 /* Translate statements one by one to GIMPLE trees until we reach
968 the end of this gfc_code branch. */
969 for (; code; code = code->next)
973 res = gfc_trans_label_here (code);
974 gfc_add_expr_to_block (&block, res);
984 res = gfc_trans_assign (code);
987 case EXEC_LABEL_ASSIGN:
988 res = gfc_trans_label_assign (code);
991 case EXEC_POINTER_ASSIGN:
992 res = gfc_trans_pointer_assign (code);
995 case EXEC_INIT_ASSIGN:
996 res = gfc_trans_init_assign (code);
1004 res = gfc_trans_cycle (code);
1008 res = gfc_trans_exit (code);
1012 res = gfc_trans_goto (code);
1016 res = gfc_trans_entry (code);
1020 res = gfc_trans_pause (code);
1024 res = gfc_trans_stop (code);
1028 res = gfc_trans_call (code, false);
1031 case EXEC_ASSIGN_CALL:
1032 res = gfc_trans_call (code, true);
1036 res = gfc_trans_return (code);
1040 res = gfc_trans_if (code);
1043 case EXEC_ARITHMETIC_IF:
1044 res = gfc_trans_arithmetic_if (code);
1048 res = gfc_trans_do (code);
1052 res = gfc_trans_do_while (code);
1056 res = gfc_trans_select (code);
1060 res = gfc_trans_flush (code);
1064 res = gfc_trans_forall (code);
1068 res = gfc_trans_where (code);
1072 res = gfc_trans_allocate (code);
1075 case EXEC_DEALLOCATE:
1076 res = gfc_trans_deallocate (code);
1080 res = gfc_trans_open (code);
1084 res = gfc_trans_close (code);
1088 res = gfc_trans_read (code);
1092 res = gfc_trans_write (code);
1096 res = gfc_trans_iolength (code);
1099 case EXEC_BACKSPACE:
1100 res = gfc_trans_backspace (code);
1104 res = gfc_trans_endfile (code);
1108 res = gfc_trans_inquire (code);
1112 res = gfc_trans_rewind (code);
1116 res = gfc_trans_transfer (code);
1120 res = gfc_trans_dt_end (code);
1123 case EXEC_OMP_ATOMIC:
1124 case EXEC_OMP_BARRIER:
1125 case EXEC_OMP_CRITICAL:
1127 case EXEC_OMP_FLUSH:
1128 case EXEC_OMP_MASTER:
1129 case EXEC_OMP_ORDERED:
1130 case EXEC_OMP_PARALLEL:
1131 case EXEC_OMP_PARALLEL_DO:
1132 case EXEC_OMP_PARALLEL_SECTIONS:
1133 case EXEC_OMP_PARALLEL_WORKSHARE:
1134 case EXEC_OMP_SECTIONS:
1135 case EXEC_OMP_SINGLE:
1136 case EXEC_OMP_WORKSHARE:
1137 res = gfc_trans_omp_directive (code);
1141 internal_error ("gfc_trans_code(): Bad statement code");
1144 gfc_set_backend_locus (&code->loc);
1146 if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
1148 if (TREE_CODE (res) == STATEMENT_LIST)
1149 annotate_all_with_locus (&res, input_location);
1151 SET_EXPR_LOCATION (res, input_location);
1153 /* Add the new statement to the block. */
1154 gfc_add_expr_to_block (&block, res);
1158 /* Return the finished block. */
1159 return gfc_finish_block (&block);
1163 /* This function is called after a complete program unit has been parsed
1167 gfc_generate_code (gfc_namespace * ns)
1169 if (ns->is_block_data)
1171 gfc_generate_block_data (ns);
1175 gfc_generate_function_code (ns);
1179 /* This function is called after a complete module has been parsed
1183 gfc_generate_module_code (gfc_namespace * ns)
1187 gfc_generate_module_vars (ns);
1189 /* We need to generate all module function prototypes first, to allow
1191 for (n = ns->contained; n; n = n->sibling)
1196 gfc_create_function_decl (n);
1199 for (n = ns->contained; n; n = n->sibling)
1204 gfc_generate_function_code (n);