diff options
Diffstat (limited to 'gcc/fortran/trans.c')
| -rw-r--r-- | gcc/fortran/trans.c | 693 |
1 files changed, 693 insertions, 0 deletions
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c new file mode 100644 index 00000000000..00215f6a2a4 --- /dev/null +++ b/gcc/fortran/trans.c @@ -0,0 +1,693 @@ +/* Code translation -- generate GCC trees from gfc_code. + Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free +Software Foundation; either version 2, or (at your option) any later +version. + +GCC is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING. If not, write to the Free +Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "tree.h" +#include "tree-gimple.h" +#include <stdio.h> +#include "ggc.h" +#include "toplev.h" +#include "defaults.h" +#include "real.h" +#include <gmp.h> +#include <assert.h> +#include "gfortran.h" +#include "trans.h" +#include "trans-stmt.h" +#include "trans-array.h" +#include "trans-types.h" +#include "trans-const.h" + +/* Naming convention for backend interface code: + + gfc_trans_* translate gfc_code into STMT trees. + + gfc_conv_* expression conversion + + gfc_get_* get a backend tree representation of a decl or type */ + +static gfc_file *gfc_current_backend_file; + + +/* Advance along TREE_CHAIN n times. */ + +tree +gfc_advance_chain (tree t, int n) +{ + for (; n > 0; n--) + { + assert (t != NULL_TREE); + t = TREE_CHAIN (t); + } + return t; +} + + +/* Wrap a node in a TREE_LIST node and add it to the end of a list. */ + +tree +gfc_chainon_list (tree list, tree add) +{ + tree l; + + l = tree_cons (NULL_TREE, add, NULL_TREE); + + return chainon (list, l); +} + + +/* Strip off a legitimate source ending from the input + string NAME of length LEN. */ + +static inline void +remove_suffix (char *name, int len) +{ + int i; + + for (i = 2; i < 8 && len > i; i++) + { + if (name[len - i] == '.') + { + name[len - i] = '\0'; + break; + } + } +} + + +/* Creates a variable declaration with a given TYPE. */ + +tree +gfc_create_var_np (tree type, const char *prefix) +{ + return create_tmp_var_raw (type, prefix); +} + + +/* Like above, but also adds it to the current scope. */ + +tree +gfc_create_var (tree type, const char *prefix) +{ + tree tmp; + + tmp = gfc_create_var_np (type, prefix); + + pushdecl (tmp); + + return tmp; +} + + +/* If the an expression is not constant, evaluate it now. We assign the + result of the expression to an artificially created variable VAR, and + return a pointer to the VAR_DECL node for this variable. */ + +tree +gfc_evaluate_now (tree expr, stmtblock_t * pblock) +{ + tree var; + + if (TREE_CODE_CLASS (TREE_CODE (expr)) == 'c') + return expr; + + var = gfc_create_var (TREE_TYPE (expr), NULL); + gfc_add_modify_expr (pblock, var, expr); + + return var; +} + + +/* Build a MODIFY_EXPR node and add it to a given statement block PBLOCK. + A MODIFY_EXPR is an assignment: LHS <- RHS. */ + +void +gfc_add_modify_expr (stmtblock_t * pblock, tree lhs, tree rhs) +{ + tree tmp; + +#ifdef ENABLE_CHECKING + /* Make sure that the types of the rhs and the lhs are the same + for scalar assignments. We should probably have something + similar for aggregates, but right now removing that check just + breaks everything. */ + if (TREE_TYPE (rhs) != TREE_TYPE (lhs) + && !AGGREGATE_TYPE_P (TREE_TYPE (lhs))) + abort (); +#endif + + tmp = fold (build_v (MODIFY_EXPR, lhs, rhs)); + gfc_add_expr_to_block (pblock, tmp); +} + + +/* Create a new scope/binding level and initialize a block. Care must be + taken when translating expessions as any temporaries will be placed in + the innermost scope. */ + +void +gfc_start_block (stmtblock_t * block) +{ + /* Start a new binding level. */ + pushlevel (0); + block->has_scope = 1; + + /* The block is empty. */ + block->head = NULL_TREE; +} + + +/* Initialize a block without creating a new scope. */ + +void +gfc_init_block (stmtblock_t * block) +{ + block->head = NULL_TREE; + block->has_scope = 0; +} + + +/* Sometimes we create a scope but it turns out that we don't actually + need it. This function merges the scope of BLOCK with its parent. + Only variable decls will be merged, you still need to add the code. */ + +void +gfc_merge_block_scope (stmtblock_t * block) +{ + tree decl; + tree next; + + assert (block->has_scope); + block->has_scope = 0; + + /* Remember the decls in this scope. */ + decl = getdecls (); + poplevel (0, 0, 0); + + /* Add them to the parent scope. */ + while (decl != NULL_TREE) + { + next = TREE_CHAIN (decl); + TREE_CHAIN (decl) = NULL_TREE; + + pushdecl (decl); + decl = next; + } +} + + +/* Finish a scope containing a block of statements. */ + +tree +gfc_finish_block (stmtblock_t * stmtblock) +{ + tree decl; + tree expr; + tree block; + + expr = stmtblock->head; + if (!expr) + expr = build_empty_stmt (); + + stmtblock->head = NULL_TREE; + + if (stmtblock->has_scope) + { + decl = getdecls (); + + if (decl) + { + block = poplevel (1, 0, 0); + expr = build_v (BIND_EXPR, decl, expr, block); + } + else + poplevel (0, 0, 0); + } + + return expr; +} + + +/* Build an ADDR_EXPR and cast the result to TYPE. If TYPE is NULL, the + natural type is used. */ + +tree +gfc_build_addr_expr (tree type, tree t) +{ + tree base_type = TREE_TYPE (t); + tree natural_type; + + if (type && POINTER_TYPE_P (type) + && TREE_CODE (base_type) == ARRAY_TYPE + && TYPE_MAIN_VARIANT (TREE_TYPE (type)) + == TYPE_MAIN_VARIANT (TREE_TYPE (base_type))) + natural_type = type; + else + natural_type = build_pointer_type (base_type); + + if (TREE_CODE (t) == INDIRECT_REF) + { + if (!type) + type = natural_type; + t = TREE_OPERAND (t, 0); + natural_type = TREE_TYPE (t); + } + else + { + if (DECL_P (t)) + TREE_ADDRESSABLE (t) = 1; + t = build1 (ADDR_EXPR, natural_type, t); + } + + if (type && natural_type != type) + t = convert (type, t); + + return t; +} + + +/* Build an INDIRECT_REF with its natural type. */ + +tree +gfc_build_indirect_ref (tree t) +{ + tree type = TREE_TYPE (t); + if (!POINTER_TYPE_P (type)) + abort (); + type = TREE_TYPE (type); + + if (TREE_CODE (t) == ADDR_EXPR) + return TREE_OPERAND (t, 0); + else + return build1 (INDIRECT_REF, type, t); +} + + +/* Build an ARRAY_REF with its natural type. */ + +tree +gfc_build_array_ref (tree base, tree offset) +{ + tree type = TREE_TYPE (base); + if (TREE_CODE (type) != ARRAY_TYPE) + abort (); + type = TREE_TYPE (type); + + if (DECL_P (base)) + TREE_ADDRESSABLE (base) = 1; + + return build (ARRAY_REF, type, base, offset, NULL_TREE, NULL_TREE); +} + + +/* Given a funcion declaration FNDECL and an argument list ARGLIST, + build a CALL_EXPR. */ + +tree +gfc_build_function_call (tree fndecl, tree arglist) +{ + tree fn; + tree call; + + fn = gfc_build_addr_expr (NULL, fndecl); + call = build (CALL_EXPR, TREE_TYPE (TREE_TYPE (fndecl)), fn, arglist, NULL); + TREE_SIDE_EFFECTS (call) = 1; + + return call; +} + + +/* Generate a runtime error if COND is true. */ + +void +gfc_trans_runtime_check (tree cond, tree msg, stmtblock_t * pblock) +{ + stmtblock_t block; + tree body; + tree tmp; + tree args; + + cond = fold (cond); + + if (integer_zerop (cond)) + return; + + /* The code to generate the error. */ + gfc_start_block (&block); + + assert (TREE_CODE (msg) == STRING_CST); + + TREE_USED (msg) = 1; + + tmp = gfc_build_addr_expr (pchar_type_node, msg); + args = gfc_chainon_list (NULL_TREE, tmp); + + tmp = gfc_build_addr_expr (pchar_type_node, gfc_strconst_current_filename); + args = gfc_chainon_list (args, tmp); + + tmp = build_int_2 (input_line, 0); + args = gfc_chainon_list (args, tmp); + + tmp = gfc_build_function_call (gfor_fndecl_runtime_error, args); + gfc_add_expr_to_block (&block, tmp); + + body = gfc_finish_block (&block); + + if (integer_onep (cond)) + { + gfc_add_expr_to_block (pblock, body); + } + else + { + /* Tell the compiler that this isn't likely. */ + tmp = gfc_chainon_list (NULL_TREE, cond); + tmp = gfc_chainon_list (tmp, integer_zero_node); + cond = gfc_build_function_call (built_in_decls[BUILT_IN_EXPECT], tmp); + + tmp = build_v (COND_EXPR, cond, body, build_empty_stmt ()); + gfc_add_expr_to_block (pblock, tmp); + } +} + + +/* Add a statement to a block. */ + +void +gfc_add_expr_to_block (stmtblock_t * block, tree expr) +{ + assert (block); + + if (expr == NULL_TREE || IS_EMPTY_STMT (expr)) + return; + + if (TREE_CODE (expr) != STATEMENT_LIST) + expr = fold (expr); + + if (block->head) + { + if (TREE_CODE (block->head) != STATEMENT_LIST) + { + tree tmp; + + tmp = block->head; + block->head = NULL_TREE; + append_to_statement_list (tmp, &block->head); + } + append_to_statement_list (expr, &block->head); + } + else + /* Don't bother creating a list if we only have a single statement. */ + block->head = expr; +} + + +/* Add a block the end of a block. */ + +void +gfc_add_block_to_block (stmtblock_t * block, stmtblock_t * append) +{ + assert (append); + assert (!append->has_scope); + + gfc_add_expr_to_block (block, append->head); + append->head = NULL_TREE; +} + + +/* Get the current locus. The structure may not be complete, and should + only be used with gfc_set_backend_locus. */ + +void +gfc_get_backend_locus (locus * loc) +{ + loc->lb = gfc_getmem (sizeof (gfc_linebuf)); + loc->lb->linenum = input_line - 1; + loc->lb->file = gfc_current_backend_file; +} + + +/* Set the current locus. */ + +void +gfc_set_backend_locus (locus * loc) +{ + input_line = loc->lb->linenum; + gfc_current_backend_file = loc->lb->file; + input_filename = loc->lb->file->filename; +} + + +/* Translate an executable statement. */ + +tree +gfc_trans_code (gfc_code * code) +{ + stmtblock_t block; + tree res; + + if (!code) + return build_empty_stmt (); + + gfc_start_block (&block); + + /* Translate statements one by one to GIMPLE trees until we reach + the end of this gfc_code branch. */ + for (; code; code = code->next) + { + gfc_set_backend_locus (&code->loc); + + if (code->here != 0) + { + res = gfc_trans_label_here (code); + gfc_add_expr_to_block (&block, res); + } + + switch (code->op) + { + case EXEC_NOP: + res = NULL_TREE; + break; + + case EXEC_ASSIGN: + res = gfc_trans_assign (code); + break; + + case EXEC_LABEL_ASSIGN: + res = gfc_trans_label_assign (code); + break; + + case EXEC_POINTER_ASSIGN: + res = gfc_trans_pointer_assign (code); + break; + + case EXEC_CONTINUE: + res = NULL_TREE; + break; + + case EXEC_CYCLE: + res = gfc_trans_cycle (code); + break; + + case EXEC_EXIT: + res = gfc_trans_exit (code); + break; + + case EXEC_GOTO: + res = gfc_trans_goto (code); + break; + + case EXEC_PAUSE: + res = gfc_trans_pause (code); + break; + + case EXEC_STOP: + res = gfc_trans_stop (code); + break; + + case EXEC_CALL: + res = gfc_trans_call (code); + break; + + case EXEC_RETURN: + res = gfc_trans_return (code); + break; + + case EXEC_IF: + res = gfc_trans_if (code); + break; + + case EXEC_ARITHMETIC_IF: + res = gfc_trans_arithmetic_if (code); + break; + + case EXEC_DO: + res = gfc_trans_do (code); + break; + + case EXEC_DO_WHILE: + res = gfc_trans_do_while (code); + break; + + case EXEC_SELECT: + res = gfc_trans_select (code); + break; + + case EXEC_FORALL: + res = gfc_trans_forall (code); + break; + + case EXEC_WHERE: + res = gfc_trans_where (code); + break; + + case EXEC_ALLOCATE: + res = gfc_trans_allocate (code); + break; + + case EXEC_DEALLOCATE: + res = gfc_trans_deallocate (code); + break; + + case EXEC_OPEN: + res = gfc_trans_open (code); + break; + + case EXEC_CLOSE: + res = gfc_trans_close (code); + break; + + case EXEC_READ: + res = gfc_trans_read (code); + break; + + case EXEC_WRITE: + res = gfc_trans_write (code); + break; + + case EXEC_IOLENGTH: + res = gfc_trans_iolength (code); + break; + + case EXEC_BACKSPACE: + res = gfc_trans_backspace (code); + break; + + case EXEC_ENDFILE: + res = gfc_trans_endfile (code); + break; + + case EXEC_INQUIRE: + res = gfc_trans_inquire (code); + break; + + case EXEC_REWIND: + res = gfc_trans_rewind (code); + break; + + case EXEC_TRANSFER: + res = gfc_trans_transfer (code); + break; + + case EXEC_DT_END: + res = gfc_trans_dt_end (code); + break; + + default: + internal_error ("gfc_trans_code(): Bad statement code"); + } + + if (res != NULL_TREE && ! IS_EMPTY_STMT (res)) + { + if (TREE_CODE (res) == STATEMENT_LIST) + annotate_all_with_locus (&res, input_location); + else + annotate_with_locus (res, input_location); + + /* Add the new statemment to the block. */ + gfc_add_expr_to_block (&block, res); + } + } + + /* Return the finished block. */ + return gfc_finish_block (&block); +} + + +/* This function is called after a complete program unit has been parsed + and resolved. */ + +void +gfc_generate_code (gfc_namespace * ns) +{ + gfc_symbol *main_program = NULL; + symbol_attribute attr; + + /* Main program subroutine. */ + if (!ns->proc_name) + { + /* Lots of things get upset if a subroutine doesn't have a symbol, so we + make one now. Hopefully we've set all the required fields. */ + gfc_get_symbol ("MAIN__", ns, &main_program); + gfc_clear_attr (&attr); + attr.flavor = FL_PROCEDURE; + attr.proc = PROC_UNKNOWN; + attr.subroutine = 1; + attr.access = ACCESS_PUBLIC; + main_program->attr = attr; + ns->proc_name = main_program; + gfc_commit_symbols (); + } + + gfc_generate_function_code (ns); +} + + +/* This function is called after a complete module has been parsed + and resolved. */ + +void +gfc_generate_module_code (gfc_namespace * ns) +{ + gfc_namespace *n; + + gfc_generate_module_vars (ns); + + /* We need to generate all module function prototypes first, to allow + sibling calls. */ + for (n = ns->contained; n; n = n->sibling) + { + if (!n->proc_name) + continue; + + gfc_build_function_decl (n->proc_name); + } + + for (n = ns->contained; n; n = n->sibling) + { + if (!n->proc_name) + continue; + + gfc_generate_function_code (n); + } +} + |