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