| /* gfortran backend interface |
| Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 |
| 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, 51 Franklin Street, Fifth Floor, Boston, MA |
| 02110-1301, USA. */ |
| |
| /* f95-lang.c-- GCC backend interface stuff */ |
| |
| /* declare required prototypes: */ |
| |
| #include "config.h" |
| #include "system.h" |
| #include "ansidecl.h" |
| #include "system.h" |
| #include "coretypes.h" |
| #include "tree.h" |
| #include "tree-gimple.h" |
| #include "flags.h" |
| #include "langhooks.h" |
| #include "langhooks-def.h" |
| #include "timevar.h" |
| #include "tm.h" |
| #include "function.h" |
| #include "ggc.h" |
| #include "toplev.h" |
| #include "target.h" |
| #include "debug.h" |
| #include "diagnostic.h" |
| #include "tree-dump.h" |
| #include "cgraph.h" |
| |
| #include "gfortran.h" |
| #include "trans.h" |
| #include "trans-types.h" |
| #include "trans-const.h" |
| |
| /* Language-dependent contents of an identifier. */ |
| |
| struct lang_identifier |
| GTY(()) |
| { |
| struct tree_identifier common; |
| }; |
| |
| /* The resulting tree type. */ |
| |
| union lang_tree_node |
| GTY((desc ("TREE_CODE (&%h.generic) == IDENTIFIER_NODE"), |
| chain_next ("(union lang_tree_node *)TREE_CHAIN (&%h.generic)"))) |
| { |
| union tree_node GTY((tag ("0"), |
| desc ("tree_node_structure (&%h)"))) generic; |
| struct lang_identifier GTY((tag ("1"))) identifier; |
| }; |
| |
| /* Save and restore the variables in this file and elsewhere |
| that keep track of the progress of compilation of the current function. |
| Used for nested functions. */ |
| |
| struct language_function |
| GTY(()) |
| { |
| /* struct gfc_language_function base; */ |
| struct binding_level *binding_level; |
| }; |
| |
| /* We don't have a lex/yacc lexer/parser, but toplev expects these to |
| exist anyway. */ |
| void yyerror (const char *str); |
| int yylex (void); |
| |
| static void gfc_init_decl_processing (void); |
| static void gfc_init_builtin_functions (void); |
| |
| /* Each front end provides its own. */ |
| static bool gfc_init (void); |
| static void gfc_finish (void); |
| static void gfc_print_identifier (FILE *, tree, int); |
| static bool gfc_mark_addressable (tree); |
| void do_function_end (void); |
| int global_bindings_p (void); |
| void insert_block (tree); |
| static void gfc_clear_binding_stack (void); |
| static void gfc_be_parse_file (int); |
| static void gfc_expand_function (tree); |
| static HOST_WIDE_INT gfc_get_alias_set (tree); |
| |
| #undef LANG_HOOKS_NAME |
| #undef LANG_HOOKS_INIT |
| #undef LANG_HOOKS_FINISH |
| #undef LANG_HOOKS_INIT_OPTIONS |
| #undef LANG_HOOKS_HANDLE_OPTION |
| #undef LANG_HOOKS_POST_OPTIONS |
| #undef LANG_HOOKS_PRINT_IDENTIFIER |
| #undef LANG_HOOKS_PARSE_FILE |
| #undef LANG_HOOKS_MARK_ADDRESSABLE |
| #undef LANG_HOOKS_TYPE_FOR_MODE |
| #undef LANG_HOOKS_TYPE_FOR_SIZE |
| #undef LANG_HOOKS_UNSIGNED_TYPE |
| #undef LANG_HOOKS_SIGNED_TYPE |
| #undef LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE |
| #undef LANG_HOOKS_CALLGRAPH_EXPAND_FUNCTION |
| #undef LANG_HOOKS_CLEAR_BINDING_STACK |
| #undef LANG_HOOKS_GET_ALIAS_SET |
| #undef LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE |
| #undef LANG_HOOKS_OMP_PREDETERMINED_SHARING |
| #undef LANG_HOOKS_OMP_CLAUSE_DEFAULT_CTOR |
| #undef LANG_HOOKS_OMP_DISREGARD_VALUE_EXPR |
| #undef LANG_HOOKS_OMP_PRIVATE_DEBUG_CLAUSE |
| #undef LANG_HOOKS_OMP_FIRSTPRIVATIZE_TYPE_SIZES |
| |
| /* Define lang hooks. */ |
| #define LANG_HOOKS_NAME "GNU F95" |
| #define LANG_HOOKS_INIT gfc_init |
| #define LANG_HOOKS_FINISH gfc_finish |
| #define LANG_HOOKS_INIT_OPTIONS gfc_init_options |
| #define LANG_HOOKS_HANDLE_OPTION gfc_handle_option |
| #define LANG_HOOKS_POST_OPTIONS gfc_post_options |
| #define LANG_HOOKS_PRINT_IDENTIFIER gfc_print_identifier |
| #define LANG_HOOKS_PARSE_FILE gfc_be_parse_file |
| #define LANG_HOOKS_MARK_ADDRESSABLE gfc_mark_addressable |
| #define LANG_HOOKS_TYPE_FOR_MODE gfc_type_for_mode |
| #define LANG_HOOKS_TYPE_FOR_SIZE gfc_type_for_size |
| #define LANG_HOOKS_UNSIGNED_TYPE gfc_unsigned_type |
| #define LANG_HOOKS_SIGNED_TYPE gfc_signed_type |
| #define LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE gfc_signed_or_unsigned_type |
| #define LANG_HOOKS_CALLGRAPH_EXPAND_FUNCTION gfc_expand_function |
| #define LANG_HOOKS_CLEAR_BINDING_STACK gfc_clear_binding_stack |
| #define LANG_HOOKS_GET_ALIAS_SET gfc_get_alias_set |
| #define LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE gfc_omp_privatize_by_reference |
| #define LANG_HOOKS_OMP_PREDETERMINED_SHARING gfc_omp_predetermined_sharing |
| #define LANG_HOOKS_OMP_CLAUSE_DEFAULT_CTOR gfc_omp_clause_default_ctor |
| #define LANG_HOOKS_OMP_DISREGARD_VALUE_EXPR gfc_omp_disregard_value_expr |
| #define LANG_HOOKS_OMP_PRIVATE_DEBUG_CLAUSE gfc_omp_private_debug_clause |
| #define LANG_HOOKS_OMP_FIRSTPRIVATIZE_TYPE_SIZES \ |
| gfc_omp_firstprivatize_type_sizes |
| |
| const struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER; |
| |
| /* APPLE LOCAL begin constant cfstrings */ |
| enum { blabla } c_language; |
| const char *constant_string_class_name = "die die"; |
| /* APPLE LOCAL end constant cfstrings */ |
| |
| /* APPLE LOCAL disable_typechecking_for_spec_flag */ |
| int disable_typechecking_for_spec_flag = 0; |
| |
| /* APPLE LOCAL begin CW asm blocks */ |
| /* Dummies needed because we use them from cpplib, yuck. */ |
| void build_modify_expr (void); |
| void iasm_addr (void); |
| void iasm_build_bracket (void); |
| void build_function_call (void); |
| void iasm_get_register_var (void); |
| bool iasm_is_pseudo (void); |
| void iasm_for_constraint (void); |
| void iasm_print_operand (void); |
| void iasm_force_constraint (void); |
| void pointer_int_sum (void); |
| void decl_constant_value (void); |
| void lookup_name (void); |
| void build_modify_expr (void) { abort (); } |
| void iasm_addr (void) { abort (); } |
| void iasm_build_bracket (void) { abort (); } |
| void build_function_call (void) { abort (); } |
| void iasm_get_register_var (void) { abort (); } |
| bool iasm_is_pseudo (void) { abort (); } |
| void iasm_for_constraint (void) { abort (); } |
| void iasm_print_operand (void) { abort (); } |
| void iasm_force_constraint (void) { abort (); } |
| void pointer_int_sum (void) { abort (); } |
| void decl_constant_value (void) { abort (); } |
| void lookup_name (void) { abort (); } |
| /* APPLE LOCAL end CW asm blocks */ |
| |
| /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function |
| that have names. Here so we can clear out their names' definitions |
| at the end of the function. */ |
| |
| /* Tree code classes. */ |
| |
| #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE, |
| |
| const enum tree_code_class tree_code_type[] = { |
| #include "tree.def" |
| }; |
| #undef DEFTREECODE |
| |
| /* Table indexed by tree code giving number of expression |
| operands beyond the fixed part of the node structure. |
| Not used for types or decls. */ |
| |
| #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) LENGTH, |
| |
| const unsigned char tree_code_length[] = { |
| #include "tree.def" |
| }; |
| #undef DEFTREECODE |
| |
| /* Names of tree components. |
| Used for printing out the tree and error messages. */ |
| #define DEFTREECODE(SYM, NAME, TYPE, LEN) NAME, |
| |
| const char *const tree_code_name[] = { |
| #include "tree.def" |
| }; |
| #undef DEFTREECODE |
| |
| |
| #define NULL_BINDING_LEVEL (struct binding_level *) NULL |
| |
| /* A chain of binding_level structures awaiting reuse. */ |
| |
| static GTY(()) struct binding_level *free_binding_level; |
| |
| /* The elements of `ridpointers' are identifier nodes |
| for the reserved type names and storage classes. |
| It is indexed by a RID_... value. */ |
| tree *ridpointers = NULL; |
| |
| /* language-specific flags. */ |
| |
| static void |
| gfc_expand_function (tree fndecl) |
| { |
| tree t; |
| |
| if (DECL_INITIAL (fndecl) |
| && BLOCK_SUBBLOCKS (DECL_INITIAL (fndecl))) |
| { |
| /* Local static equivalenced variables are never seen by |
| check_global_declarations, so we need to output debug |
| info by hand. */ |
| |
| t = BLOCK_SUBBLOCKS (DECL_INITIAL (fndecl)); |
| for (t = BLOCK_VARS (t); t; t = TREE_CHAIN (t)) |
| if (TREE_CODE (t) == VAR_DECL && DECL_HAS_VALUE_EXPR_P (t) |
| && TREE_STATIC (t)) |
| { |
| tree expr = DECL_VALUE_EXPR (t); |
| |
| if (TREE_CODE (expr) == COMPONENT_REF |
| && TREE_CODE (TREE_OPERAND (expr, 0)) == VAR_DECL |
| && TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) |
| == UNION_TYPE |
| && cgraph_varpool_node (TREE_OPERAND (expr, 0))->needed |
| && errorcount == 0 && sorrycount == 0) |
| { |
| timevar_push (TV_SYMOUT); |
| (*debug_hooks->global_decl) (t); |
| timevar_pop (TV_SYMOUT); |
| } |
| } |
| } |
| |
| tree_rest_of_compilation (fndecl); |
| } |
| |
| |
| /* Prepare expr to be an argument of a TRUTH_NOT_EXPR, |
| or validate its data type for an `if' or `while' statement or ?..: exp. |
| |
| This preparation consists of taking the ordinary |
| representation of an expression expr and producing a valid tree |
| boolean expression describing whether expr is nonzero. We could |
| simply always do build_binary_op (NE_EXPR, expr, boolean_false_node, 1), |
| but we optimize comparisons, &&, ||, and !. |
| |
| The resulting type should always be `boolean_type_node'. |
| This is much simpler than the corresponding C version because we have a |
| distinct boolean type. */ |
| |
| tree |
| gfc_truthvalue_conversion (tree expr) |
| { |
| switch (TREE_CODE (TREE_TYPE (expr))) |
| { |
| case BOOLEAN_TYPE: |
| if (TREE_TYPE (expr) == boolean_type_node) |
| return expr; |
| else if (COMPARISON_CLASS_P (expr)) |
| { |
| TREE_TYPE (expr) = boolean_type_node; |
| return expr; |
| } |
| else if (TREE_CODE (expr) == NOP_EXPR) |
| return build1 (NOP_EXPR, boolean_type_node, |
| TREE_OPERAND (expr, 0)); |
| else |
| return build1 (NOP_EXPR, boolean_type_node, expr); |
| |
| case INTEGER_TYPE: |
| if (TREE_CODE (expr) == INTEGER_CST) |
| return integer_zerop (expr) ? boolean_false_node : boolean_true_node; |
| else |
| return build2 (NE_EXPR, boolean_type_node, expr, |
| build_int_cst (TREE_TYPE (expr), 0)); |
| |
| default: |
| internal_error ("Unexpected type in truthvalue_conversion"); |
| } |
| } |
| |
| static void |
| gfc_create_decls (void) |
| { |
| /* GCC builtins. */ |
| gfc_init_builtin_functions (); |
| |
| /* Runtime/IO library functions. */ |
| gfc_build_builtin_function_decls (); |
| |
| gfc_init_constants (); |
| } |
| |
| static void |
| gfc_be_parse_file (int set_yydebug ATTRIBUTE_UNUSED) |
| { |
| int errors; |
| int warnings; |
| |
| gfc_create_decls (); |
| gfc_parse_file (); |
| gfc_generate_constructors (); |
| |
| cgraph_finalize_compilation_unit (); |
| cgraph_optimize (); |
| |
| /* Tell the frontent about any errors. */ |
| gfc_get_errors (&warnings, &errors); |
| errorcount += errors; |
| warningcount += warnings; |
| } |
| |
| /* Initialize everything. */ |
| |
| static bool |
| gfc_init (void) |
| { |
| #ifdef USE_MAPPED_LOCATION |
| linemap_add (&line_table, LC_ENTER, false, gfc_source_file, 1); |
| linemap_add (&line_table, LC_RENAME, false, "<built-in>", 0); |
| #endif |
| |
| /* First initialize the backend. */ |
| gfc_init_decl_processing (); |
| gfc_static_ctors = NULL_TREE; |
| |
| /* Then the frontend. */ |
| gfc_init_1 (); |
| |
| if (gfc_new_file () != SUCCESS) |
| fatal_error ("can't open input file: %s", gfc_source_file); |
| return true; |
| } |
| |
| |
| static void |
| gfc_finish (void) |
| { |
| gfc_done_1 (); |
| gfc_release_include_path (); |
| return; |
| } |
| |
| static void |
| gfc_print_identifier (FILE * file ATTRIBUTE_UNUSED, |
| tree node ATTRIBUTE_UNUSED, |
| int indent ATTRIBUTE_UNUSED) |
| { |
| return; |
| } |
| |
| |
| /* These functions and variables deal with binding contours. We only |
| need these functions for the list of PARM_DECLs, but we leave the |
| functions more general; these are a simplified version of the |
| functions from GNAT. */ |
| |
| /* For each binding contour we allocate a binding_level structure which records |
| the entities defined or declared in that contour. Contours include: |
| |
| the global one |
| one for each subprogram definition |
| one for each compound statement (declare block) |
| |
| Binding contours are used to create GCC tree BLOCK nodes. */ |
| |
| struct binding_level |
| GTY(()) |
| { |
| /* A chain of ..._DECL nodes for all variables, constants, functions, |
| parameters and type declarations. These ..._DECL nodes are chained |
| through the TREE_CHAIN field. Note that these ..._DECL nodes are stored |
| in the reverse of the order supplied to be compatible with the |
| back-end. */ |
| tree names; |
| /* For each level (except the global one), a chain of BLOCK nodes for all |
| the levels that were entered and exited one level down from this one. */ |
| tree blocks; |
| /* The binding level containing this one (the enclosing binding level). */ |
| struct binding_level *level_chain; |
| }; |
| |
| /* The binding level currently in effect. */ |
| static GTY(()) struct binding_level *current_binding_level = NULL; |
| |
| /* The outermost binding level. This binding level is created when the |
| compiler is started and it will exist through the entire compilation. */ |
| static GTY(()) struct binding_level *global_binding_level; |
| |
| /* Binding level structures are initialized by copying this one. */ |
| static struct binding_level clear_binding_level = { NULL, NULL, NULL }; |
| |
| /* Return nonzero if we are currently in the global binding level. */ |
| |
| int |
| global_bindings_p (void) |
| { |
| return current_binding_level == global_binding_level ? -1 : 0; |
| } |
| |
| tree |
| getdecls (void) |
| { |
| return current_binding_level->names; |
| } |
| |
| /* Enter a new binding level. The input parameter is ignored, but has to be |
| specified for back-end compatibility. */ |
| |
| void |
| pushlevel (int ignore ATTRIBUTE_UNUSED) |
| { |
| struct binding_level *newlevel |
| = (struct binding_level *) ggc_alloc (sizeof (struct binding_level)); |
| |
| *newlevel = clear_binding_level; |
| |
| /* Add this level to the front of the chain (stack) of levels that are |
| active. */ |
| newlevel->level_chain = current_binding_level; |
| current_binding_level = newlevel; |
| } |
| |
| /* Exit a binding level. |
| Pop the level off, and restore the state of the identifier-decl mappings |
| that were in effect when this level was entered. |
| |
| If KEEP is nonzero, this level had explicit declarations, so |
| and create a "block" (a BLOCK node) for the level |
| to record its declarations and subblocks for symbol table output. |
| |
| If FUNCTIONBODY is nonzero, this level is the body of a function, |
| so create a block as if KEEP were set and also clear out all |
| label names. |
| |
| If REVERSE is nonzero, reverse the order of decls before putting |
| them into the BLOCK. */ |
| |
| tree |
| poplevel (int keep, int reverse, int functionbody) |
| { |
| /* Points to a BLOCK tree node. This is the BLOCK node constructed for the |
| binding level that we are about to exit and which is returned by this |
| routine. */ |
| tree block_node = NULL_TREE; |
| tree decl_chain; |
| tree subblock_chain = current_binding_level->blocks; |
| tree subblock_node; |
| |
| /* Reverse the list of XXXX_DECL nodes if desired. Note that the ..._DECL |
| nodes chained through the `names' field of current_binding_level are in |
| reverse order except for PARM_DECL node, which are explicitly stored in |
| the right order. */ |
| decl_chain = (reverse) ? nreverse (current_binding_level->names) |
| : current_binding_level->names; |
| |
| /* If there were any declarations in the current binding level, or if this |
| binding level is a function body, or if there are any nested blocks then |
| create a BLOCK node to record them for the life of this function. */ |
| if (keep || functionbody) |
| block_node = build_block (keep ? decl_chain : 0, subblock_chain, 0, 0); |
| |
| /* Record the BLOCK node just built as the subblock its enclosing scope. */ |
| for (subblock_node = subblock_chain; subblock_node; |
| subblock_node = TREE_CHAIN (subblock_node)) |
| BLOCK_SUPERCONTEXT (subblock_node) = block_node; |
| |
| /* Clear out the meanings of the local variables of this level. */ |
| |
| for (subblock_node = decl_chain; subblock_node; |
| subblock_node = TREE_CHAIN (subblock_node)) |
| if (DECL_NAME (subblock_node) != 0) |
| /* If the identifier was used or addressed via a local extern decl, |
| don't forget that fact. */ |
| if (DECL_EXTERNAL (subblock_node)) |
| { |
| if (TREE_USED (subblock_node)) |
| TREE_USED (DECL_NAME (subblock_node)) = 1; |
| if (TREE_ADDRESSABLE (subblock_node)) |
| TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (subblock_node)) = 1; |
| } |
| |
| /* Pop the current level. */ |
| current_binding_level = current_binding_level->level_chain; |
| |
| if (functionbody) |
| { |
| /* This is the top level block of a function. The ..._DECL chain stored |
| in BLOCK_VARS are the function's parameters (PARM_DECL nodes). Don't |
| leave them in the BLOCK because they are found in the FUNCTION_DECL |
| instead. */ |
| DECL_INITIAL (current_function_decl) = block_node; |
| BLOCK_VARS (block_node) = 0; |
| } |
| else if (block_node) |
| { |
| current_binding_level->blocks |
| = chainon (current_binding_level->blocks, block_node); |
| } |
| |
| /* If we did not make a block for the level just exited, any blocks made for |
| inner levels (since they cannot be recorded as subblocks in that level) |
| must be carried forward so they will later become subblocks of something |
| else. */ |
| else if (subblock_chain) |
| current_binding_level->blocks |
| = chainon (current_binding_level->blocks, subblock_chain); |
| if (block_node) |
| TREE_USED (block_node) = 1; |
| |
| return block_node; |
| } |
| |
| /* Insert BLOCK at the end of the list of subblocks of the |
| current binding level. This is used when a BIND_EXPR is expanded, |
| to handle the BLOCK node inside the BIND_EXPR. */ |
| |
| void |
| insert_block (tree block) |
| { |
| TREE_USED (block) = 1; |
| current_binding_level->blocks |
| = chainon (current_binding_level->blocks, block); |
| } |
| |
| /* Records a ..._DECL node DECL as belonging to the current lexical scope. |
| Returns the ..._DECL node. */ |
| |
| tree |
| pushdecl (tree decl) |
| { |
| /* External objects aren't nested, other objects may be. */ |
| if ((DECL_EXTERNAL (decl)) || (decl == current_function_decl)) |
| DECL_CONTEXT (decl) = 0; |
| else |
| DECL_CONTEXT (decl) = current_function_decl; |
| |
| /* Put the declaration on the list. The list of declarations is in reverse |
| order. The list will be reversed later if necessary. This needs to be |
| this way for compatibility with the back-end. */ |
| |
| TREE_CHAIN (decl) = current_binding_level->names; |
| current_binding_level->names = decl; |
| |
| /* For the declaration of a type, set its name if it is not already set. */ |
| |
| if (TREE_CODE (decl) == TYPE_DECL && TYPE_NAME (TREE_TYPE (decl)) == 0) |
| { |
| if (DECL_SOURCE_LINE (decl) == 0) |
| TYPE_NAME (TREE_TYPE (decl)) = decl; |
| else |
| TYPE_NAME (TREE_TYPE (decl)) = DECL_NAME (decl); |
| } |
| |
| return decl; |
| } |
| |
| |
| /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL. */ |
| |
| tree |
| pushdecl_top_level (tree x) |
| { |
| tree t; |
| struct binding_level *b = current_binding_level; |
| |
| current_binding_level = global_binding_level; |
| t = pushdecl (x); |
| current_binding_level = b; |
| return t; |
| } |
| |
| |
| /* Clear the binding stack. */ |
| static void |
| gfc_clear_binding_stack (void) |
| { |
| while (!global_bindings_p ()) |
| poplevel (0, 0, 0); |
| } |
| |
| |
| #ifndef CHAR_TYPE_SIZE |
| #define CHAR_TYPE_SIZE BITS_PER_UNIT |
| #endif |
| |
| #ifndef INT_TYPE_SIZE |
| #define INT_TYPE_SIZE BITS_PER_WORD |
| #endif |
| |
| #undef SIZE_TYPE |
| #define SIZE_TYPE "long unsigned int" |
| |
| /* Create tree nodes for the basic scalar types of Fortran 95, |
| and some nodes representing standard constants (0, 1, (void *) 0). |
| Initialize the global binding level. |
| Make definitions for built-in primitive functions. */ |
| static void |
| gfc_init_decl_processing (void) |
| { |
| current_function_decl = NULL; |
| current_binding_level = NULL_BINDING_LEVEL; |
| free_binding_level = NULL_BINDING_LEVEL; |
| |
| /* Make the binding_level structure for global names. We move all |
| variables that are in a COMMON block to this binding level. */ |
| pushlevel (0); |
| global_binding_level = current_binding_level; |
| |
| /* Build common tree nodes. char_type_node is unsigned because we |
| only use it for actual characters, not for INTEGER(1). Also, we |
| want double_type_node to actually have double precision. */ |
| build_common_tree_nodes (false, false); |
| set_sizetype (long_unsigned_type_node); |
| build_common_tree_nodes_2 (0); |
| void_list_node = build_tree_list (NULL_TREE, void_type_node); |
| |
| /* Set up F95 type nodes. */ |
| gfc_init_kinds (); |
| gfc_init_types (); |
| } |
| |
| /* Mark EXP saying that we need to be able to take the |
| address of it; it should not be allocated in a register. |
| In Fortran 95 this is only the case for variables with |
| the TARGET attribute, but we implement it here for a |
| likely future Cray pointer extension. |
| Value is 1 if successful. */ |
| /* TODO: Check/fix mark_addressable. */ |
| bool |
| gfc_mark_addressable (tree exp) |
| { |
| register tree x = exp; |
| while (1) |
| switch (TREE_CODE (x)) |
| { |
| case COMPONENT_REF: |
| case ADDR_EXPR: |
| case ARRAY_REF: |
| case REALPART_EXPR: |
| case IMAGPART_EXPR: |
| x = TREE_OPERAND (x, 0); |
| break; |
| |
| case CONSTRUCTOR: |
| TREE_ADDRESSABLE (x) = 1; |
| return true; |
| |
| case VAR_DECL: |
| case CONST_DECL: |
| case PARM_DECL: |
| case RESULT_DECL: |
| if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x) && DECL_NONLOCAL (x)) |
| { |
| if (TREE_PUBLIC (x)) |
| { |
| error |
| ("global register variable %qs used in nested function", |
| IDENTIFIER_POINTER (DECL_NAME (x))); |
| return false; |
| } |
| pedwarn ("register variable %qs used in nested function", |
| IDENTIFIER_POINTER (DECL_NAME (x))); |
| } |
| else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)) |
| { |
| if (TREE_PUBLIC (x)) |
| { |
| error ("address of global register variable %qs requested", |
| IDENTIFIER_POINTER (DECL_NAME (x))); |
| return true; |
| } |
| |
| #if 0 |
| /* If we are making this addressable due to its having |
| volatile components, give a different error message. Also |
| handle the case of an unnamed parameter by not trying |
| to give the name. */ |
| |
| else if (C_TYPE_FIELDS_VOLATILE (TREE_TYPE (x))) |
| { |
| error ("cannot put object with volatile field into register"); |
| return false; |
| } |
| #endif |
| |
| pedwarn ("address of register variable %qs requested", |
| IDENTIFIER_POINTER (DECL_NAME (x))); |
| } |
| |
| /* drops in */ |
| case FUNCTION_DECL: |
| TREE_ADDRESSABLE (x) = 1; |
| |
| default: |
| return true; |
| } |
| } |
| |
| /* Return the typed-based alias set for T, which may be an expression |
| or a type. Return -1 if we don't do anything special. */ |
| |
| static HOST_WIDE_INT |
| gfc_get_alias_set (tree t) |
| { |
| tree u; |
| |
| /* Permit type-punning when accessing an EQUIVALENCEd variable or |
| mixed type entry master's return value. */ |
| for (u = t; handled_component_p (u); u = TREE_OPERAND (u, 0)) |
| if (TREE_CODE (u) == COMPONENT_REF |
| && TREE_CODE (TREE_TYPE (TREE_OPERAND (u, 0))) == UNION_TYPE) |
| return 0; |
| |
| return -1; |
| } |
| |
| /* press the big red button - garbage (ggc) collection is on */ |
| |
| int ggc_p = 1; |
| |
| /* Builtin function initialization. */ |
| |
| /* Return a definition for a builtin function named NAME and whose data type |
| is TYPE. TYPE should be a function type with argument types. |
| FUNCTION_CODE tells later passes how to compile calls to this function. |
| See tree.h for its possible values. |
| |
| If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME, |
| the name to be called if we can't opencode the function. If |
| ATTRS is nonzero, use that for the function's attribute list. */ |
| |
| tree |
| builtin_function (const char *name, |
| tree type, |
| int function_code, |
| enum built_in_class class, |
| const char *library_name, |
| tree attrs) |
| { |
| tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type); |
| DECL_EXTERNAL (decl) = 1; |
| TREE_PUBLIC (decl) = 1; |
| if (library_name) |
| SET_DECL_ASSEMBLER_NAME (decl, get_identifier (library_name)); |
| /* LLVM LOCAL begin */ |
| #ifndef ENABLE_LLVM |
| make_decl_rtl (decl); |
| #else |
| make_decl_llvm (decl); |
| #endif |
| /* LLVM LOCAL end */ |
| pushdecl (decl); |
| DECL_BUILT_IN_CLASS (decl) = class; |
| DECL_FUNCTION_CODE (decl) = function_code; |
| |
| /* Possibly apply some default attributes to this built-in function. */ |
| if (attrs) |
| { |
| /* FORNOW the only supported attribute is "const". If others need |
| to be supported then see the more general solution in procedure |
| builtin_function in c-decl.c */ |
| if (lookup_attribute ( "const", attrs )) |
| TREE_READONLY (decl) = 1; |
| } |
| |
| return decl; |
| } |
| |
| |
| static void |
| gfc_define_builtin (const char * name, |
| tree type, |
| int code, |
| const char * library_name, |
| bool const_p) |
| { |
| tree decl; |
| |
| decl = builtin_function (name, type, code, BUILT_IN_NORMAL, |
| library_name, NULL_TREE); |
| if (const_p) |
| TREE_READONLY (decl) = 1; |
| |
| built_in_decls[code] = decl; |
| implicit_built_in_decls[code] = decl; |
| } |
| |
| |
| #define DO_DEFINE_MATH_BUILTIN(code, name, argtype, tbase) \ |
| gfc_define_builtin ("__builtin_" name "l", tbase##longdouble[argtype], \ |
| BUILT_IN_ ## code ## L, name "l", true); \ |
| gfc_define_builtin ("__builtin_" name, tbase##double[argtype], \ |
| BUILT_IN_ ## code, name, true); \ |
| gfc_define_builtin ("__builtin_" name "f", tbase##float[argtype], \ |
| BUILT_IN_ ## code ## F, name "f", true); |
| |
| #define DEFINE_MATH_BUILTIN(code, name, argtype) \ |
| DO_DEFINE_MATH_BUILTIN (code, name, argtype, mfunc_) |
| |
| #define DEFINE_MATH_BUILTIN_C(code, name, argtype) \ |
| DO_DEFINE_MATH_BUILTIN (code, name, argtype, mfunc_) \ |
| DO_DEFINE_MATH_BUILTIN (C##code, "c" name, argtype, mfunc_c) |
| |
| |
| /* Create function types for builtin functions. */ |
| |
| static void |
| build_builtin_fntypes (tree * fntype, tree type) |
| { |
| tree tmp; |
| |
| /* type (*) (type) */ |
| tmp = tree_cons (NULL_TREE, type, void_list_node); |
| fntype[0] = build_function_type (type, tmp); |
| /* type (*) (type, type) */ |
| tmp = tree_cons (NULL_TREE, type, tmp); |
| fntype[1] = build_function_type (type, tmp); |
| /* type (*) (int, type) */ |
| tmp = tree_cons (NULL_TREE, integer_type_node, void_list_node); |
| tmp = tree_cons (NULL_TREE, type, tmp); |
| fntype[2] = build_function_type (type, tmp); |
| } |
| |
| static tree |
| builtin_type_for_size (int size, bool unsignedp) |
| { |
| tree type = lang_hooks.types.type_for_size (size, unsignedp); |
| return type ? type : error_mark_node; |
| } |
| |
| /* Initialization of builtin function nodes. */ |
| |
| static void |
| gfc_init_builtin_functions (void) |
| { |
| enum builtin_type |
| { |
| #define DEF_PRIMITIVE_TYPE(NAME, VALUE) NAME, |
| #define DEF_FUNCTION_TYPE_0(NAME, RETURN) NAME, |
| #define DEF_FUNCTION_TYPE_1(NAME, RETURN, ARG1) NAME, |
| #define DEF_FUNCTION_TYPE_2(NAME, RETURN, ARG1, ARG2) NAME, |
| #define DEF_FUNCTION_TYPE_3(NAME, RETURN, ARG1, ARG2, ARG3) NAME, |
| #define DEF_FUNCTION_TYPE_4(NAME, RETURN, ARG1, ARG2, ARG3, ARG4) NAME, |
| #define DEF_FUNCTION_TYPE_5(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) NAME, |
| #define DEF_FUNCTION_TYPE_6(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6) NAME, |
| #define DEF_FUNCTION_TYPE_7(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6, ARG7) NAME, |
| #define DEF_FUNCTION_TYPE_VAR_0(NAME, RETURN) NAME, |
| #define DEF_POINTER_TYPE(NAME, TYPE) NAME, |
| #include "types.def" |
| #undef DEF_PRIMITIVE_TYPE |
| #undef DEF_FUNCTION_TYPE_0 |
| #undef DEF_FUNCTION_TYPE_1 |
| #undef DEF_FUNCTION_TYPE_2 |
| #undef DEF_FUNCTION_TYPE_3 |
| #undef DEF_FUNCTION_TYPE_4 |
| #undef DEF_FUNCTION_TYPE_5 |
| #undef DEF_FUNCTION_TYPE_6 |
| #undef DEF_FUNCTION_TYPE_7 |
| #undef DEF_FUNCTION_TYPE_VAR_0 |
| #undef DEF_POINTER_TYPE |
| BT_LAST |
| }; |
| typedef enum builtin_type builtin_type; |
| enum |
| { |
| /* So far we need just these 2 attribute types. */ |
| ATTR_NOTHROW_LIST, |
| ATTR_CONST_NOTHROW_LIST |
| }; |
| |
| tree mfunc_float[3]; |
| tree mfunc_double[3]; |
| tree mfunc_longdouble[3]; |
| tree mfunc_cfloat[3]; |
| tree mfunc_cdouble[3]; |
| tree mfunc_clongdouble[3]; |
| tree func_cfloat_float; |
| tree func_cdouble_double; |
| tree func_clongdouble_longdouble; |
| tree ftype; |
| tree tmp; |
| tree builtin_types[(int) BT_LAST + 1]; |
| |
| build_builtin_fntypes (mfunc_float, float_type_node); |
| build_builtin_fntypes (mfunc_double, double_type_node); |
| build_builtin_fntypes (mfunc_longdouble, long_double_type_node); |
| build_builtin_fntypes (mfunc_cfloat, complex_float_type_node); |
| build_builtin_fntypes (mfunc_cdouble, complex_double_type_node); |
| build_builtin_fntypes (mfunc_clongdouble, complex_long_double_type_node); |
| |
| tmp = tree_cons (NULL_TREE, complex_float_type_node, void_list_node); |
| func_cfloat_float = build_function_type (float_type_node, tmp); |
| |
| tmp = tree_cons (NULL_TREE, complex_double_type_node, void_list_node); |
| func_cdouble_double = build_function_type (double_type_node, tmp); |
| |
| tmp = tree_cons (NULL_TREE, complex_long_double_type_node, void_list_node); |
| func_clongdouble_longdouble = |
| build_function_type (long_double_type_node, tmp); |
| |
| #include "mathbuiltins.def" |
| |
| /* We define these separately as the fortran versions have different |
| semantics (they return an integer type) */ |
| gfc_define_builtin ("__builtin_roundl", mfunc_longdouble[0], |
| BUILT_IN_ROUNDL, "roundl", true); |
| gfc_define_builtin ("__builtin_round", mfunc_double[0], |
| BUILT_IN_ROUND, "round", true); |
| gfc_define_builtin ("__builtin_roundf", mfunc_float[0], |
| BUILT_IN_ROUNDF, "roundf", true); |
| |
| gfc_define_builtin ("__builtin_truncl", mfunc_longdouble[0], |
| BUILT_IN_TRUNCL, "truncl", true); |
| gfc_define_builtin ("__builtin_trunc", mfunc_double[0], |
| BUILT_IN_TRUNC, "trunc", true); |
| gfc_define_builtin ("__builtin_truncf", mfunc_float[0], |
| BUILT_IN_TRUNCF, "truncf", true); |
| |
| gfc_define_builtin ("__builtin_cabsl", func_clongdouble_longdouble, |
| BUILT_IN_CABSL, "cabsl", true); |
| gfc_define_builtin ("__builtin_cabs", func_cdouble_double, |
| BUILT_IN_CABS, "cabs", true); |
| gfc_define_builtin ("__builtin_cabsf", func_cfloat_float, |
| BUILT_IN_CABSF, "cabsf", true); |
| |
| gfc_define_builtin ("__builtin_copysignl", mfunc_longdouble[1], |
| BUILT_IN_COPYSIGNL, "copysignl", true); |
| gfc_define_builtin ("__builtin_copysign", mfunc_double[1], |
| BUILT_IN_COPYSIGN, "copysign", true); |
| gfc_define_builtin ("__builtin_copysignf", mfunc_float[1], |
| BUILT_IN_COPYSIGNF, "copysignf", true); |
| |
| gfc_define_builtin ("__builtin_fmodl", mfunc_longdouble[1], |
| BUILT_IN_FMODL, "fmodl", true); |
| gfc_define_builtin ("__builtin_fmod", mfunc_double[1], |
| BUILT_IN_FMOD, "fmod", true); |
| gfc_define_builtin ("__builtin_fmodf", mfunc_float[1], |
| BUILT_IN_FMODF, "fmodf", true); |
| |
| /* These are used to implement the ** operator. */ |
| gfc_define_builtin ("__builtin_powl", mfunc_longdouble[1], |
| BUILT_IN_POWL, "powl", true); |
| gfc_define_builtin ("__builtin_pow", mfunc_double[1], |
| BUILT_IN_POW, "pow", true); |
| gfc_define_builtin ("__builtin_powf", mfunc_float[1], |
| BUILT_IN_POWF, "powf", true); |
| |
| /* Other builtin functions we use. */ |
| |
| tmp = tree_cons (NULL_TREE, long_integer_type_node, void_list_node); |
| tmp = tree_cons (NULL_TREE, long_integer_type_node, tmp); |
| ftype = build_function_type (long_integer_type_node, tmp); |
| gfc_define_builtin ("__builtin_expect", ftype, BUILT_IN_EXPECT, |
| "__builtin_expect", true); |
| |
| #define DEF_PRIMITIVE_TYPE(ENUM, VALUE) \ |
| builtin_types[(int) ENUM] = VALUE; |
| #define DEF_FUNCTION_TYPE_0(ENUM, RETURN) \ |
| builtin_types[(int) ENUM] \ |
| = build_function_type (builtin_types[(int) RETURN], \ |
| void_list_node); |
| #define DEF_FUNCTION_TYPE_1(ENUM, RETURN, ARG1) \ |
| builtin_types[(int) ENUM] \ |
| = build_function_type (builtin_types[(int) RETURN], \ |
| tree_cons (NULL_TREE, \ |
| builtin_types[(int) ARG1], \ |
| void_list_node)); |
| #define DEF_FUNCTION_TYPE_2(ENUM, RETURN, ARG1, ARG2) \ |
| builtin_types[(int) ENUM] \ |
| = build_function_type \ |
| (builtin_types[(int) RETURN], \ |
| tree_cons (NULL_TREE, \ |
| builtin_types[(int) ARG1], \ |
| tree_cons (NULL_TREE, \ |
| builtin_types[(int) ARG2], \ |
| void_list_node))); |
| #define DEF_FUNCTION_TYPE_3(ENUM, RETURN, ARG1, ARG2, ARG3) \ |
| builtin_types[(int) ENUM] \ |
| = build_function_type \ |
| (builtin_types[(int) RETURN], \ |
| tree_cons (NULL_TREE, \ |
| builtin_types[(int) ARG1], \ |
| tree_cons (NULL_TREE, \ |
| builtin_types[(int) ARG2], \ |
| tree_cons (NULL_TREE, \ |
| builtin_types[(int) ARG3], \ |
| void_list_node)))); |
| #define DEF_FUNCTION_TYPE_4(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4) \ |
| builtin_types[(int) ENUM] \ |
| = build_function_type \ |
| (builtin_types[(int) RETURN], \ |
| tree_cons (NULL_TREE, \ |
| builtin_types[(int) ARG1], \ |
| tree_cons (NULL_TREE, \ |
| builtin_types[(int) ARG2], \ |
| tree_cons \ |
| (NULL_TREE, \ |
| builtin_types[(int) ARG3], \ |
| tree_cons (NULL_TREE, \ |
| builtin_types[(int) ARG4], \ |
| void_list_node))))); |
| #define DEF_FUNCTION_TYPE_5(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) \ |
| builtin_types[(int) ENUM] \ |
| = build_function_type \ |
| (builtin_types[(int) RETURN], \ |
| tree_cons (NULL_TREE, \ |
| builtin_types[(int) ARG1], \ |
| tree_cons (NULL_TREE, \ |
| builtin_types[(int) ARG2], \ |
| tree_cons \ |
| (NULL_TREE, \ |
| builtin_types[(int) ARG3], \ |
| tree_cons (NULL_TREE, \ |
| builtin_types[(int) ARG4], \ |
| tree_cons (NULL_TREE, \ |
| builtin_types[(int) ARG5],\ |
| void_list_node)))))); |
| #define DEF_FUNCTION_TYPE_6(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ |
| ARG6) \ |
| builtin_types[(int) ENUM] \ |
| = build_function_type \ |
| (builtin_types[(int) RETURN], \ |
| tree_cons (NULL_TREE, \ |
| builtin_types[(int) ARG1], \ |
| tree_cons (NULL_TREE, \ |
| builtin_types[(int) ARG2], \ |
| tree_cons \ |
| (NULL_TREE, \ |
| builtin_types[(int) ARG3], \ |
| tree_cons \ |
| (NULL_TREE, \ |
| builtin_types[(int) ARG4], \ |
| tree_cons (NULL_TREE, \ |
| builtin_types[(int) ARG5], \ |
| tree_cons (NULL_TREE, \ |
| builtin_types[(int) ARG6],\ |
| void_list_node))))))); |
| #define DEF_FUNCTION_TYPE_7(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ |
| ARG6, ARG7) \ |
| builtin_types[(int) ENUM] \ |
| = build_function_type \ |
| (builtin_types[(int) RETURN], \ |
| tree_cons (NULL_TREE, \ |
| builtin_types[(int) ARG1], \ |
| tree_cons (NULL_TREE, \ |
| builtin_types[(int) ARG2], \ |
| tree_cons \ |
| (NULL_TREE, \ |
| builtin_types[(int) ARG3], \ |
| tree_cons \ |
| (NULL_TREE, \ |
| builtin_types[(int) ARG4], \ |
| tree_cons (NULL_TREE, \ |
| builtin_types[(int) ARG5], \ |
| tree_cons (NULL_TREE, \ |
| builtin_types[(int) ARG6],\ |
| tree_cons (NULL_TREE, \ |
| builtin_types[(int) ARG6], \ |
| void_list_node)))))))); |
| #define DEF_FUNCTION_TYPE_VAR_0(ENUM, RETURN) \ |
| builtin_types[(int) ENUM] \ |
| = build_function_type (builtin_types[(int) RETURN], NULL_TREE); |
| #define DEF_POINTER_TYPE(ENUM, TYPE) \ |
| builtin_types[(int) ENUM] \ |
| = build_pointer_type (builtin_types[(int) TYPE]); |
| #include "types.def" |
| #undef DEF_PRIMITIVE_TYPE |
| #undef DEF_FUNCTION_TYPE_1 |
| #undef DEF_FUNCTION_TYPE_2 |
| #undef DEF_FUNCTION_TYPE_3 |
| #undef DEF_FUNCTION_TYPE_4 |
| #undef DEF_FUNCTION_TYPE_5 |
| #undef DEF_FUNCTION_TYPE_6 |
| #undef DEF_FUNCTION_TYPE_VAR_0 |
| #undef DEF_POINTER_TYPE |
| builtin_types[(int) BT_LAST] = NULL_TREE; |
| |
| /* Initialize synchronization builtins. */ |
| #undef DEF_SYNC_BUILTIN |
| #define DEF_SYNC_BUILTIN(code, name, type, attr) \ |
| gfc_define_builtin (name, builtin_types[type], code, name, \ |
| attr == ATTR_CONST_NOTHROW_LIST); |
| #include "../sync-builtins.def" |
| #undef DEF_SYNC_BUILTIN |
| |
| if (gfc_option.flag_openmp) |
| { |
| #undef DEF_GOMP_BUILTIN |
| #define DEF_GOMP_BUILTIN(code, name, type, attr) \ |
| gfc_define_builtin ("__builtin_" name, builtin_types[type], \ |
| code, name, attr == ATTR_CONST_NOTHROW_LIST); |
| #include "../omp-builtins.def" |
| #undef DEF_GOMP_BUILTIN |
| } |
| |
| gfc_define_builtin ("__builtin_trap", builtin_types[BT_FN_VOID], |
| BUILT_IN_TRAP, NULL, false); |
| TREE_THIS_VOLATILE (built_in_decls[BUILT_IN_TRAP]) = 1; |
| |
| build_common_builtin_nodes (); |
| targetm.init_builtins (); |
| } |
| |
| #undef DEFINE_MATH_BUILTIN_C |
| #undef DEFINE_MATH_BUILTIN |
| |
| #include "gt-fortran-f95-lang.h" |
| #include "gtype-fortran.h" |