1 /* Code translation -- generate GCC trees from gfc_code.
2 Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation,
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 2, 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 COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
25 #include "coretypes.h"
27 #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;
50 /* Advance along TREE_CHAIN n times. */
53 gfc_advance_chain (tree t, int n)
57 gcc_assert (t != NULL_TREE);
64 /* Wrap a node in a TREE_LIST node and add it to the end of a list. */
67 gfc_chainon_list (tree list, tree add)
71 l = tree_cons (NULL_TREE, add, NULL_TREE);
73 return chainon (list, l);
77 /* Strip off a legitimate source ending from the input
78 string NAME of length LEN. */
81 remove_suffix (char *name, int len)
85 for (i = 2; i < 8 && len > i; i++)
87 if (name[len - i] == '.')
96 /* Creates a variable declaration with a given TYPE. */
99 gfc_create_var_np (tree type, const char *prefix)
101 return create_tmp_var_raw (type, prefix);
105 /* Like above, but also adds it to the current scope. */
108 gfc_create_var (tree type, const char *prefix)
112 tmp = gfc_create_var_np (type, prefix);
120 /* If the an expression is not constant, evaluate it now. We assign the
121 result of the expression to an artificially created variable VAR, and
122 return a pointer to the VAR_DECL node for this variable. */
125 gfc_evaluate_now (tree expr, stmtblock_t * pblock)
129 if (CONSTANT_CLASS_P (expr))
132 var = gfc_create_var (TREE_TYPE (expr), NULL);
133 gfc_add_modify_expr (pblock, var, expr);
139 /* Build a MODIFY_EXPR node and add it to a given statement block PBLOCK.
140 A MODIFY_EXPR is an assignment: LHS <- RHS. */
143 gfc_add_modify_expr (stmtblock_t * pblock, tree lhs, tree rhs)
147 #ifdef ENABLE_CHECKING
148 /* Make sure that the types of the rhs and the lhs are the same
149 for scalar assignments. We should probably have something
150 similar for aggregates, but right now removing that check just
151 breaks everything. */
152 gcc_assert (TREE_TYPE (rhs) == TREE_TYPE (lhs)
153 || AGGREGATE_TYPE_P (TREE_TYPE (lhs)));
156 tmp = fold_build2 (MODIFY_EXPR, void_type_node, lhs, rhs);
157 gfc_add_expr_to_block (pblock, tmp);
161 /* Create a new scope/binding level and initialize a block. Care must be
162 taken when translating expressions as any temporaries will be placed in
163 the innermost scope. */
166 gfc_start_block (stmtblock_t * block)
168 /* Start a new binding level. */
170 block->has_scope = 1;
172 /* The block is empty. */
173 block->head = NULL_TREE;
177 /* Initialize a block without creating a new scope. */
180 gfc_init_block (stmtblock_t * block)
182 block->head = NULL_TREE;
183 block->has_scope = 0;
187 /* Sometimes we create a scope but it turns out that we don't actually
188 need it. This function merges the scope of BLOCK with its parent.
189 Only variable decls will be merged, you still need to add the code. */
192 gfc_merge_block_scope (stmtblock_t * block)
197 gcc_assert (block->has_scope);
198 block->has_scope = 0;
200 /* Remember the decls in this scope. */
204 /* Add them to the parent scope. */
205 while (decl != NULL_TREE)
207 next = TREE_CHAIN (decl);
208 TREE_CHAIN (decl) = NULL_TREE;
216 /* Finish a scope containing a block of statements. */
219 gfc_finish_block (stmtblock_t * stmtblock)
225 expr = stmtblock->head;
227 expr = build_empty_stmt ();
229 stmtblock->head = NULL_TREE;
231 if (stmtblock->has_scope)
237 block = poplevel (1, 0, 0);
238 expr = build3_v (BIND_EXPR, decl, expr, block);
248 /* Build an ADDR_EXPR and cast the result to TYPE. If TYPE is NULL, the
249 natural type is used. */
252 gfc_build_addr_expr (tree type, tree t)
254 tree base_type = TREE_TYPE (t);
257 if (type && POINTER_TYPE_P (type)
258 && TREE_CODE (base_type) == ARRAY_TYPE
259 && TYPE_MAIN_VARIANT (TREE_TYPE (type))
260 == TYPE_MAIN_VARIANT (TREE_TYPE (base_type)))
263 natural_type = build_pointer_type (base_type);
265 if (TREE_CODE (t) == INDIRECT_REF)
269 t = TREE_OPERAND (t, 0);
270 natural_type = TREE_TYPE (t);
275 TREE_ADDRESSABLE (t) = 1;
276 t = build1 (ADDR_EXPR, natural_type, t);
279 if (type && natural_type != type)
280 t = convert (type, t);
286 /* Build an ARRAY_REF with its natural type. */
289 gfc_build_array_ref (tree base, tree offset)
291 tree type = TREE_TYPE (base);
292 gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
293 type = TREE_TYPE (type);
296 TREE_ADDRESSABLE (base) = 1;
298 return build4 (ARRAY_REF, type, base, offset, NULL_TREE, NULL_TREE);
302 /* Generate a runtime error if COND is true. */
305 gfc_trans_runtime_check (tree cond, tree msg, stmtblock_t * pblock)
312 if (integer_zerop (cond))
315 /* The code to generate the error. */
316 gfc_start_block (&block);
318 gcc_assert (TREE_CODE (msg) == STRING_CST);
322 tmp = gfc_build_addr_expr (pchar_type_node, msg);
323 args = gfc_chainon_list (NULL_TREE, tmp);
325 tmp = gfc_build_addr_expr (pchar_type_node, gfc_strconst_current_filename);
326 args = gfc_chainon_list (args, tmp);
328 tmp = build_int_cst (NULL_TREE, input_line);
329 args = gfc_chainon_list (args, tmp);
331 tmp = build_function_call_expr (gfor_fndecl_runtime_error, args);
332 gfc_add_expr_to_block (&block, tmp);
334 body = gfc_finish_block (&block);
336 if (integer_onep (cond))
338 gfc_add_expr_to_block (pblock, body);
342 /* Tell the compiler that this isn't likely. */
343 cond = fold_convert (long_integer_type_node, cond);
344 tmp = gfc_chainon_list (NULL_TREE, cond);
345 tmp = gfc_chainon_list (tmp, build_int_cst (long_integer_type_node, 0));
346 cond = build_function_call_expr (built_in_decls[BUILT_IN_EXPECT], tmp);
347 cond = fold_convert (boolean_type_node, cond);
349 tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt ());
350 gfc_add_expr_to_block (pblock, tmp);
355 /* Add a statement to a block. */
358 gfc_add_expr_to_block (stmtblock_t * block, tree expr)
362 if (expr == NULL_TREE || IS_EMPTY_STMT (expr))
367 if (TREE_CODE (block->head) != STATEMENT_LIST)
372 block->head = NULL_TREE;
373 append_to_statement_list (tmp, &block->head);
375 append_to_statement_list (expr, &block->head);
378 /* Don't bother creating a list if we only have a single statement. */
383 /* Add a block the end of a block. */
386 gfc_add_block_to_block (stmtblock_t * block, stmtblock_t * append)
389 gcc_assert (!append->has_scope);
391 gfc_add_expr_to_block (block, append->head);
392 append->head = NULL_TREE;
396 /* Get the current locus. The structure may not be complete, and should
397 only be used with gfc_set_backend_locus. */
400 gfc_get_backend_locus (locus * loc)
402 loc->lb = gfc_getmem (sizeof (gfc_linebuf));
403 #ifdef USE_MAPPED_LOCATION
404 loc->lb->location = input_location;
406 loc->lb->linenum = input_line;
408 loc->lb->file = gfc_current_backend_file;
412 /* Set the current locus. */
415 gfc_set_backend_locus (locus * loc)
417 gfc_current_backend_file = loc->lb->file;
418 #ifdef USE_MAPPED_LOCATION
419 input_location = loc->lb->location;
421 input_line = loc->lb->linenum;
422 input_filename = loc->lb->file->filename;
427 /* Translate an executable statement. */
430 gfc_trans_code (gfc_code * code)
436 return build_empty_stmt ();
438 gfc_start_block (&block);
440 /* Translate statements one by one to GIMPLE trees until we reach
441 the end of this gfc_code branch. */
442 for (; code; code = code->next)
446 res = gfc_trans_label_here (code);
447 gfc_add_expr_to_block (&block, res);
457 res = gfc_trans_assign (code);
460 case EXEC_LABEL_ASSIGN:
461 res = gfc_trans_label_assign (code);
464 case EXEC_POINTER_ASSIGN:
465 res = gfc_trans_pointer_assign (code);
473 res = gfc_trans_cycle (code);
477 res = gfc_trans_exit (code);
481 res = gfc_trans_goto (code);
485 res = gfc_trans_entry (code);
489 res = gfc_trans_pause (code);
493 res = gfc_trans_stop (code);
497 res = gfc_trans_call (code, false);
500 case EXEC_ASSIGN_CALL:
501 res = gfc_trans_call (code, true);
505 res = gfc_trans_return (code);
509 res = gfc_trans_if (code);
512 case EXEC_ARITHMETIC_IF:
513 res = gfc_trans_arithmetic_if (code);
517 res = gfc_trans_do (code);
521 res = gfc_trans_do_while (code);
525 res = gfc_trans_select (code);
529 res = gfc_trans_flush (code);
533 res = gfc_trans_forall (code);
537 res = gfc_trans_where (code);
541 res = gfc_trans_allocate (code);
544 case EXEC_DEALLOCATE:
545 res = gfc_trans_deallocate (code);
549 res = gfc_trans_open (code);
553 res = gfc_trans_close (code);
557 res = gfc_trans_read (code);
561 res = gfc_trans_write (code);
565 res = gfc_trans_iolength (code);
569 res = gfc_trans_backspace (code);
573 res = gfc_trans_endfile (code);
577 res = gfc_trans_inquire (code);
581 res = gfc_trans_rewind (code);
585 res = gfc_trans_transfer (code);
589 res = gfc_trans_dt_end (code);
592 case EXEC_OMP_ATOMIC:
593 case EXEC_OMP_BARRIER:
594 case EXEC_OMP_CRITICAL:
597 case EXEC_OMP_MASTER:
598 case EXEC_OMP_ORDERED:
599 case EXEC_OMP_PARALLEL:
600 case EXEC_OMP_PARALLEL_DO:
601 case EXEC_OMP_PARALLEL_SECTIONS:
602 case EXEC_OMP_PARALLEL_WORKSHARE:
603 case EXEC_OMP_SECTIONS:
604 case EXEC_OMP_SINGLE:
605 case EXEC_OMP_WORKSHARE:
606 res = gfc_trans_omp_directive (code);
610 internal_error ("gfc_trans_code(): Bad statement code");
613 gfc_set_backend_locus (&code->loc);
615 if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
617 if (TREE_CODE (res) == STATEMENT_LIST)
618 annotate_all_with_locus (&res, input_location);
620 SET_EXPR_LOCATION (res, input_location);
622 /* Add the new statement to the block. */
623 gfc_add_expr_to_block (&block, res);
627 /* Return the finished block. */
628 return gfc_finish_block (&block);
632 /* This function is called after a complete program unit has been parsed
636 gfc_generate_code (gfc_namespace * ns)
638 if (ns->is_block_data)
640 gfc_generate_block_data (ns);
644 gfc_generate_function_code (ns);
648 /* This function is called after a complete module has been parsed
652 gfc_generate_module_code (gfc_namespace * ns)
656 gfc_generate_module_vars (ns);
658 /* We need to generate all module function prototypes first, to allow
660 for (n = ns->contained; n; n = n->sibling)
665 gfc_create_function_decl (n);
668 for (n = ns->contained; n; n = n->sibling)
673 gfc_generate_function_code (n);