1 /* Code translation -- generate GCC trees from gfc_code.
2 Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
3 Contributed by Paul Brook
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 2, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING. If not, write to the Free
19 Software Foundation, 59 Temple Place - Suite 330, Boston, MA
24 #include "coretypes.h"
26 #include "tree-gimple.h"
36 #include "trans-stmt.h"
37 #include "trans-array.h"
38 #include "trans-types.h"
39 #include "trans-const.h"
41 /* Naming convention for backend interface code:
43 gfc_trans_* translate gfc_code into STMT trees.
45 gfc_conv_* expression conversion
47 gfc_get_* get a backend tree representation of a decl or type */
49 static gfc_file *gfc_current_backend_file;
52 /* Advance along TREE_CHAIN n times. */
55 gfc_advance_chain (tree t, int n)
59 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)
103 return create_tmp_var_raw (type, prefix);
107 /* Like above, but also adds it to the current scope. */
110 gfc_create_var (tree type, const char *prefix)
114 tmp = gfc_create_var_np (type, prefix);
122 /* If the an expression is not constant, evaluate it now. We assign the
123 result of the expression to an artificially created variable VAR, and
124 return a pointer to the VAR_DECL node for this variable. */
127 gfc_evaluate_now (tree expr, stmtblock_t * pblock)
131 if (TREE_CODE_CLASS (TREE_CODE (expr)) == 'c')
134 var = gfc_create_var (TREE_TYPE (expr), NULL);
135 gfc_add_modify_expr (pblock, var, expr);
141 /* Build a MODIFY_EXPR node and add it to a given statement block PBLOCK.
142 A MODIFY_EXPR is an assignment: LHS <- RHS. */
145 gfc_add_modify_expr (stmtblock_t * pblock, tree lhs, tree rhs)
149 #ifdef ENABLE_CHECKING
150 /* Make sure that the types of the rhs and the lhs are the same
151 for scalar assignments. We should probably have something
152 similar for aggregates, but right now removing that check just
153 breaks everything. */
154 if (TREE_TYPE (rhs) != TREE_TYPE (lhs)
155 && !AGGREGATE_TYPE_P (TREE_TYPE (lhs)))
159 tmp = fold (build2_v (MODIFY_EXPR, lhs, rhs));
160 gfc_add_expr_to_block (pblock, tmp);
164 /* Create a new scope/binding level and initialize a block. Care must be
165 taken when translating expessions as any temporaries will be placed in
166 the innermost scope. */
169 gfc_start_block (stmtblock_t * block)
171 /* Start a new binding level. */
173 block->has_scope = 1;
175 /* The block is empty. */
176 block->head = NULL_TREE;
180 /* Initialize a block without creating a new scope. */
183 gfc_init_block (stmtblock_t * block)
185 block->head = NULL_TREE;
186 block->has_scope = 0;
190 /* Sometimes we create a scope but it turns out that we don't actually
191 need it. This function merges the scope of BLOCK with its parent.
192 Only variable decls will be merged, you still need to add the code. */
195 gfc_merge_block_scope (stmtblock_t * block)
200 assert (block->has_scope);
201 block->has_scope = 0;
203 /* Remember the decls in this scope. */
207 /* Add them to the parent scope. */
208 while (decl != NULL_TREE)
210 next = TREE_CHAIN (decl);
211 TREE_CHAIN (decl) = NULL_TREE;
219 /* Finish a scope containing a block of statements. */
222 gfc_finish_block (stmtblock_t * stmtblock)
228 expr = stmtblock->head;
230 expr = build_empty_stmt ();
232 stmtblock->head = NULL_TREE;
234 if (stmtblock->has_scope)
240 block = poplevel (1, 0, 0);
241 expr = build3_v (BIND_EXPR, decl, expr, block);
251 /* Build an ADDR_EXPR and cast the result to TYPE. If TYPE is NULL, the
252 natural type is used. */
255 gfc_build_addr_expr (tree type, tree t)
257 tree base_type = TREE_TYPE (t);
260 if (type && POINTER_TYPE_P (type)
261 && TREE_CODE (base_type) == ARRAY_TYPE
262 && TYPE_MAIN_VARIANT (TREE_TYPE (type))
263 == TYPE_MAIN_VARIANT (TREE_TYPE (base_type)))
266 natural_type = build_pointer_type (base_type);
268 if (TREE_CODE (t) == INDIRECT_REF)
272 t = TREE_OPERAND (t, 0);
273 natural_type = TREE_TYPE (t);
278 TREE_ADDRESSABLE (t) = 1;
279 t = build1 (ADDR_EXPR, natural_type, t);
282 if (type && natural_type != type)
283 t = convert (type, t);
289 /* Build an INDIRECT_REF with its natural type. */
292 gfc_build_indirect_ref (tree t)
294 tree type = TREE_TYPE (t);
295 if (!POINTER_TYPE_P (type))
297 type = TREE_TYPE (type);
299 if (TREE_CODE (t) == ADDR_EXPR)
300 return TREE_OPERAND (t, 0);
302 return build1 (INDIRECT_REF, type, t);
306 /* Build an ARRAY_REF with its natural type. */
309 gfc_build_array_ref (tree base, tree offset)
311 tree type = TREE_TYPE (base);
312 if (TREE_CODE (type) != ARRAY_TYPE)
314 type = TREE_TYPE (type);
317 TREE_ADDRESSABLE (base) = 1;
319 return build4 (ARRAY_REF, type, base, offset, NULL_TREE, NULL_TREE);
323 /* Given a funcion declaration FNDECL and an argument list ARGLIST,
324 build a CALL_EXPR. */
327 gfc_build_function_call (tree fndecl, tree arglist)
332 fn = gfc_build_addr_expr (NULL, fndecl);
333 call = build3 (CALL_EXPR, TREE_TYPE (TREE_TYPE (fndecl)),
335 TREE_SIDE_EFFECTS (call) = 1;
341 /* Generate a runtime error if COND is true. */
344 gfc_trans_runtime_check (tree cond, tree msg, stmtblock_t * pblock)
353 if (integer_zerop (cond))
356 /* The code to generate the error. */
357 gfc_start_block (&block);
359 assert (TREE_CODE (msg) == STRING_CST);
363 tmp = gfc_build_addr_expr (pchar_type_node, msg);
364 args = gfc_chainon_list (NULL_TREE, tmp);
366 tmp = gfc_build_addr_expr (pchar_type_node, gfc_strconst_current_filename);
367 args = gfc_chainon_list (args, tmp);
369 tmp = build_int_cst (NULL_TREE, input_line);
370 args = gfc_chainon_list (args, tmp);
372 tmp = gfc_build_function_call (gfor_fndecl_runtime_error, args);
373 gfc_add_expr_to_block (&block, tmp);
375 body = gfc_finish_block (&block);
377 if (integer_onep (cond))
379 gfc_add_expr_to_block (pblock, body);
383 /* Tell the compiler that this isn't likely. */
384 tmp = gfc_chainon_list (NULL_TREE, cond);
385 tmp = gfc_chainon_list (tmp, integer_zero_node);
386 cond = gfc_build_function_call (built_in_decls[BUILT_IN_EXPECT], tmp);
388 tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt ());
389 gfc_add_expr_to_block (pblock, tmp);
394 /* Add a statement to a block. */
397 gfc_add_expr_to_block (stmtblock_t * block, tree expr)
401 if (expr == NULL_TREE || IS_EMPTY_STMT (expr))
404 if (TREE_CODE (expr) != STATEMENT_LIST)
409 if (TREE_CODE (block->head) != STATEMENT_LIST)
414 block->head = NULL_TREE;
415 append_to_statement_list (tmp, &block->head);
417 append_to_statement_list (expr, &block->head);
420 /* Don't bother creating a list if we only have a single statement. */
425 /* Add a block the end of a block. */
428 gfc_add_block_to_block (stmtblock_t * block, stmtblock_t * append)
431 assert (!append->has_scope);
433 gfc_add_expr_to_block (block, append->head);
434 append->head = NULL_TREE;
438 /* Get the current locus. The structure may not be complete, and should
439 only be used with gfc_set_backend_locus. */
442 gfc_get_backend_locus (locus * loc)
444 loc->lb = gfc_getmem (sizeof (gfc_linebuf));
445 loc->lb->linenum = input_line - 1;
446 loc->lb->file = gfc_current_backend_file;
450 /* Set the current locus. */
453 gfc_set_backend_locus (locus * loc)
455 input_line = loc->lb->linenum;
456 gfc_current_backend_file = loc->lb->file;
457 input_filename = loc->lb->file->filename;
461 /* Translate an executable statement. */
464 gfc_trans_code (gfc_code * code)
470 return build_empty_stmt ();
472 gfc_start_block (&block);
474 /* Translate statements one by one to GIMPLE trees until we reach
475 the end of this gfc_code branch. */
476 for (; code; code = code->next)
478 gfc_set_backend_locus (&code->loc);
482 res = gfc_trans_label_here (code);
483 gfc_add_expr_to_block (&block, res);
493 res = gfc_trans_assign (code);
496 case EXEC_LABEL_ASSIGN:
497 res = gfc_trans_label_assign (code);
500 case EXEC_POINTER_ASSIGN:
501 res = gfc_trans_pointer_assign (code);
509 res = gfc_trans_cycle (code);
513 res = gfc_trans_exit (code);
517 res = gfc_trans_goto (code);
521 res = gfc_trans_entry (code);
525 res = gfc_trans_pause (code);
529 res = gfc_trans_stop (code);
533 res = gfc_trans_call (code);
537 res = gfc_trans_return (code);
541 res = gfc_trans_if (code);
544 case EXEC_ARITHMETIC_IF:
545 res = gfc_trans_arithmetic_if (code);
549 res = gfc_trans_do (code);
553 res = gfc_trans_do_while (code);
557 res = gfc_trans_select (code);
561 res = gfc_trans_forall (code);
565 res = gfc_trans_where (code);
569 res = gfc_trans_allocate (code);
572 case EXEC_DEALLOCATE:
573 res = gfc_trans_deallocate (code);
577 res = gfc_trans_open (code);
581 res = gfc_trans_close (code);
585 res = gfc_trans_read (code);
589 res = gfc_trans_write (code);
593 res = gfc_trans_iolength (code);
597 res = gfc_trans_backspace (code);
601 res = gfc_trans_endfile (code);
605 res = gfc_trans_inquire (code);
609 res = gfc_trans_rewind (code);
613 res = gfc_trans_transfer (code);
617 res = gfc_trans_dt_end (code);
621 internal_error ("gfc_trans_code(): Bad statement code");
624 if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
626 if (TREE_CODE (res) == STATEMENT_LIST)
627 annotate_all_with_locus (&res, input_location);
629 annotate_with_locus (res, input_location);
631 /* Add the new statemment to the block. */
632 gfc_add_expr_to_block (&block, res);
636 /* Return the finished block. */
637 return gfc_finish_block (&block);
641 /* This function is called after a complete program unit has been parsed
645 gfc_generate_code (gfc_namespace * ns)
647 gfc_symbol *main_program = NULL;
648 symbol_attribute attr;
650 if (ns->is_block_data)
652 gfc_generate_block_data (ns);
656 /* Main program subroutine. */
659 /* Lots of things get upset if a subroutine doesn't have a symbol, so we
660 make one now. Hopefully we've set all the required fields. */
661 gfc_get_symbol ("MAIN__", ns, &main_program);
662 gfc_clear_attr (&attr);
663 attr.flavor = FL_PROCEDURE;
664 attr.proc = PROC_UNKNOWN;
666 attr.access = ACCESS_PUBLIC;
667 main_program->attr = attr;
668 ns->proc_name = main_program;
669 gfc_commit_symbols ();
672 gfc_generate_function_code (ns);
676 /* This function is called after a complete module has been parsed
680 gfc_generate_module_code (gfc_namespace * ns)
684 gfc_generate_module_vars (ns);
686 /* We need to generate all module function prototypes first, to allow
688 for (n = ns->contained; n; n = n->sibling)
693 gfc_create_function_decl (n);
696 for (n = ns->contained; n; n = n->sibling)
701 gfc_generate_function_code (n);