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;
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)
105 return create_tmp_var_raw (type, prefix);
109 /* Like above, but also adds it to the current scope. */
112 gfc_create_var (tree type, const char *prefix)
116 tmp = gfc_create_var_np (type, prefix);
124 /* If the an expression is not constant, evaluate it now. We assign the
125 result of the expression to an artificially created variable VAR, and
126 return a pointer to the VAR_DECL node for this variable. */
129 gfc_evaluate_now (tree expr, stmtblock_t * pblock)
133 if (CONSTANT_CLASS_P (expr))
136 var = gfc_create_var (TREE_TYPE (expr), NULL);
137 gfc_add_modify_expr (pblock, var, expr);
143 /* Build a MODIFY_EXPR (or GIMPLE_MODIFY_STMT) node and add it to a
144 given statement block PBLOCK. A MODIFY_EXPR is an assignment:
148 gfc_add_modify (stmtblock_t * pblock, tree lhs, tree rhs,
153 #ifdef ENABLE_CHECKING
154 /* Make sure that the types of the rhs and the lhs are the same
155 for scalar assignments. We should probably have something
156 similar for aggregates, but right now removing that check just
157 breaks everything. */
158 gcc_assert (TREE_TYPE (rhs) == TREE_TYPE (lhs)
159 || AGGREGATE_TYPE_P (TREE_TYPE (lhs)));
162 tmp = fold_build2 (tuples_p ? GIMPLE_MODIFY_STMT : MODIFY_EXPR,
163 void_type_node, lhs, rhs);
164 gfc_add_expr_to_block (pblock, tmp);
168 /* Create a new scope/binding level and initialize a block. Care must be
169 taken when translating expressions as any temporaries will be placed in
170 the innermost scope. */
173 gfc_start_block (stmtblock_t * block)
175 /* Start a new binding level. */
177 block->has_scope = 1;
179 /* The block is empty. */
180 block->head = NULL_TREE;
184 /* Initialize a block without creating a new scope. */
187 gfc_init_block (stmtblock_t * block)
189 block->head = NULL_TREE;
190 block->has_scope = 0;
194 /* Sometimes we create a scope but it turns out that we don't actually
195 need it. This function merges the scope of BLOCK with its parent.
196 Only variable decls will be merged, you still need to add the code. */
199 gfc_merge_block_scope (stmtblock_t * block)
204 gcc_assert (block->has_scope);
205 block->has_scope = 0;
207 /* Remember the decls in this scope. */
211 /* Add them to the parent scope. */
212 while (decl != NULL_TREE)
214 next = TREE_CHAIN (decl);
215 TREE_CHAIN (decl) = NULL_TREE;
223 /* Finish a scope containing a block of statements. */
226 gfc_finish_block (stmtblock_t * stmtblock)
232 expr = stmtblock->head;
234 expr = build_empty_stmt ();
236 stmtblock->head = NULL_TREE;
238 if (stmtblock->has_scope)
244 block = poplevel (1, 0, 0);
245 expr = build3_v (BIND_EXPR, decl, expr, block);
255 /* Build an ADDR_EXPR and cast the result to TYPE. If TYPE is NULL, the
256 natural type is used. */
259 gfc_build_addr_expr (tree type, tree t)
261 tree base_type = TREE_TYPE (t);
264 if (type && POINTER_TYPE_P (type)
265 && TREE_CODE (base_type) == ARRAY_TYPE
266 && TYPE_MAIN_VARIANT (TREE_TYPE (type))
267 == TYPE_MAIN_VARIANT (TREE_TYPE (base_type)))
270 natural_type = build_pointer_type (base_type);
272 if (TREE_CODE (t) == INDIRECT_REF)
276 t = TREE_OPERAND (t, 0);
277 natural_type = TREE_TYPE (t);
282 TREE_ADDRESSABLE (t) = 1;
283 t = build1 (ADDR_EXPR, natural_type, t);
286 if (type && natural_type != type)
287 t = convert (type, t);
293 /* Build an ARRAY_REF with its natural type. */
296 gfc_build_array_ref (tree base, tree offset)
298 tree type = TREE_TYPE (base);
299 gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
300 type = TREE_TYPE (type);
303 TREE_ADDRESSABLE (base) = 1;
305 /* Strip NON_LVALUE_EXPR nodes. */
306 STRIP_TYPE_NOPS (offset);
308 return build4 (ARRAY_REF, type, base, offset, NULL_TREE, NULL_TREE);
312 /* Generate a runtime error if COND is true. */
315 gfc_trans_runtime_check (tree cond, const char * msgid, stmtblock_t * pblock,
325 if (integer_zerop (cond))
328 /* The code to generate the error. */
329 gfc_start_block (&block);
333 #ifdef USE_MAPPED_LOCATION
334 line = LOCATION_LINE (where->lb->location);
336 line = where->lb->linenum;
338 asprintf (&message, "%s (in file '%s', at line %d)", _(msgid),
339 where->lb->file->filename, line);
342 asprintf (&message, "%s (in file '%s', around line %d)", _(msgid),
343 gfc_source_file, input_line + 1);
345 arg = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const(message));
348 tmp = build_call_expr (gfor_fndecl_runtime_error, 1, arg);
349 gfc_add_expr_to_block (&block, tmp);
351 body = gfc_finish_block (&block);
353 if (integer_onep (cond))
355 gfc_add_expr_to_block (pblock, body);
359 /* Tell the compiler that this isn't likely. */
360 cond = fold_convert (long_integer_type_node, cond);
361 tmp = build_int_cst (long_integer_type_node, 0);
362 cond = build_call_expr (built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
363 cond = fold_convert (boolean_type_node, cond);
365 tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt ());
366 gfc_add_expr_to_block (pblock, tmp);
371 /* Add a statement to a block. */
374 gfc_add_expr_to_block (stmtblock_t * block, tree expr)
378 if (expr == NULL_TREE || IS_EMPTY_STMT (expr))
383 if (TREE_CODE (block->head) != STATEMENT_LIST)
388 block->head = NULL_TREE;
389 append_to_statement_list (tmp, &block->head);
391 append_to_statement_list (expr, &block->head);
394 /* Don't bother creating a list if we only have a single statement. */
399 /* Add a block the end of a block. */
402 gfc_add_block_to_block (stmtblock_t * block, stmtblock_t * append)
405 gcc_assert (!append->has_scope);
407 gfc_add_expr_to_block (block, append->head);
408 append->head = NULL_TREE;
412 /* Get the current locus. The structure may not be complete, and should
413 only be used with gfc_set_backend_locus. */
416 gfc_get_backend_locus (locus * loc)
418 loc->lb = gfc_getmem (sizeof (gfc_linebuf));
419 #ifdef USE_MAPPED_LOCATION
420 loc->lb->location = input_location;
422 loc->lb->linenum = input_line;
424 loc->lb->file = gfc_current_backend_file;
428 /* Set the current locus. */
431 gfc_set_backend_locus (locus * loc)
433 gfc_current_backend_file = loc->lb->file;
434 #ifdef USE_MAPPED_LOCATION
435 input_location = loc->lb->location;
437 input_line = loc->lb->linenum;
438 input_filename = loc->lb->file->filename;
443 /* Translate an executable statement. */
446 gfc_trans_code (gfc_code * code)
452 return build_empty_stmt ();
454 gfc_start_block (&block);
456 /* Translate statements one by one to GIMPLE trees until we reach
457 the end of this gfc_code branch. */
458 for (; code; code = code->next)
462 res = gfc_trans_label_here (code);
463 gfc_add_expr_to_block (&block, res);
473 res = gfc_trans_assign (code);
476 case EXEC_LABEL_ASSIGN:
477 res = gfc_trans_label_assign (code);
480 case EXEC_POINTER_ASSIGN:
481 res = gfc_trans_pointer_assign (code);
484 case EXEC_INIT_ASSIGN:
485 res = gfc_trans_init_assign (code);
493 res = gfc_trans_cycle (code);
497 res = gfc_trans_exit (code);
501 res = gfc_trans_goto (code);
505 res = gfc_trans_entry (code);
509 res = gfc_trans_pause (code);
513 res = gfc_trans_stop (code);
517 res = gfc_trans_call (code, false);
520 case EXEC_ASSIGN_CALL:
521 res = gfc_trans_call (code, true);
525 res = gfc_trans_return (code);
529 res = gfc_trans_if (code);
532 case EXEC_ARITHMETIC_IF:
533 res = gfc_trans_arithmetic_if (code);
537 res = gfc_trans_do (code);
541 res = gfc_trans_do_while (code);
545 res = gfc_trans_select (code);
549 res = gfc_trans_flush (code);
553 res = gfc_trans_forall (code);
557 res = gfc_trans_where (code);
561 res = gfc_trans_allocate (code);
564 case EXEC_DEALLOCATE:
565 res = gfc_trans_deallocate (code);
569 res = gfc_trans_open (code);
573 res = gfc_trans_close (code);
577 res = gfc_trans_read (code);
581 res = gfc_trans_write (code);
585 res = gfc_trans_iolength (code);
589 res = gfc_trans_backspace (code);
593 res = gfc_trans_endfile (code);
597 res = gfc_trans_inquire (code);
601 res = gfc_trans_rewind (code);
605 res = gfc_trans_transfer (code);
609 res = gfc_trans_dt_end (code);
612 case EXEC_OMP_ATOMIC:
613 case EXEC_OMP_BARRIER:
614 case EXEC_OMP_CRITICAL:
617 case EXEC_OMP_MASTER:
618 case EXEC_OMP_ORDERED:
619 case EXEC_OMP_PARALLEL:
620 case EXEC_OMP_PARALLEL_DO:
621 case EXEC_OMP_PARALLEL_SECTIONS:
622 case EXEC_OMP_PARALLEL_WORKSHARE:
623 case EXEC_OMP_SECTIONS:
624 case EXEC_OMP_SINGLE:
625 case EXEC_OMP_WORKSHARE:
626 res = gfc_trans_omp_directive (code);
630 internal_error ("gfc_trans_code(): Bad statement code");
633 gfc_set_backend_locus (&code->loc);
635 if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
637 if (TREE_CODE (res) == STATEMENT_LIST)
638 annotate_all_with_locus (&res, input_location);
640 SET_EXPR_LOCATION (res, input_location);
642 /* Add the new statement to the block. */
643 gfc_add_expr_to_block (&block, res);
647 /* Return the finished block. */
648 return gfc_finish_block (&block);
652 /* This function is called after a complete program unit has been parsed
656 gfc_generate_code (gfc_namespace * ns)
658 if (ns->is_block_data)
660 gfc_generate_block_data (ns);
664 gfc_generate_function_code (ns);
668 /* This function is called after a complete module has been parsed
672 gfc_generate_module_code (gfc_namespace * ns)
676 gfc_generate_module_vars (ns);
678 /* We need to generate all module function prototypes first, to allow
680 for (n = ns->contained; n; n = n->sibling)
685 gfc_create_function_decl (n);
688 for (n = ns->contained; n; n = n->sibling)
693 gfc_generate_function_code (n);