gcc/fortran/f95-lang.c

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