gcc/fortran/f95-lang.c

   1 /* gfortran backend interface
   2    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006
   3    Free Software Foundation, Inc.
   4    Contributed by Paul Brook.
   5
   6 This file is part of GCC.
   7
   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
  11 version.
  12
  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
  16 for more details.
  17
  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
  21 02110-1301, USA.  */
  22
  23 /* f95-lang.c-- GCC backend interface stuff */
  24
  25 /* declare required prototypes: */
  26
  27 #include "config.h"
  28 #include "system.h"
  29 #include "ansidecl.h"
  30 #include "system.h"
  31 #include "coretypes.h"
  32 #include "tree.h"
  33 #include "tree-gimple.h"
  34 #include "flags.h"
  35 #include "langhooks.h"
  36 #include "langhooks-def.h"
  37 #include "timevar.h"
  38 #include "tm.h"
  39 #include "function.h"
  40 #include "ggc.h"
  41 #include "toplev.h"
  42 #include "target.h"
  43 #include "debug.h"
  44 #include "diagnostic.h"
  45 #include "tree-dump.h"
  46 #include "cgraph.h"
  47
  48 #include "gfortran.h"
  49 #include "trans.h"
  50 #include "trans-types.h"
  51 #include "trans-const.h"
  52
  53 /* Language-dependent contents of an identifier.  */
  54
  55 struct lang_identifier
  56 GTY(())
  57 {
  58   struct tree_identifier common;
  59 };
  60
  61 /* The resulting tree type.  */
  62
  63 union lang_tree_node
  64 GTY((desc ("TREE_CODE (&%h.generic) == IDENTIFIER_NODE"),
  65      chain_next ("(union lang_tree_node *)TREE_CHAIN (&%h.generic)")))
  66 {
  67   union tree_node GTY((tag ("0"),
  68                        desc ("tree_node_structure (&%h)"))) generic;
  69   struct lang_identifier GTY((tag ("1"))) identifier;
  70 };
  71
  72 /* Save and restore the variables in this file and elsewhere
  73    that keep track of the progress of compilation of the current function.
  74    Used for nested functions.  */
  75
  76 struct language_function
  77 GTY(())
  78 {
  79   /* struct gfc_language_function base; */
  80   struct binding_level *binding_level;
  81 };
  82
  83 /* We don't have a lex/yacc lexer/parser, but toplev expects these to
  84    exist anyway.  */
  85 void yyerror (const char *str);
  86 int yylex (void);
  87
  88 static void gfc_init_decl_processing (void);
  89 static void gfc_init_builtin_functions (void);
  90
  91 /* Each front end provides its own.  */
  92 static bool gfc_init (void);
  93 static void gfc_finish (void);
  94 static void gfc_print_identifier (FILE *, tree, int);
  95 static bool gfc_mark_addressable (tree);
  96 void do_function_end (void);
  97 int global_bindings_p (void);
  98 void insert_block (tree);
  99 static void gfc_clear_binding_stack (void);
 100 static void gfc_be_parse_file (int);
 101 static void gfc_expand_function (tree);
 102 static HOST_WIDE_INT gfc_get_alias_set (tree);
 103
 104 #undef LANG_HOOKS_NAME
 105 #undef LANG_HOOKS_INIT
 106 #undef LANG_HOOKS_FINISH
 107 #undef LANG_HOOKS_INIT_OPTIONS
 108 #undef LANG_HOOKS_HANDLE_OPTION
 109 #undef LANG_HOOKS_POST_OPTIONS
 110 #undef LANG_HOOKS_PRINT_IDENTIFIER
 111 #undef LANG_HOOKS_PARSE_FILE
 112 #undef LANG_HOOKS_MARK_ADDRESSABLE
 113 #undef LANG_HOOKS_TYPE_FOR_MODE
 114 #undef LANG_HOOKS_TYPE_FOR_SIZE
 115 #undef LANG_HOOKS_UNSIGNED_TYPE
 116 #undef LANG_HOOKS_SIGNED_TYPE
 117 #undef LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE
 118 #undef LANG_HOOKS_CALLGRAPH_EXPAND_FUNCTION
 119 #undef LANG_HOOKS_CLEAR_BINDING_STACK
 120 #undef LANG_HOOKS_GET_ALIAS_SET
 121 #undef LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE
 122 #undef LANG_HOOKS_OMP_PREDETERMINED_SHARING
 123 #undef LANG_HOOKS_OMP_CLAUSE_DEFAULT_CTOR
 124 #undef LANG_HOOKS_OMP_DISREGARD_VALUE_EXPR
 125 #undef LANG_HOOKS_OMP_PRIVATE_DEBUG_CLAUSE
 126 #undef LANG_HOOKS_OMP_FIRSTPRIVATIZE_TYPE_SIZES
 127 #undef LANG_HOOKS_BUILTIN_FUNCTION
 128
 129 /* Define lang hooks.  */
 130 #define LANG_HOOKS_NAME                 "GNU F95"
 131 #define LANG_HOOKS_INIT                 gfc_init
 132 #define LANG_HOOKS_FINISH               gfc_finish
 133 #define LANG_HOOKS_INIT_OPTIONS         gfc_init_options
 134 #define LANG_HOOKS_HANDLE_OPTION        gfc_handle_option
 135 #define LANG_HOOKS_POST_OPTIONS         gfc_post_options
 136 #define LANG_HOOKS_PRINT_IDENTIFIER     gfc_print_identifier
 137 #define LANG_HOOKS_PARSE_FILE           gfc_be_parse_file
 138 #define LANG_HOOKS_MARK_ADDRESSABLE        gfc_mark_addressable
 139 #define LANG_HOOKS_TYPE_FOR_MODE           gfc_type_for_mode
 140 #define LANG_HOOKS_TYPE_FOR_SIZE           gfc_type_for_size
 141 #define LANG_HOOKS_UNSIGNED_TYPE           gfc_unsigned_type
 142 #define LANG_HOOKS_SIGNED_TYPE             gfc_signed_type
 143 #define LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE gfc_signed_or_unsigned_type
 144 #define LANG_HOOKS_CALLGRAPH_EXPAND_FUNCTION gfc_expand_function
 145 #define LANG_HOOKS_CLEAR_BINDING_STACK     gfc_clear_binding_stack
 146 #define LANG_HOOKS_GET_ALIAS_SET           gfc_get_alias_set
 147 #define LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE   gfc_omp_privatize_by_reference
 148 #define LANG_HOOKS_OMP_PREDETERMINED_SHARING    gfc_omp_predetermined_sharing
 149 #define LANG_HOOKS_OMP_CLAUSE_DEFAULT_CTOR      gfc_omp_clause_default_ctor
 150 #define LANG_HOOKS_OMP_DISREGARD_VALUE_EXPR     gfc_omp_disregard_value_expr
 151 #define LANG_HOOKS_OMP_PRIVATE_DEBUG_CLAUSE     gfc_omp_private_debug_clause
 152 #define LANG_HOOKS_OMP_FIRSTPRIVATIZE_TYPE_SIZES \
 153   gfc_omp_firstprivatize_type_sizes
 154 #define LANG_HOOKS_BUILTIN_FUNCTION          gfc_builtin_function
 155
 156 const struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
 157
 158 /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
 159    that have names.  Here so we can clear out their names' definitions
 160    at the end of the function.  */
 161
 162 /* Tree code classes.  */
 163
 164 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE,
 165
 166 const enum tree_code_class tree_code_type[] = {
 167 #include "tree.def"
 168 };
 169 #undef DEFTREECODE
 170
 171 /* Table indexed by tree code giving number of expression
 172    operands beyond the fixed part of the node structure.
 173    Not used for types or decls.  */
 174
 175 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) LENGTH,
 176
 177 const unsigned char tree_code_length[] = {
 178 #include "tree.def"
 179 };
 180 #undef DEFTREECODE
 181
 182 /* Names of tree components.
 183    Used for printing out the tree and error messages.  */
 184 #define DEFTREECODE(SYM, NAME, TYPE, LEN) NAME,
 185
 186 const char *const tree_code_name[] = {
 187 #include "tree.def"
 188 };
 189 #undef DEFTREECODE
 190
 191
 192 #define NULL_BINDING_LEVEL (struct binding_level *) NULL
 193
 194 /* A chain of binding_level structures awaiting reuse.  */
 195
 196 static GTY(()) struct binding_level *free_binding_level;
 197
 198 /* The elements of `ridpointers' are identifier nodes
 199    for the reserved type names and storage classes.
 200    It is indexed by a RID_... value.  */
 201 tree *ridpointers = NULL;
 202
 203 /* language-specific flags.  */
 204
 205 static void
 206 gfc_expand_function (tree fndecl)
 207 {
 208   tree t;
 209
 210   if (DECL_INITIAL (fndecl)
 211       && BLOCK_SUBBLOCKS (DECL_INITIAL (fndecl)))
 212     {
 213       /* Local static equivalenced variables are never seen by
 214          check_global_declarations, so we need to output debug
 215          info by hand.  */
 216
 217       t = BLOCK_SUBBLOCKS (DECL_INITIAL (fndecl));
 218       for (t = BLOCK_VARS (t); t; t = TREE_CHAIN (t))
 219         if (TREE_CODE (t) == VAR_DECL && DECL_HAS_VALUE_EXPR_P (t)
 220             && TREE_STATIC (t))
 221           {
 222             tree expr = DECL_VALUE_EXPR (t);
 223
 224             if (TREE_CODE (expr) == COMPONENT_REF
 225                 && TREE_CODE (TREE_OPERAND (expr, 0)) == VAR_DECL
 226                 && TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0)))
 227                    == UNION_TYPE
 228                 && cgraph_varpool_node (TREE_OPERAND (expr, 0))->needed
 229                 && errorcount == 0 && sorrycount == 0)
 230               {
 231                 timevar_push (TV_SYMOUT);
 232                 (*debug_hooks->global_decl) (t);
 233                 timevar_pop (TV_SYMOUT);
 234               }
 235           }
 236     }
 237
 238   tree_rest_of_compilation (fndecl);
 239 }
 240 \f
 241
 242 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
 243    or validate its data type for an `if' or `while' statement or ?..: exp.
 244
 245    This preparation consists of taking the ordinary
 246    representation of an expression expr and producing a valid tree
 247    boolean expression describing whether expr is nonzero.  We could
 248    simply always do build_binary_op (NE_EXPR, expr, boolean_false_node, 1),
 249    but we optimize comparisons, &&, ||, and !.
 250
 251    The resulting type should always be `boolean_type_node'.
 252    This is much simpler than the corresponding C version because we have a
 253    distinct boolean type.  */
 254
 255 tree
 256 gfc_truthvalue_conversion (tree expr)
 257 {
 258   switch (TREE_CODE (TREE_TYPE (expr)))
 259     {
 260     case BOOLEAN_TYPE:
 261       if (TREE_TYPE (expr) == boolean_type_node)
 262         return expr;
 263       else if (COMPARISON_CLASS_P (expr))
 264         {
 265           TREE_TYPE (expr) = boolean_type_node;
 266           return expr;
 267         }
 268       else if (TREE_CODE (expr) == NOP_EXPR)
 269         return build1 (NOP_EXPR, boolean_type_node,
 270                        TREE_OPERAND (expr, 0));
 271       else
 272         return build1 (NOP_EXPR, boolean_type_node, expr);
 273
 274     case INTEGER_TYPE:
 275       if (TREE_CODE (expr) == INTEGER_CST)
 276         return integer_zerop (expr) ? boolean_false_node : boolean_true_node;
 277       else
 278         return build2 (NE_EXPR, boolean_type_node, expr,
 279                        build_int_cst (TREE_TYPE (expr), 0));
 280
 281     default:
 282       internal_error ("Unexpected type in truthvalue_conversion");
 283     }
 284 }
 285
 286 static void
 287 gfc_create_decls (void)
 288 {
 289   /* GCC builtins.  */
 290   gfc_init_builtin_functions ();
 291
 292   /* Runtime/IO library functions.  */
 293   gfc_build_builtin_function_decls ();
 294
 295   gfc_init_constants ();
 296 }
 297
 298 static void
 299 gfc_be_parse_file (int set_yydebug ATTRIBUTE_UNUSED)
 300 {
 301   int errors;
 302   int warnings;
 303
 304   gfc_create_decls ();
 305   gfc_parse_file ();
 306   gfc_generate_constructors ();
 307
 308   cgraph_finalize_compilation_unit ();
 309   cgraph_optimize ();
 310
 311   /* Tell the frontent about any errors.  */
 312   gfc_get_errors (&warnings, &errors);
 313   errorcount += errors;
 314   warningcount += warnings;
 315 }
 316 \f
 317 /* Initialize everything.  */
 318
 319 static bool
 320 gfc_init (void)
 321 {
 322 #ifdef USE_MAPPED_LOCATION
 323   linemap_add (&line_table, LC_ENTER, false, gfc_source_file, 1);
 324   linemap_add (&line_table, LC_RENAME, false, "<built-in>", 0);
 325 #endif
 326
 327   /* First initialize the backend.  */
 328   gfc_init_decl_processing ();
 329   gfc_static_ctors = NULL_TREE;
 330
 331   /* Then the frontend.  */
 332   gfc_init_1 ();
 333
 334   if (gfc_new_file () != SUCCESS)
 335     fatal_error ("can't open input file: %s", gfc_source_file);
 336   return true;
 337 }
 338
 339
 340 static void
 341 gfc_finish (void)
 342 {
 343   gfc_done_1 ();
 344   gfc_release_include_path ();
 345   return;
 346 }
 347
 348 static void
 349 gfc_print_identifier (FILE * file ATTRIBUTE_UNUSED,
 350                       tree node ATTRIBUTE_UNUSED,
 351                       int indent ATTRIBUTE_UNUSED)
 352 {
 353   return;
 354 }
 355 \f
 356
 357 /* These functions and variables deal with binding contours.  We only
 358    need these functions for the list of PARM_DECLs, but we leave the
 359    functions more general; these are a simplified version of the
 360    functions from GNAT.  */
 361
 362 /* For each binding contour we allocate a binding_level structure which records
 363    the entities defined or declared in that contour. Contours include:
 364
 365         the global one
 366         one for each subprogram definition
 367         one for each compound statement (declare block)
 368
 369    Binding contours are used to create GCC tree BLOCK nodes.  */
 370
 371 struct binding_level
 372 GTY(())
 373 {
 374   /* A chain of ..._DECL nodes for all variables, constants, functions,
 375      parameters and type declarations.  These ..._DECL nodes are chained
 376      through the TREE_CHAIN field. Note that these ..._DECL nodes are stored
 377      in the reverse of the order supplied to be compatible with the
 378      back-end.  */
 379   tree names;
 380   /* For each level (except the global one), a chain of BLOCK nodes for all
 381      the levels that were entered and exited one level down from this one.  */
 382   tree blocks;
 383   /* The binding level containing this one (the enclosing binding level).  */
 384   struct binding_level *level_chain;
 385 };
 386
 387 /* The binding level currently in effect.  */
 388 static GTY(()) struct binding_level *current_binding_level = NULL;
 389
 390 /* The outermost binding level. This binding level is created when the
 391    compiler is started and it will exist through the entire compilation.  */
 392 static GTY(()) struct binding_level *global_binding_level;
 393
 394 /* Binding level structures are initialized by copying this one.  */
 395 static struct binding_level clear_binding_level = { NULL, NULL, NULL };
 396 \f
 397 /* Return nonzero if we are currently in the global binding level.  */
 398
 399 int
 400 global_bindings_p (void)
 401 {
 402   return current_binding_level == global_binding_level ? -1 : 0;
 403 }
 404
 405 tree
 406 getdecls (void)
 407 {
 408   return current_binding_level->names;
 409 }
 410
 411 /* Enter a new binding level. The input parameter is ignored, but has to be
 412    specified for back-end compatibility.  */
 413
 414 void
 415 pushlevel (int ignore ATTRIBUTE_UNUSED)
 416 {
 417   struct binding_level *newlevel
 418     = (struct binding_level *) ggc_alloc (sizeof (struct binding_level));
 419
 420   *newlevel = clear_binding_level;
 421
 422   /* Add this level to the front of the chain (stack) of levels that are
 423      active.  */
 424   newlevel->level_chain = current_binding_level;
 425   current_binding_level = newlevel;
 426 }
 427
 428 /* Exit a binding level.
 429    Pop the level off, and restore the state of the identifier-decl mappings
 430    that were in effect when this level was entered.
 431
 432    If KEEP is nonzero, this level had explicit declarations, so
 433    and create a "block" (a BLOCK node) for the level
 434    to record its declarations and subblocks for symbol table output.
 435
 436    If FUNCTIONBODY is nonzero, this level is the body of a function,
 437    so create a block as if KEEP were set and also clear out all
 438    label names.
 439
 440    If REVERSE is nonzero, reverse the order of decls before putting
 441    them into the BLOCK.  */
 442
 443 tree
 444 poplevel (int keep, int reverse, int functionbody)
 445 {
 446   /* Points to a BLOCK tree node. This is the BLOCK node constructed for the
 447      binding level that we are about to exit and which is returned by this
 448      routine.  */
 449   tree block_node = NULL_TREE;
 450   tree decl_chain;
 451   tree subblock_chain = current_binding_level->blocks;
 452   tree subblock_node;
 453
 454   /* Reverse the list of XXXX_DECL nodes if desired.  Note that the ..._DECL
 455      nodes chained through the `names' field of current_binding_level are in
 456      reverse order except for PARM_DECL node, which are explicitly stored in
 457      the right order.  */
 458   decl_chain = (reverse) ? nreverse (current_binding_level->names)
 459     : current_binding_level->names;
 460
 461   /* If there were any declarations in the current binding level, or if this
 462      binding level is a function body, or if there are any nested blocks then
 463      create a BLOCK node to record them for the life of this function.  */
 464   if (keep || functionbody)
 465     block_node = build_block (keep ? decl_chain : 0, subblock_chain, 0, 0);
 466
 467   /* Record the BLOCK node just built as the subblock its enclosing scope.  */
 468   for (subblock_node = subblock_chain; subblock_node;
 469        subblock_node = TREE_CHAIN (subblock_node))
 470     BLOCK_SUPERCONTEXT (subblock_node) = block_node;
 471
 472   /* Clear out the meanings of the local variables of this level.  */
 473
 474   for (subblock_node = decl_chain; subblock_node;
 475        subblock_node = TREE_CHAIN (subblock_node))
 476     if (DECL_NAME (subblock_node) != 0)
 477       /* If the identifier was used or addressed via a local extern decl,
 478          don't forget that fact.  */
 479       if (DECL_EXTERNAL (subblock_node))
 480         {
 481           if (TREE_USED (subblock_node))
 482             TREE_USED (DECL_NAME (subblock_node)) = 1;
 483           if (TREE_ADDRESSABLE (subblock_node))
 484             TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (subblock_node)) = 1;
 485         }
 486
 487   /* Pop the current level.  */
 488   current_binding_level = current_binding_level->level_chain;
 489
 490   if (functionbody)
 491     {
 492       /* This is the top level block of a function. The ..._DECL chain stored
 493          in BLOCK_VARS are the function's parameters (PARM_DECL nodes). Don't
 494          leave them in the BLOCK because they are found in the FUNCTION_DECL
 495          instead.  */
 496       DECL_INITIAL (current_function_decl) = block_node;
 497       BLOCK_VARS (block_node) = 0;
 498     }
 499   else if (block_node)
 500     {
 501       current_binding_level->blocks
 502         = chainon (current_binding_level->blocks, block_node);
 503     }
 504
 505   /* If we did not make a block for the level just exited, any blocks made for
 506      inner levels (since they cannot be recorded as subblocks in that level)
 507      must be carried forward so they will later become subblocks of something
 508      else.  */
 509   else if (subblock_chain)
 510     current_binding_level->blocks
 511       = chainon (current_binding_level->blocks, subblock_chain);
 512   if (block_node)
 513     TREE_USED (block_node) = 1;
 514
 515   return block_node;
 516 }
 517 \f
 518 /* Insert BLOCK at the end of the list of subblocks of the
 519    current binding level.  This is used when a BIND_EXPR is expanded,
 520    to handle the BLOCK node inside the BIND_EXPR.  */
 521
 522 void
 523 insert_block (tree block)
 524 {
 525   TREE_USED (block) = 1;
 526   current_binding_level->blocks
 527     = chainon (current_binding_level->blocks, block);
 528 }
 529
 530 /* Records a ..._DECL node DECL as belonging to the current lexical scope.
 531    Returns the ..._DECL node.  */
 532
 533 tree
 534 pushdecl (tree decl)
 535 {
 536   /* External objects aren't nested, other objects may be.  */
 537   if ((DECL_EXTERNAL (decl)) || (decl == current_function_decl))
 538     DECL_CONTEXT (decl) = 0;
 539   else
 540     DECL_CONTEXT (decl) = current_function_decl;
 541
 542   /* Put the declaration on the list.  The list of declarations is in reverse
 543      order. The list will be reversed later if necessary.  This needs to be
 544      this way for compatibility with the back-end.  */
 545
 546   TREE_CHAIN (decl) = current_binding_level->names;
 547   current_binding_level->names = decl;
 548
 549   /* For the declaration of a type, set its name if it is not already set.  */
 550
 551   if (TREE_CODE (decl) == TYPE_DECL && TYPE_NAME (TREE_TYPE (decl)) == 0)
 552     {
 553       if (DECL_SOURCE_LINE (decl) == 0)
 554         TYPE_NAME (TREE_TYPE (decl)) = decl;
 555       else
 556         TYPE_NAME (TREE_TYPE (decl)) = DECL_NAME (decl);
 557     }
 558
 559   return decl;
 560 }
 561
 562
 563 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL.  */
 564
 565 tree
 566 pushdecl_top_level (tree x)
 567 {
 568   tree t;
 569   struct binding_level *b = current_binding_level;
 570
 571   current_binding_level = global_binding_level;
 572   t = pushdecl (x);
 573   current_binding_level = b;
 574   return t;
 575 }
 576
 577
 578 /* Clear the binding stack.  */
 579 static void
 580 gfc_clear_binding_stack (void)
 581 {
 582   while (!global_bindings_p ())
 583     poplevel (0, 0, 0);
 584 }
 585
 586
 587 #ifndef CHAR_TYPE_SIZE
 588 #define CHAR_TYPE_SIZE BITS_PER_UNIT
 589 #endif
 590
 591 #ifndef INT_TYPE_SIZE
 592 #define INT_TYPE_SIZE BITS_PER_WORD
 593 #endif
 594
 595 #undef SIZE_TYPE
 596 #define SIZE_TYPE "long unsigned int"
 597
 598 /* Create tree nodes for the basic scalar types of Fortran 95,
 599    and some nodes representing standard constants (0, 1, (void *) 0).
 600    Initialize the global binding level.
 601    Make definitions for built-in primitive functions.  */
 602 static void
 603 gfc_init_decl_processing (void)
 604 {
 605   current_function_decl = NULL;
 606   current_binding_level = NULL_BINDING_LEVEL;
 607   free_binding_level = NULL_BINDING_LEVEL;
 608
 609   /* Make the binding_level structure for global names. We move all
 610      variables that are in a COMMON block to this binding level.  */
 611   pushlevel (0);
 612   global_binding_level = current_binding_level;
 613
 614   /* Build common tree nodes. char_type_node is unsigned because we
 615      only use it for actual characters, not for INTEGER(1). Also, we
 616      want double_type_node to actually have double precision.  */
 617   build_common_tree_nodes (false, false);
 618   set_sizetype (long_unsigned_type_node);
 619   build_common_tree_nodes_2 (0);
 620   void_list_node = build_tree_list (NULL_TREE, void_type_node);
 621
 622   /* Set up F95 type nodes.  */
 623   gfc_init_kinds ();
 624   gfc_init_types ();
 625 }
 626
 627 /* Mark EXP saying that we need to be able to take the
 628    address of it; it should not be allocated in a register.
 629    In Fortran 95 this is only the case for variables with
 630    the TARGET attribute, but we implement it here for a
 631    likely future Cray pointer extension.
 632    Value is 1 if successful.  */
 633 /* TODO: Check/fix mark_addressable.  */
 634 bool
 635 gfc_mark_addressable (tree exp)
 636 {
 637   register tree x = exp;
 638   while (1)
 639     switch (TREE_CODE (x))
 640       {
 641       case COMPONENT_REF:
 642       case ADDR_EXPR:
 643       case ARRAY_REF:
 644       case REALPART_EXPR:
 645       case IMAGPART_EXPR:
 646         x = TREE_OPERAND (x, 0);
 647         break;
 648
 649       case CONSTRUCTOR:
 650         TREE_ADDRESSABLE (x) = 1;
 651         return true;
 652
 653       case VAR_DECL:
 654       case CONST_DECL:
 655       case PARM_DECL:
 656       case RESULT_DECL:
 657         if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x) && DECL_NONLOCAL (x))
 658           {
 659             if (TREE_PUBLIC (x))
 660               {
 661                 error
 662                   ("global register variable %qs used in nested function",
 663                    IDENTIFIER_POINTER (DECL_NAME (x)));
 664                 return false;
 665               }
 666             pedwarn ("register variable %qs used in nested function",
 667                      IDENTIFIER_POINTER (DECL_NAME (x)));
 668           }
 669         else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
 670           {
 671             if (TREE_PUBLIC (x))
 672               {
 673                 error ("address of global register variable %qs requested",
 674                        IDENTIFIER_POINTER (DECL_NAME (x)));
 675                 return true;
 676               }
 677
 678 #if 0
 679             /* If we are making this addressable due to its having
 680                volatile components, give a different error message.  Also
 681                handle the case of an unnamed parameter by not trying
 682                to give the name.  */
 683
 684             else if (C_TYPE_FIELDS_VOLATILE (TREE_TYPE (x)))
 685               {
 686                 error ("cannot put object with volatile field into register");
 687                 return false;
 688               }
 689 #endif
 690
 691             pedwarn ("address of register variable %qs requested",
 692                      IDENTIFIER_POINTER (DECL_NAME (x)));
 693           }
 694
 695         /* drops in */
 696       case FUNCTION_DECL:
 697         TREE_ADDRESSABLE (x) = 1;
 698
 699       default:
 700         return true;
 701       }
 702 }
 703
 704 /* Return the typed-based alias set for T, which may be an expression
 705    or a type.  Return -1 if we don't do anything special.  */
 706
 707 static HOST_WIDE_INT
 708 gfc_get_alias_set (tree t)
 709 {
 710   tree u;
 711
 712   /* Permit type-punning when accessing an EQUIVALENCEd variable or
 713      mixed type entry master's return value.  */
 714   for (u = t; handled_component_p (u); u = TREE_OPERAND (u, 0))
 715     if (TREE_CODE (u) == COMPONENT_REF
 716         && TREE_CODE (TREE_TYPE (TREE_OPERAND (u, 0))) == UNION_TYPE)
 717       return 0;
 718
 719   return -1;
 720 }
 721
 722 /* press the big red button - garbage (ggc) collection is on */
 723
 724 int ggc_p = 1;
 725
 726 /* Builtin function initialization.  */
 727
 728 tree
 729 gfc_builtin_function (tree decl)
 730 {
 731   make_decl_rtl (decl);
 732   pushdecl (decl);
 733   return decl;
 734 }
 735
 736
 737 static void
 738 gfc_define_builtin (const char * name,
 739                     tree type,
 740                     int code,
 741                     const char * library_name,
 742                     bool const_p)
 743 {
 744   tree decl;
 745
 746   decl = add_builtin_function (name, type, code, BUILT_IN_NORMAL,
 747                                library_name, NULL_TREE);
 748   if (const_p)
 749     TREE_READONLY (decl) = 1;
 750
 751   built_in_decls[code] = decl;
 752   implicit_built_in_decls[code] = decl;
 753 }
 754
 755
 756 #define DO_DEFINE_MATH_BUILTIN(code, name, argtype, tbase) \
 757     gfc_define_builtin ("__builtin_" name "l", tbase##longdouble[argtype], \
 758                        BUILT_IN_ ## code ## L, name "l", true); \
 759     gfc_define_builtin ("__builtin_" name, tbase##double[argtype], \
 760                         BUILT_IN_ ## code, name, true); \
 761     gfc_define_builtin ("__builtin_" name "f", tbase##float[argtype], \
 762                         BUILT_IN_ ## code ## F, name "f", true);
 763
 764 #define DEFINE_MATH_BUILTIN(code, name, argtype) \
 765     DO_DEFINE_MATH_BUILTIN (code, name, argtype, mfunc_)
 766
 767 #define DEFINE_MATH_BUILTIN_C(code, name, argtype) \
 768     DO_DEFINE_MATH_BUILTIN (code, name, argtype, mfunc_) \
 769     DO_DEFINE_MATH_BUILTIN (C##code, "c" name, argtype, mfunc_c)
 770
 771
 772 /* Create function types for builtin functions.  */
 773
 774 static void
 775 build_builtin_fntypes (tree * fntype, tree type)
 776 {
 777   tree tmp;
 778
 779   /* type (*) (type) */
 780   tmp = tree_cons (NULL_TREE, type, void_list_node);
 781   fntype[0] = build_function_type (type, tmp);
 782   /* type (*) (type, type) */
 783   tmp = tree_cons (NULL_TREE, type, tmp);
 784   fntype[1] = build_function_type (type, tmp);
 785   /* type (*) (int, type) */
 786   tmp = tree_cons (NULL_TREE, integer_type_node, void_list_node);
 787   tmp = tree_cons (NULL_TREE, type, tmp);
 788   fntype[2] = build_function_type (type, tmp);
 789 }
 790
 791 static tree
 792 builtin_type_for_size (int size, bool unsignedp)
 793 {
 794   tree type = lang_hooks.types.type_for_size (size, unsignedp);
 795   return type ? type : error_mark_node;
 796 }
 797
 798 /* Initialization of builtin function nodes.  */
 799
 800 static void
 801 gfc_init_builtin_functions (void)
 802 {
 803   enum builtin_type
 804   {
 805 #define DEF_PRIMITIVE_TYPE(NAME, VALUE) NAME,
 806 #define DEF_FUNCTION_TYPE_0(NAME, RETURN) NAME,
 807 #define DEF_FUNCTION_TYPE_1(NAME, RETURN, ARG1) NAME,
 808 #define DEF_FUNCTION_TYPE_2(NAME, RETURN, ARG1, ARG2) NAME,
 809 #define DEF_FUNCTION_TYPE_3(NAME, RETURN, ARG1, ARG2, ARG3) NAME,
 810 #define DEF_FUNCTION_TYPE_4(NAME, RETURN, ARG1, ARG2, ARG3, ARG4) NAME,
 811 #define DEF_FUNCTION_TYPE_5(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) NAME,
 812 #define DEF_FUNCTION_TYPE_6(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6) NAME,
 813 #define DEF_FUNCTION_TYPE_7(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6, ARG7) NAME,
 814 #define DEF_FUNCTION_TYPE_VAR_0(NAME, RETURN) NAME,
 815 #define DEF_POINTER_TYPE(NAME, TYPE) NAME,
 816 #include "types.def"
 817 #undef DEF_PRIMITIVE_TYPE
 818 #undef DEF_FUNCTION_TYPE_0
 819 #undef DEF_FUNCTION_TYPE_1
 820 #undef DEF_FUNCTION_TYPE_2
 821 #undef DEF_FUNCTION_TYPE_3
 822 #undef DEF_FUNCTION_TYPE_4
 823 #undef DEF_FUNCTION_TYPE_5
 824 #undef DEF_FUNCTION_TYPE_6
 825 #undef DEF_FUNCTION_TYPE_7
 826 #undef DEF_FUNCTION_TYPE_VAR_0
 827 #undef DEF_POINTER_TYPE
 828     BT_LAST
 829   };
 830   typedef enum builtin_type builtin_type;
 831   enum
 832   {
 833     /* So far we need just these 2 attribute types.  */
 834     ATTR_NOTHROW_LIST,
 835     ATTR_CONST_NOTHROW_LIST
 836   };
 837
 838   tree mfunc_float[3];
 839   tree mfunc_double[3];
 840   tree mfunc_longdouble[3];
 841   tree mfunc_cfloat[3];
 842   tree mfunc_cdouble[3];
 843   tree mfunc_clongdouble[3];
 844   tree func_cfloat_float;
 845   tree func_cdouble_double;
 846   tree func_clongdouble_longdouble;
 847   tree ftype;
 848   tree tmp;
 849   tree builtin_types[(int) BT_LAST + 1];
 850
 851   build_builtin_fntypes (mfunc_float, float_type_node);
 852   build_builtin_fntypes (mfunc_double, double_type_node);
 853   build_builtin_fntypes (mfunc_longdouble, long_double_type_node);
 854   build_builtin_fntypes (mfunc_cfloat, complex_float_type_node);
 855   build_builtin_fntypes (mfunc_cdouble, complex_double_type_node);
 856   build_builtin_fntypes (mfunc_clongdouble, complex_long_double_type_node);
 857
 858   tmp = tree_cons (NULL_TREE, complex_float_type_node, void_list_node);
 859   func_cfloat_float = build_function_type (float_type_node, tmp);
 860
 861   tmp = tree_cons (NULL_TREE, complex_double_type_node, void_list_node);
 862   func_cdouble_double = build_function_type (double_type_node, tmp);
 863
 864   tmp = tree_cons (NULL_TREE, complex_long_double_type_node, void_list_node);
 865   func_clongdouble_longdouble =
 866     build_function_type (long_double_type_node, tmp);
 867
 868 #include "mathbuiltins.def"
 869
 870   /* We define these separately as the fortran versions have different
 871      semantics (they return an integer type) */
 872   gfc_define_builtin ("__builtin_roundl", mfunc_longdouble[0],
 873                       BUILT_IN_ROUNDL, "roundl", true);
 874   gfc_define_builtin ("__builtin_round", mfunc_double[0],
 875                       BUILT_IN_ROUND, "round", true);
 876   gfc_define_builtin ("__builtin_roundf", mfunc_float[0],
 877                       BUILT_IN_ROUNDF, "roundf", true);
 878
 879   gfc_define_builtin ("__builtin_truncl", mfunc_longdouble[0],
 880                       BUILT_IN_TRUNCL, "truncl", true);
 881   gfc_define_builtin ("__builtin_trunc", mfunc_double[0],
 882                       BUILT_IN_TRUNC, "trunc", true);
 883   gfc_define_builtin ("__builtin_truncf", mfunc_float[0],
 884                       BUILT_IN_TRUNCF, "truncf", true);
 885
 886   gfc_define_builtin ("__builtin_cabsl", func_clongdouble_longdouble,
 887                       BUILT_IN_CABSL, "cabsl", true);
 888   gfc_define_builtin ("__builtin_cabs", func_cdouble_double,
 889                       BUILT_IN_CABS, "cabs", true);
 890   gfc_define_builtin ("__builtin_cabsf", func_cfloat_float,
 891                       BUILT_IN_CABSF, "cabsf", true);
 892
 893   gfc_define_builtin ("__builtin_copysignl", mfunc_longdouble[1],
 894                       BUILT_IN_COPYSIGNL, "copysignl", true);
 895   gfc_define_builtin ("__builtin_copysign", mfunc_double[1],
 896                       BUILT_IN_COPYSIGN, "copysign", true);
 897   gfc_define_builtin ("__builtin_copysignf", mfunc_float[1],
 898                       BUILT_IN_COPYSIGNF, "copysignf", true);
 899
 900   gfc_define_builtin ("__builtin_fmodl", mfunc_longdouble[1],
 901                       BUILT_IN_FMODL, "fmodl", true);
 902   gfc_define_builtin ("__builtin_fmod", mfunc_double[1],
 903                       BUILT_IN_FMOD, "fmod", true);
 904   gfc_define_builtin ("__builtin_fmodf", mfunc_float[1],
 905                       BUILT_IN_FMODF, "fmodf", true);
 906
 907   /* These are used to implement the ** operator.  */
 908   gfc_define_builtin ("__builtin_powl", mfunc_longdouble[1],
 909                       BUILT_IN_POWL, "powl", true);
 910   gfc_define_builtin ("__builtin_pow", mfunc_double[1],
 911                       BUILT_IN_POW, "pow", true);
 912   gfc_define_builtin ("__builtin_powf", mfunc_float[1],
 913                       BUILT_IN_POWF, "powf", true);
 914
 915   /* Other builtin functions we use.  */
 916
 917   tmp = tree_cons (NULL_TREE, long_integer_type_node, void_list_node);
 918   tmp = tree_cons (NULL_TREE, long_integer_type_node, tmp);
 919   ftype = build_function_type (long_integer_type_node, tmp);
 920   gfc_define_builtin ("__builtin_expect", ftype, BUILT_IN_EXPECT,
 921                       "__builtin_expect", true);
 922
 923 #define DEF_PRIMITIVE_TYPE(ENUM, VALUE) \
 924   builtin_types[(int) ENUM] = VALUE;
 925 #define DEF_FUNCTION_TYPE_0(ENUM, RETURN)               \
 926   builtin_types[(int) ENUM]                             \
 927     = build_function_type (builtin_types[(int) RETURN], \
 928                            void_list_node);
 929 #define DEF_FUNCTION_TYPE_1(ENUM, RETURN, ARG1)                         \
 930   builtin_types[(int) ENUM]                                             \
 931     = build_function_type (builtin_types[(int) RETURN],                 \
 932                            tree_cons (NULL_TREE,                        \
 933                                       builtin_types[(int) ARG1],        \
 934                                       void_list_node));
 935 #define DEF_FUNCTION_TYPE_2(ENUM, RETURN, ARG1, ARG2)   \
 936   builtin_types[(int) ENUM]                             \
 937     = build_function_type                               \
 938       (builtin_types[(int) RETURN],                     \
 939        tree_cons (NULL_TREE,                            \
 940                   builtin_types[(int) ARG1],            \
 941                   tree_cons (NULL_TREE,                 \
 942                              builtin_types[(int) ARG2], \
 943                              void_list_node)));
 944 #define DEF_FUNCTION_TYPE_3(ENUM, RETURN, ARG1, ARG2, ARG3)              \
 945   builtin_types[(int) ENUM]                                              \
 946     = build_function_type                                                \
 947       (builtin_types[(int) RETURN],                                      \
 948        tree_cons (NULL_TREE,                                             \
 949                   builtin_types[(int) ARG1],                             \
 950                   tree_cons (NULL_TREE,                                  \
 951                              builtin_types[(int) ARG2],                  \
 952                              tree_cons (NULL_TREE,                       \
 953                                         builtin_types[(int) ARG3],       \
 954                                         void_list_node))));
 955 #define DEF_FUNCTION_TYPE_4(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4)       \
 956   builtin_types[(int) ENUM]                                             \
 957     = build_function_type                                               \
 958       (builtin_types[(int) RETURN],                                     \
 959        tree_cons (NULL_TREE,                                            \
 960                   builtin_types[(int) ARG1],                            \
 961                   tree_cons (NULL_TREE,                                 \
 962                              builtin_types[(int) ARG2],                 \
 963                              tree_cons                                  \
 964                              (NULL_TREE,                                \
 965                               builtin_types[(int) ARG3],                \
 966                               tree_cons (NULL_TREE,                     \
 967                                          builtin_types[(int) ARG4],     \
 968                                          void_list_node)))));
 969 #define DEF_FUNCTION_TYPE_5(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) \
 970   builtin_types[(int) ENUM]                                             \
 971     = build_function_type                                               \
 972       (builtin_types[(int) RETURN],                                     \
 973        tree_cons (NULL_TREE,                                            \
 974                   builtin_types[(int) ARG1],                            \
 975                   tree_cons (NULL_TREE,                                 \
 976                              builtin_types[(int) ARG2],                 \
 977                              tree_cons                                  \
 978                              (NULL_TREE,                                \
 979                               builtin_types[(int) ARG3],                \
 980                               tree_cons (NULL_TREE,                     \
 981                                          builtin_types[(int) ARG4],     \
 982                                          tree_cons (NULL_TREE,          \
 983                                               builtin_types[(int) ARG5],\
 984                                               void_list_node))))));
 985 #define DEF_FUNCTION_TYPE_6(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \
 986                             ARG6)                                       \
 987   builtin_types[(int) ENUM]                                             \
 988     = build_function_type                                               \
 989       (builtin_types[(int) RETURN],                                     \
 990        tree_cons (NULL_TREE,                                            \
 991                   builtin_types[(int) ARG1],                            \
 992                   tree_cons (NULL_TREE,                                 \
 993                              builtin_types[(int) ARG2],                 \
 994                              tree_cons                                  \
 995                              (NULL_TREE,                                \
 996                               builtin_types[(int) ARG3],                \
 997                               tree_cons                                 \
 998                               (NULL_TREE,                               \
 999                                builtin_types[(int) ARG4],               \
1000                                tree_cons (NULL_TREE,                    \
1001                                          builtin_types[(int) ARG5],     \
1002                                          tree_cons (NULL_TREE,          \
1003                                               builtin_types[(int) ARG6],\
1004                                               void_list_node)))))));
1005 #define DEF_FUNCTION_TYPE_7(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \
1006                             ARG6, ARG7)                                 \
1007   builtin_types[(int) ENUM]                                             \
1008     = build_function_type                                               \
1009       (builtin_types[(int) RETURN],                                     \
1010        tree_cons (NULL_TREE,                                            \
1011                   builtin_types[(int) ARG1],                            \
1012                   tree_cons (NULL_TREE,                                 \
1013                              builtin_types[(int) ARG2],                 \
1014                              tree_cons                                  \
1015                              (NULL_TREE,                                \
1016                               builtin_types[(int) ARG3],                \
1017                               tree_cons                                 \
1018                               (NULL_TREE,                               \
1019                                builtin_types[(int) ARG4],               \
1020                                tree_cons (NULL_TREE,                    \
1021                                          builtin_types[(int) ARG5],     \
1022                                          tree_cons (NULL_TREE,          \
1023                                               builtin_types[(int) ARG6],\
1024                                          tree_cons (NULL_TREE,          \
1025                                               builtin_types[(int) ARG6], \
1026                                               void_list_node))))))));
1027 #define DEF_FUNCTION_TYPE_VAR_0(ENUM, RETURN)                           \
1028   builtin_types[(int) ENUM]                                             \
1029     = build_function_type (builtin_types[(int) RETURN], NULL_TREE);
1030 #define DEF_POINTER_TYPE(ENUM, TYPE)                    \
1031   builtin_types[(int) ENUM]                             \
1032     = build_pointer_type (builtin_types[(int) TYPE]);
1033 #include "types.def"
1034 #undef DEF_PRIMITIVE_TYPE
1035 #undef DEF_FUNCTION_TYPE_1
1036 #undef DEF_FUNCTION_TYPE_2
1037 #undef DEF_FUNCTION_TYPE_3
1038 #undef DEF_FUNCTION_TYPE_4
1039 #undef DEF_FUNCTION_TYPE_5
1040 #undef DEF_FUNCTION_TYPE_6
1041 #undef DEF_FUNCTION_TYPE_VAR_0
1042 #undef DEF_POINTER_TYPE
1043   builtin_types[(int) BT_LAST] = NULL_TREE;
1044
1045   /* Initialize synchronization builtins.  */
1046 #undef DEF_SYNC_BUILTIN
1047 #define DEF_SYNC_BUILTIN(code, name, type, attr) \
1048     gfc_define_builtin (name, builtin_types[type], code, name, \
1049                         attr == ATTR_CONST_NOTHROW_LIST);
1050 #include "../sync-builtins.def"
1051 #undef DEF_SYNC_BUILTIN
1052
1053   if (gfc_option.flag_openmp)
1054     {
1055 #undef DEF_GOMP_BUILTIN
1056 #define DEF_GOMP_BUILTIN(code, name, type, attr) \
1057       gfc_define_builtin ("__builtin_" name, builtin_types[type], \
1058                           code, name, attr == ATTR_CONST_NOTHROW_LIST);
1059 #include "../omp-builtins.def"
1060 #undef DEF_GOMP_BUILTIN
1061     }
1062
1063   gfc_define_builtin ("__builtin_trap", builtin_types[BT_FN_VOID],
1064                       BUILT_IN_TRAP, NULL, false);
1065   TREE_THIS_VOLATILE (built_in_decls[BUILT_IN_TRAP]) = 1;
1066
1067   build_common_builtin_nodes ();
1068   targetm.init_builtins ();
1069 }
1070
1071 #undef DEFINE_MATH_BUILTIN_C
1072 #undef DEFINE_MATH_BUILTIN
1073
1074 #include "gt-fortran-f95-lang.h"
1075 #include "gtype-fortran.h"