1 /* Code translation -- generate GCC trees from gfc_code.
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 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 char gfc_msg_bounds[] = N_("Array bound mismatch");
50 char gfc_msg_fault[] = N_("Array reference out of bounds");
51 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 = build4 (ARRAY_REF, TREE_TYPE (type), t, min_val,
282 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 = 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 #ifdef USE_MAPPED_LOCATION
386 line = LOCATION_LINE (where->lb->location);
388 line = where->lb->linenum;
390 asprintf (&message, "At line %d of file %s", line,
391 where->lb->file->filename);
394 asprintf (&message, "In file '%s', around line %d",
395 gfc_source_file, input_line + 1);
397 arg = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const(message));
400 asprintf (&message, "%s", _(msgid));
401 arg2 = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const(message));
404 /* Build the argument array. */
405 argarray = (tree *) alloca (sizeof (tree) * (nargs + 2));
408 va_start (ap, msgid);
409 for (i = 0; i < nargs; i++)
410 argarray[2+i] = va_arg (ap, tree);
413 /* Build the function call to runtime_error_at; because of the variable
414 number of arguments, we can't use build_call_expr directly. */
415 fntype = TREE_TYPE (gfor_fndecl_runtime_error_at);
416 tmp = fold_builtin_call_array (TREE_TYPE (fntype),
418 build_pointer_type (fntype),
419 gfor_fndecl_runtime_error_at),
420 nargs + 2, argarray);
421 gfc_add_expr_to_block (&block, tmp);
423 body = gfc_finish_block (&block);
425 if (integer_onep (cond))
427 gfc_add_expr_to_block (pblock, body);
431 /* Tell the compiler that this isn't likely. */
432 cond = fold_convert (long_integer_type_node, cond);
433 tmp = build_int_cst (long_integer_type_node, 0);
434 cond = build_call_expr (built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
435 cond = fold_convert (boolean_type_node, cond);
437 tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt ());
438 gfc_add_expr_to_block (pblock, tmp);
443 /* Call malloc to allocate size bytes of memory, with special conditions:
444 + if size < 0, generate a runtime error,
445 + if size == 0, return a NULL pointer,
446 + if malloc returns NULL, issue a runtime error. */
448 gfc_call_malloc (stmtblock_t * block, tree type, tree size)
450 tree tmp, msg, negative, zero, malloc_result, null_result, res;
453 size = gfc_evaluate_now (size, block);
455 if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
456 size = fold_convert (size_type_node, size);
458 /* Create a variable to hold the result. */
459 res = gfc_create_var (pvoid_type_node, NULL);
462 negative = fold_build2 (LT_EXPR, boolean_type_node, size,
463 build_int_cst (size_type_node, 0));
464 msg = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const
465 ("Attempt to allocate a negative amount of memory."));
466 tmp = fold_build3 (COND_EXPR, void_type_node, negative,
467 build_call_expr (gfor_fndecl_runtime_error, 1, msg),
468 build_empty_stmt ());
469 gfc_add_expr_to_block (block, tmp);
471 /* Call malloc and check the result. */
472 gfc_start_block (&block2);
473 gfc_add_modify_expr (&block2, res,
474 build_call_expr (built_in_decls[BUILT_IN_MALLOC], 1,
476 null_result = fold_build2 (EQ_EXPR, boolean_type_node, res,
477 build_int_cst (pvoid_type_node, 0));
478 msg = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const
479 ("Memory allocation failed"));
480 tmp = fold_build3 (COND_EXPR, void_type_node, null_result,
481 build_call_expr (gfor_fndecl_os_error, 1, msg),
482 build_empty_stmt ());
483 gfc_add_expr_to_block (&block2, tmp);
484 malloc_result = gfc_finish_block (&block2);
487 zero = fold_build2 (EQ_EXPR, boolean_type_node, size,
488 build_int_cst (size_type_node, 0));
489 tmp = fold_build2 (MODIFY_EXPR, pvoid_type_node, res,
490 build_int_cst (pvoid_type_node, 0));
491 tmp = fold_build3 (COND_EXPR, void_type_node, zero, tmp, malloc_result);
492 gfc_add_expr_to_block (block, tmp);
495 res = fold_convert (type, res);
499 /* Allocate memory, using an optional status argument.
501 This function follows the following pseudo-code:
504 allocate (size_t size, integer_type* stat)
511 // The only time this can happen is the size wraps around.
516 *stat = LIBERROR_ALLOCATION;
520 runtime_error ("Attempt to allocate negative amount of memory. "
521 "Possible integer overflow");
525 newmem = malloc (MAX (size, 1));
529 *stat = LIBERROR_ALLOCATION;
531 runtime_error ("Out of memory");
538 gfc_allocate_with_status (stmtblock_t * block, tree size, tree status)
540 stmtblock_t alloc_block;
541 tree res, tmp, error, msg, cond;
542 tree status_type = status ? TREE_TYPE (TREE_TYPE (status)) : NULL_TREE;
544 /* Evaluate size only once, and make sure it has the right type. */
545 size = gfc_evaluate_now (size, block);
546 if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
547 size = fold_convert (size_type_node, size);
549 /* Create a variable to hold the result. */
550 res = gfc_create_var (pvoid_type_node, NULL);
552 /* Set the optional status variable to zero. */
553 if (status != NULL_TREE && !integer_zerop (status))
555 tmp = fold_build2 (MODIFY_EXPR, status_type,
556 build1 (INDIRECT_REF, status_type, status),
557 build_int_cst (status_type, 0));
558 tmp = fold_build3 (COND_EXPR, void_type_node,
559 fold_build2 (NE_EXPR, boolean_type_node,
560 status, build_int_cst (status_type, 0)),
561 tmp, build_empty_stmt ());
562 gfc_add_expr_to_block (block, tmp);
565 /* Generate the block of code handling (size < 0). */
566 msg = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const
567 ("Attempt to allocate negative amount of memory. "
568 "Possible integer overflow"));
569 error = build_call_expr (gfor_fndecl_runtime_error, 1, msg);
571 if (status != NULL_TREE && !integer_zerop (status))
573 /* Set the status variable if it's present. */
574 stmtblock_t set_status_block;
576 gfc_start_block (&set_status_block);
577 gfc_add_modify_expr (&set_status_block,
578 build1 (INDIRECT_REF, status_type, status),
579 build_int_cst (status_type, LIBERROR_ALLOCATION));
580 gfc_add_modify_expr (&set_status_block, res,
581 build_int_cst (pvoid_type_node, 0));
583 tmp = fold_build2 (EQ_EXPR, boolean_type_node, status,
584 build_int_cst (status_type, 0));
585 error = fold_build3 (COND_EXPR, void_type_node, tmp, error,
586 gfc_finish_block (&set_status_block));
589 /* The allocation itself. */
590 gfc_start_block (&alloc_block);
591 gfc_add_modify_expr (&alloc_block, res,
592 build_call_expr (built_in_decls[BUILT_IN_MALLOC], 1,
593 fold_build2 (MAX_EXPR, size_type_node,
595 build_int_cst (size_type_node, 1))));
597 msg = gfc_build_addr_expr (pchar_type_node,
598 gfc_build_cstring_const ("Out of memory"));
599 tmp = build_call_expr (gfor_fndecl_os_error, 1, msg);
601 if (status != NULL_TREE && !integer_zerop (status))
603 /* Set the status variable if it's present. */
606 cond = fold_build2 (EQ_EXPR, boolean_type_node, status,
607 build_int_cst (status_type, 0));
608 tmp2 = fold_build2 (MODIFY_EXPR, status_type,
609 build1 (INDIRECT_REF, status_type, status),
610 build_int_cst (status_type, LIBERROR_ALLOCATION));
611 tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
615 tmp = fold_build3 (COND_EXPR, void_type_node,
616 fold_build2 (EQ_EXPR, boolean_type_node, res,
617 build_int_cst (pvoid_type_node, 0)),
618 tmp, build_empty_stmt ());
619 gfc_add_expr_to_block (&alloc_block, tmp);
621 cond = fold_build2 (LT_EXPR, boolean_type_node, size,
622 build_int_cst (TREE_TYPE (size), 0));
623 tmp = fold_build3 (COND_EXPR, void_type_node, cond, error,
624 gfc_finish_block (&alloc_block));
625 gfc_add_expr_to_block (block, tmp);
631 /* Generate code for an ALLOCATE statement when the argument is an
632 allocatable array. If the array is currently allocated, it is an
633 error to allocate it again.
635 This function follows the following pseudo-code:
638 allocate_array (void *mem, size_t size, integer_type *stat)
641 return allocate (size, stat);
647 mem = allocate (size, stat);
648 *stat = LIBERROR_ALLOCATION;
652 runtime_error ("Attempting to allocate already allocated array");
655 gfc_allocate_array_with_status (stmtblock_t * block, tree mem, tree size,
658 stmtblock_t alloc_block;
659 tree res, tmp, null_mem, alloc, error, msg;
660 tree type = TREE_TYPE (mem);
662 if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
663 size = fold_convert (size_type_node, size);
665 /* Create a variable to hold the result. */
666 res = gfc_create_var (pvoid_type_node, NULL);
667 null_mem = fold_build2 (EQ_EXPR, boolean_type_node, mem,
668 build_int_cst (type, 0));
670 /* If mem is NULL, we call gfc_allocate_with_status. */
671 gfc_start_block (&alloc_block);
672 tmp = gfc_allocate_with_status (&alloc_block, size, status);
673 gfc_add_modify_expr (&alloc_block, res, fold_convert (type, tmp));
674 alloc = gfc_finish_block (&alloc_block);
676 /* Otherwise, we issue a runtime error or set the status variable. */
677 msg = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const
678 ("Attempting to allocate already allocated array"));
679 error = build_call_expr (gfor_fndecl_runtime_error, 1, msg);
681 if (status != NULL_TREE && !integer_zerop (status))
683 tree status_type = TREE_TYPE (TREE_TYPE (status));
684 stmtblock_t set_status_block;
686 gfc_start_block (&set_status_block);
687 tmp = build_call_expr (built_in_decls[BUILT_IN_FREE], 1,
688 fold_convert (pvoid_type_node, mem));
689 gfc_add_expr_to_block (&set_status_block, tmp);
691 tmp = gfc_allocate_with_status (&set_status_block, size, status);
692 gfc_add_modify_expr (&set_status_block, res, fold_convert (type, tmp));
694 gfc_add_modify_expr (&set_status_block,
695 build1 (INDIRECT_REF, status_type, status),
696 build_int_cst (status_type, LIBERROR_ALLOCATION));
698 tmp = fold_build2 (EQ_EXPR, boolean_type_node, status,
699 build_int_cst (status_type, 0));
700 error = fold_build3 (COND_EXPR, void_type_node, tmp, error,
701 gfc_finish_block (&set_status_block));
704 tmp = fold_build3 (COND_EXPR, void_type_node, null_mem, alloc, error);
705 gfc_add_expr_to_block (block, tmp);
711 /* Free a given variable, if it's not NULL. */
713 gfc_call_free (tree var)
716 tree tmp, cond, call;
718 if (TREE_TYPE (var) != TREE_TYPE (pvoid_type_node))
719 var = fold_convert (pvoid_type_node, var);
721 gfc_start_block (&block);
722 var = gfc_evaluate_now (var, &block);
723 cond = fold_build2 (NE_EXPR, boolean_type_node, var,
724 build_int_cst (pvoid_type_node, 0));
725 call = build_call_expr (built_in_decls[BUILT_IN_FREE], 1, var);
726 tmp = fold_build3 (COND_EXPR, void_type_node, cond, call,
727 build_empty_stmt ());
728 gfc_add_expr_to_block (&block, tmp);
730 return gfc_finish_block (&block);
735 /* User-deallocate; we emit the code directly from the front-end, and the
736 logic is the same as the previous library function:
739 deallocate (void *pointer, GFC_INTEGER_4 * stat)
746 runtime_error ("Attempt to DEALLOCATE unallocated memory.");
756 In this front-end version, status doesn't have to be GFC_INTEGER_4.
757 Moreover, if CAN_FAIL is true, then we will not emit a runtime error,
758 even when no status variable is passed to us (this is used for
759 unconditional deallocation generated by the front-end at end of
762 gfc_deallocate_with_status (tree pointer, tree status, bool can_fail)
764 stmtblock_t null, non_null;
765 tree cond, tmp, error, msg;
767 cond = fold_build2 (EQ_EXPR, boolean_type_node, pointer,
768 build_int_cst (TREE_TYPE (pointer), 0));
770 /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
771 we emit a runtime error. */
772 gfc_start_block (&null);
775 msg = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const
776 ("Attempt to DEALLOCATE unallocated memory."));
777 error = build_call_expr (gfor_fndecl_runtime_error, 1, msg);
780 error = build_empty_stmt ();
782 if (status != NULL_TREE && !integer_zerop (status))
784 tree status_type = TREE_TYPE (TREE_TYPE (status));
787 cond2 = fold_build2 (NE_EXPR, boolean_type_node, status,
788 build_int_cst (TREE_TYPE (status), 0));
789 tmp = fold_build2 (MODIFY_EXPR, status_type,
790 build1 (INDIRECT_REF, status_type, status),
791 build_int_cst (status_type, 1));
792 error = fold_build3 (COND_EXPR, void_type_node, cond2, tmp, error);
795 gfc_add_expr_to_block (&null, error);
797 /* When POINTER is not NULL, we free it. */
798 gfc_start_block (&non_null);
799 tmp = build_call_expr (built_in_decls[BUILT_IN_FREE], 1,
800 fold_convert (pvoid_type_node, pointer));
801 gfc_add_expr_to_block (&non_null, tmp);
803 if (status != NULL_TREE && !integer_zerop (status))
805 /* We set STATUS to zero if it is present. */
806 tree status_type = TREE_TYPE (TREE_TYPE (status));
809 cond2 = fold_build2 (NE_EXPR, boolean_type_node, status,
810 build_int_cst (TREE_TYPE (status), 0));
811 tmp = fold_build2 (MODIFY_EXPR, status_type,
812 build1 (INDIRECT_REF, status_type, status),
813 build_int_cst (status_type, 0));
814 tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp,
815 build_empty_stmt ());
816 gfc_add_expr_to_block (&non_null, tmp);
819 return fold_build3 (COND_EXPR, void_type_node, cond,
820 gfc_finish_block (&null), gfc_finish_block (&non_null));
824 /* Reallocate MEM so it has SIZE bytes of data. This behaves like the
825 following pseudo-code:
828 internal_realloc (void *mem, size_t size)
831 runtime_error ("Attempt to allocate a negative amount of memory.");
832 mem = realloc (mem, size);
833 if (!mem && size != 0)
834 _gfortran_os_error ("Out of memory");
842 gfc_call_realloc (stmtblock_t * block, tree mem, tree size)
844 tree msg, res, negative, zero, null_result, tmp;
845 tree type = TREE_TYPE (mem);
847 size = gfc_evaluate_now (size, block);
849 if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
850 size = fold_convert (size_type_node, size);
852 /* Create a variable to hold the result. */
853 res = gfc_create_var (type, NULL);
856 negative = fold_build2 (LT_EXPR, boolean_type_node, size,
857 build_int_cst (size_type_node, 0));
858 msg = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const
859 ("Attempt to allocate a negative amount of memory."));
860 tmp = fold_build3 (COND_EXPR, void_type_node, negative,
861 build_call_expr (gfor_fndecl_runtime_error, 1, msg),
862 build_empty_stmt ());
863 gfc_add_expr_to_block (block, tmp);
865 /* Call realloc and check the result. */
866 tmp = build_call_expr (built_in_decls[BUILT_IN_REALLOC], 2,
867 fold_convert (pvoid_type_node, mem), size);
868 gfc_add_modify_expr (block, res, fold_convert (type, tmp));
869 null_result = fold_build2 (EQ_EXPR, boolean_type_node, res,
870 build_int_cst (pvoid_type_node, 0));
871 zero = fold_build2 (EQ_EXPR, boolean_type_node, size,
872 build_int_cst (size_type_node, 0));
873 null_result = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, null_result,
875 msg = gfc_build_addr_expr (pchar_type_node,
876 gfc_build_cstring_const ("Out of memory"));
877 tmp = fold_build3 (COND_EXPR, void_type_node, null_result,
878 build_call_expr (gfor_fndecl_os_error, 1, msg),
879 build_empty_stmt ());
880 gfc_add_expr_to_block (block, tmp);
882 /* if (size == 0) then the result is NULL. */
883 tmp = fold_build2 (MODIFY_EXPR, type, res, build_int_cst (type, 0));
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 #ifdef USE_MAPPED_LOCATION
940 loc->lb->location = input_location;
942 loc->lb->linenum = input_line;
944 loc->lb->file = gfc_current_backend_file;
948 /* Set the current locus. */
951 gfc_set_backend_locus (locus * loc)
953 gfc_current_backend_file = loc->lb->file;
954 #ifdef USE_MAPPED_LOCATION
955 input_location = loc->lb->location;
957 input_line = loc->lb->linenum;
958 input_filename = loc->lb->file->filename;
963 /* Translate an executable statement. */
966 gfc_trans_code (gfc_code * code)
972 return build_empty_stmt ();
974 gfc_start_block (&block);
976 /* Translate statements one by one to GIMPLE trees until we reach
977 the end of this gfc_code branch. */
978 for (; code; code = code->next)
982 res = gfc_trans_label_here (code);
983 gfc_add_expr_to_block (&block, res);
993 res = gfc_trans_assign (code);
996 case EXEC_LABEL_ASSIGN:
997 res = gfc_trans_label_assign (code);
1000 case EXEC_POINTER_ASSIGN:
1001 res = gfc_trans_pointer_assign (code);
1004 case EXEC_INIT_ASSIGN:
1005 res = gfc_trans_init_assign (code);
1013 res = gfc_trans_cycle (code);
1017 res = gfc_trans_exit (code);
1021 res = gfc_trans_goto (code);
1025 res = gfc_trans_entry (code);
1029 res = gfc_trans_pause (code);
1033 res = gfc_trans_stop (code);
1037 res = gfc_trans_call (code, false);
1040 case EXEC_ASSIGN_CALL:
1041 res = gfc_trans_call (code, true);
1045 res = gfc_trans_return (code);
1049 res = gfc_trans_if (code);
1052 case EXEC_ARITHMETIC_IF:
1053 res = gfc_trans_arithmetic_if (code);
1057 res = gfc_trans_do (code);
1061 res = gfc_trans_do_while (code);
1065 res = gfc_trans_select (code);
1069 res = gfc_trans_flush (code);
1073 res = gfc_trans_forall (code);
1077 res = gfc_trans_where (code);
1081 res = gfc_trans_allocate (code);
1084 case EXEC_DEALLOCATE:
1085 res = gfc_trans_deallocate (code);
1089 res = gfc_trans_open (code);
1093 res = gfc_trans_close (code);
1097 res = gfc_trans_read (code);
1101 res = gfc_trans_write (code);
1105 res = gfc_trans_iolength (code);
1108 case EXEC_BACKSPACE:
1109 res = gfc_trans_backspace (code);
1113 res = gfc_trans_endfile (code);
1117 res = gfc_trans_inquire (code);
1121 res = gfc_trans_rewind (code);
1125 res = gfc_trans_transfer (code);
1129 res = gfc_trans_dt_end (code);
1132 case EXEC_OMP_ATOMIC:
1133 case EXEC_OMP_BARRIER:
1134 case EXEC_OMP_CRITICAL:
1136 case EXEC_OMP_FLUSH:
1137 case EXEC_OMP_MASTER:
1138 case EXEC_OMP_ORDERED:
1139 case EXEC_OMP_PARALLEL:
1140 case EXEC_OMP_PARALLEL_DO:
1141 case EXEC_OMP_PARALLEL_SECTIONS:
1142 case EXEC_OMP_PARALLEL_WORKSHARE:
1143 case EXEC_OMP_SECTIONS:
1144 case EXEC_OMP_SINGLE:
1145 case EXEC_OMP_WORKSHARE:
1146 res = gfc_trans_omp_directive (code);
1150 internal_error ("gfc_trans_code(): Bad statement code");
1153 gfc_set_backend_locus (&code->loc);
1155 if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
1157 if (TREE_CODE (res) == STATEMENT_LIST)
1158 annotate_all_with_locus (&res, input_location);
1160 SET_EXPR_LOCATION (res, input_location);
1162 /* Add the new statement to the block. */
1163 gfc_add_expr_to_block (&block, res);
1167 /* Return the finished block. */
1168 return gfc_finish_block (&block);
1172 /* This function is called after a complete program unit has been parsed
1176 gfc_generate_code (gfc_namespace * ns)
1178 if (ns->is_block_data)
1180 gfc_generate_block_data (ns);
1184 gfc_generate_function_code (ns);
1188 /* This function is called after a complete module has been parsed
1192 gfc_generate_module_code (gfc_namespace * ns)
1196 gfc_generate_module_vars (ns);
1198 /* We need to generate all module function prototypes first, to allow
1200 for (n = ns->contained; n; n = n->sibling)
1205 gfc_create_function_decl (n);
1208 for (n = ns->contained; n; n = n->sibling)
1213 gfc_generate_function_code (n);