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 tmp = fold (build_v (MODIFY_EXPR, lhs, rhs));
150 gfc_add_expr_to_block (pblock, tmp);
154 /* Create a new scope/binding level and initialize a block. Care must be
155 taken when translating expessions as any temporaries will be placed in
156 the innermost scope. */
159 gfc_start_block (stmtblock_t * block)
161 /* Start a new binding level. */
163 block->has_scope = 1;
165 /* The block is empty. */
166 block->head = NULL_TREE;
170 /* Initialize a block without creating a new scope. */
173 gfc_init_block (stmtblock_t * block)
175 block->head = NULL_TREE;
176 block->has_scope = 0;
180 /* Sometimes we create a scope but it turns out that we don't actually
181 need it. This function merges the scope of BLOCK with its parent.
182 Only variable decls will be merged, you still need to add the code. */
185 gfc_merge_block_scope (stmtblock_t * block)
190 assert (block->has_scope);
191 block->has_scope = 0;
193 /* Remember the decls in this scope. */
197 /* Add them to the parent scope. */
198 while (decl != NULL_TREE)
200 next = TREE_CHAIN (decl);
201 TREE_CHAIN (decl) = NULL_TREE;
209 /* Finish a scope containing a block of statements. */
212 gfc_finish_block (stmtblock_t * stmtblock)
218 expr = rationalize_compound_expr (stmtblock->head);
219 stmtblock->head = NULL_TREE;
221 if (stmtblock->has_scope)
227 block = poplevel (1, 0, 0);
228 expr = build_v (BIND_EXPR, decl, expr, block);
238 /* Build an ADDR_EXPR and cast the result to TYPE. If TYPE is NULL, the
239 natural type is used. */
242 gfc_build_addr_expr (tree type, tree t)
244 tree base_type = TREE_TYPE (t);
247 if (type && POINTER_TYPE_P (type)
248 && TREE_CODE (base_type) == ARRAY_TYPE
249 && TYPE_MAIN_VARIANT (TREE_TYPE (type))
250 == TYPE_MAIN_VARIANT (TREE_TYPE (base_type)))
253 natural_type = build_pointer_type (base_type);
255 if (TREE_CODE (t) == INDIRECT_REF)
259 t = TREE_OPERAND (t, 0);
260 natural_type = TREE_TYPE (t);
265 TREE_ADDRESSABLE (t) = 1;
266 t = build1 (ADDR_EXPR, natural_type, t);
269 if (type && natural_type != type)
270 t = convert (type, t);
276 /* Build an INDIRECT_REF with its natural type. */
279 gfc_build_indirect_ref (tree t)
281 tree type = TREE_TYPE (t);
282 if (!POINTER_TYPE_P (type))
284 type = TREE_TYPE (type);
286 if (TREE_CODE (t) == ADDR_EXPR)
287 return TREE_OPERAND (t, 0);
289 return build1 (INDIRECT_REF, 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 if (TREE_CODE (type) != ARRAY_TYPE)
301 type = TREE_TYPE (type);
304 TREE_ADDRESSABLE (base) = 1;
306 return build (ARRAY_REF, type, base, offset);
310 /* Given a funcion declaration FNDECL and an argument list ARGLIST,
311 build a CALL_EXPR. */
314 gfc_build_function_call (tree fndecl, tree arglist)
319 fn = gfc_build_addr_expr (NULL, fndecl);
320 call = build (CALL_EXPR, TREE_TYPE (TREE_TYPE (fndecl)), fn, arglist, NULL);
321 TREE_SIDE_EFFECTS (call) = 1;
327 /* Generate a runtime error if COND is true. */
330 gfc_trans_runtime_check (tree cond, tree msg, stmtblock_t * pblock)
339 if (integer_zerop (cond))
342 /* The code to generate the error. */
343 gfc_start_block (&block);
345 assert (TREE_CODE (msg) == STRING_CST);
349 tmp = gfc_build_addr_expr (pchar_type_node, msg);
350 args = gfc_chainon_list (NULL_TREE, tmp);
352 tmp = gfc_build_addr_expr (pchar_type_node, gfc_strconst_current_filename);
353 args = gfc_chainon_list (args, tmp);
355 tmp = build_int_2 (input_line, 0);
356 args = gfc_chainon_list (args, tmp);
358 tmp = gfc_build_function_call (gfor_fndecl_runtime_error, args);
359 gfc_add_expr_to_block (&block, tmp);
361 body = gfc_finish_block (&block);
363 if (integer_onep (cond))
365 gfc_add_expr_to_block (pblock, body);
369 /* Tell the compiler that this isn't likley. */
370 tmp = gfc_chainon_list (NULL_TREE, cond);
371 tmp = gfc_chainon_list (tmp, integer_zero_node);
372 cond = gfc_build_function_call (built_in_decls[BUILT_IN_EXPECT], tmp);
374 tmp = build_v (COND_EXPR, cond, body, build_empty_stmt ());
375 gfc_add_expr_to_block (pblock, tmp);
380 /* Add a statement to a bock. */
383 gfc_add_expr_to_block (stmtblock_t * block, tree expr)
387 if (expr == NULL_TREE || IS_EMPTY_STMT (expr))
392 block->head = build_v (COMPOUND_EXPR, block->head, expr);
398 /* Add a block the end of a block. */
401 gfc_add_block_to_block (stmtblock_t * block, stmtblock_t * append)
404 assert (!append->has_scope);
406 gfc_add_expr_to_block (block, append->head);
407 append->head = NULL_TREE;
411 /* Get the current locus. The structure may not be complete, and should
412 only be used with gfc_set_current_locus. */
415 gfc_get_backend_locus (locus * loc)
417 loc->lb = gfc_getmem (sizeof (gfc_linebuf));
418 loc->lb->linenum = input_line - 1;
419 loc->lb->file = gfc_current_backend_file;
423 /* Set the current locus. */
426 gfc_set_backend_locus (locus * loc)
428 input_line = loc->lb->linenum;
429 gfc_current_backend_file = loc->lb->file;
430 input_filename = loc->lb->file->filename;
434 /* Translate an executable statement. */
437 gfc_trans_code (gfc_code * code)
443 return build_empty_stmt ();
445 gfc_start_block (&block);
447 /* Translate statements one by one to GIMPLE trees until we reach
448 the end of this gfc_code branch. */
449 for (; code; code = code->next)
451 gfc_set_backend_locus (&code->loc);
455 res = gfc_trans_label_here (code);
456 gfc_add_expr_to_block (&block, res);
466 res = gfc_trans_assign (code);
469 case EXEC_LABEL_ASSIGN:
470 res = gfc_trans_label_assign (code);
473 case EXEC_POINTER_ASSIGN:
474 res = gfc_trans_pointer_assign (code);
482 res = gfc_trans_cycle (code);
486 res = gfc_trans_exit (code);
490 res = gfc_trans_goto (code);
494 res = gfc_trans_pause (code);
498 res = gfc_trans_stop (code);
502 res = gfc_trans_call (code);
506 res = gfc_trans_return (code);
510 res = gfc_trans_if (code);
513 case EXEC_ARITHMETIC_IF:
514 res = gfc_trans_arithmetic_if (code);
518 res = gfc_trans_do (code);
522 res = gfc_trans_do_while (code);
526 res = gfc_trans_select (code);
530 res = gfc_trans_forall (code);
534 res = gfc_trans_where (code);
538 res = gfc_trans_allocate (code);
541 case EXEC_DEALLOCATE:
542 res = gfc_trans_deallocate (code);
546 res = gfc_trans_open (code);
550 res = gfc_trans_close (code);
554 res = gfc_trans_read (code);
558 res = gfc_trans_write (code);
562 res = gfc_trans_iolength (code);
566 res = gfc_trans_backspace (code);
570 res = gfc_trans_endfile (code);
574 res = gfc_trans_inquire (code);
578 res = gfc_trans_rewind (code);
582 res = gfc_trans_transfer (code);
586 res = gfc_trans_dt_end (code);
590 internal_error ("gfc_trans_code(): Bad statement code");
593 if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
595 annotate_with_locus (res, input_location);
596 /* Add the new statemment to the block. */
597 gfc_add_expr_to_block (&block, res);
601 /* Return the finished block. */
602 return gfc_finish_block (&block);
606 /* This function is called after a complete program unit has been parsed
610 gfc_generate_code (gfc_namespace * ns)
612 gfc_symbol *main_program = NULL;
613 symbol_attribute attr;
615 /* Main program subroutine. */
618 /* Lots of things get upset if a subroutine doesn't have a symbol, so we
619 make one now. Hopefully we've set all the required fields. */
620 gfc_get_symbol ("MAIN__", ns, &main_program);
621 gfc_clear_attr (&attr);
622 attr.flavor = FL_PROCEDURE;
623 attr.proc = PROC_UNKNOWN;
625 attr.access = ACCESS_PUBLIC;
626 main_program->attr = attr;
627 ns->proc_name = main_program;
628 gfc_commit_symbols ();
631 gfc_generate_function_code (ns);
635 /* This function is called after a complete module has been parsed
639 gfc_generate_module_code (gfc_namespace * ns)
643 gfc_generate_module_vars (ns);
645 /* We need to generate all module function prototypes first, to allow
647 for (n = ns->contained; n; n = n->sibling)
652 gfc_build_function_decl (n->proc_name);
655 for (n = ns->contained; n; n = n->sibling)
660 gfc_generate_function_code (n);