gcc/fortran/f95-lang.c

   1 /* gfortran backend interface
   2    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2010
   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 3, 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 COPYING3.  If not see
  20 <http://www.gnu.org/licenses/>.  */
  21
  22 /* f95-lang.c-- GCC backend interface stuff */
  23
  24 /* declare required prototypes: */
  25
  26 #include "config.h"
  27 #include "system.h"
  28 #include "ansidecl.h"
  29 #include "system.h"
  30 #include "coretypes.h"
  31 #include "tree.h"
  32 #include "gimple.h"
  33 #include "flags.h"
  34 #include "langhooks.h"
  35 #include "langhooks-def.h"
  36 #include "timevar.h"
  37 #include "tm.h"
  38 #include "function.h"
  39 #include "ggc.h"
  40 #include "toplev.h"
  41 #include "target.h"
  42 #include "debug.h"
  43 #include "diagnostic.h"
  44 #include "tree-dump.h"
  45 #include "cgraph.h"
  46 #include "gfortran.h"
  47 #include "cpp.h"
  48 #include "trans.h"
  49 #include "trans-types.h"
  50 #include "trans-const.h"
  51
  52 /* Language-dependent contents of an identifier.  */
  53
  54 struct GTY(())
  55 lang_identifier {
  56   struct tree_identifier common;
  57 };
  58
  59 /* The resulting tree type.  */
  60
  61 union GTY((desc ("TREE_CODE (&%h.generic) == IDENTIFIER_NODE"),
  62      chain_next ("CODE_CONTAINS_STRUCT (TREE_CODE (&%h.generic), TS_COMMON) ? ((union lang_tree_node *) TREE_CHAIN (&%h.generic)) : NULL")))
  63
  64 lang_tree_node {
  65   union tree_node GTY((tag ("0"),
  66                        desc ("tree_node_structure (&%h)"))) generic;
  67   struct lang_identifier GTY((tag ("1"))) identifier;
  68 };
  69
  70 /* Save and restore the variables in this file and elsewhere
  71    that keep track of the progress of compilation of the current function.
  72    Used for nested functions.  */
  73
  74 struct GTY(())
  75 language_function {
  76   /* struct gfc_language_function base; */
  77   struct binding_level *binding_level;
  78 };
  79
  80 /* We don't have a lex/yacc lexer/parser, but toplev expects these to
  81    exist anyway.  */
  82 void yyerror (const char *str);
  83 int yylex (void);
  84
  85 static void gfc_init_decl_processing (void);
  86 static void gfc_init_builtin_functions (void);
  87
  88 /* Each front end provides its own.  */
  89 static bool gfc_init (void);
  90 static void gfc_finish (void);
  91 static void gfc_write_global_declarations (void);
  92 static void gfc_print_identifier (FILE *, tree, int);
  93 void do_function_end (void);
  94 bool global_bindings_p (void);
  95 static void clear_binding_stack (void);
  96 static void gfc_be_parse_file (void);
  97 static alias_set_type gfc_get_alias_set (tree);
  98 static void gfc_init_ts (void);
  99
 100 #undef LANG_HOOKS_NAME
 101 #undef LANG_HOOKS_INIT
 102 #undef LANG_HOOKS_FINISH
 103 #undef LANG_HOOKS_WRITE_GLOBALS
 104 #undef LANG_HOOKS_OPTION_LANG_MASK
 105 #undef LANG_HOOKS_INIT_OPTIONS_STRUCT
 106 #undef LANG_HOOKS_INIT_OPTIONS
 107 #undef LANG_HOOKS_HANDLE_OPTION
 108 #undef LANG_HOOKS_POST_OPTIONS
 109 #undef LANG_HOOKS_PRINT_IDENTIFIER
 110 #undef LANG_HOOKS_PARSE_FILE
 111 #undef LANG_HOOKS_MARK_ADDRESSABLE
 112 #undef LANG_HOOKS_TYPE_FOR_MODE
 113 #undef LANG_HOOKS_TYPE_FOR_SIZE
 114 #undef LANG_HOOKS_GET_ALIAS_SET
 115 #undef LANG_HOOKS_INIT_TS
 116 #undef LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE
 117 #undef LANG_HOOKS_OMP_PREDETERMINED_SHARING
 118 #undef LANG_HOOKS_OMP_REPORT_DECL
 119 #undef LANG_HOOKS_OMP_CLAUSE_DEFAULT_CTOR
 120 #undef LANG_HOOKS_OMP_CLAUSE_COPY_CTOR
 121 #undef LANG_HOOKS_OMP_CLAUSE_ASSIGN_OP
 122 #undef LANG_HOOKS_OMP_CLAUSE_DTOR
 123 #undef LANG_HOOKS_OMP_DISREGARD_VALUE_EXPR
 124 #undef LANG_HOOKS_OMP_PRIVATE_DEBUG_CLAUSE
 125 #undef LANG_HOOKS_OMP_PRIVATE_OUTER_REF
 126 #undef LANG_HOOKS_OMP_FIRSTPRIVATIZE_TYPE_SIZES
 127 #undef LANG_HOOKS_BUILTIN_FUNCTION
 128 #undef LANG_HOOKS_GET_ARRAY_DESCR_INFO
 129
 130 /* Define lang hooks.  */
 131 #define LANG_HOOKS_NAME                 "GNU Fortran"
 132 #define LANG_HOOKS_INIT                 gfc_init
 133 #define LANG_HOOKS_FINISH               gfc_finish
 134 #define LANG_HOOKS_WRITE_GLOBALS        gfc_write_global_declarations
 135 #define LANG_HOOKS_OPTION_LANG_MASK     gfc_option_lang_mask
 136 #define LANG_HOOKS_INIT_OPTIONS_STRUCT  gfc_init_options_struct
 137 #define LANG_HOOKS_INIT_OPTIONS         gfc_init_options
 138 #define LANG_HOOKS_HANDLE_OPTION        gfc_handle_option
 139 #define LANG_HOOKS_POST_OPTIONS         gfc_post_options
 140 #define LANG_HOOKS_PRINT_IDENTIFIER     gfc_print_identifier
 141 #define LANG_HOOKS_PARSE_FILE           gfc_be_parse_file
 142 #define LANG_HOOKS_TYPE_FOR_MODE        gfc_type_for_mode
 143 #define LANG_HOOKS_TYPE_FOR_SIZE        gfc_type_for_size
 144 #define LANG_HOOKS_GET_ALIAS_SET        gfc_get_alias_set
 145 #define LANG_HOOKS_INIT_TS              gfc_init_ts
 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_REPORT_DECL              gfc_omp_report_decl
 149 #define LANG_HOOKS_OMP_CLAUSE_DEFAULT_CTOR      gfc_omp_clause_default_ctor
 150 #define LANG_HOOKS_OMP_CLAUSE_COPY_CTOR         gfc_omp_clause_copy_ctor
 151 #define LANG_HOOKS_OMP_CLAUSE_ASSIGN_OP         gfc_omp_clause_assign_op
 152 #define LANG_HOOKS_OMP_CLAUSE_DTOR              gfc_omp_clause_dtor
 153 #define LANG_HOOKS_OMP_DISREGARD_VALUE_EXPR     gfc_omp_disregard_value_expr
 154 #define LANG_HOOKS_OMP_PRIVATE_DEBUG_CLAUSE     gfc_omp_private_debug_clause
 155 #define LANG_HOOKS_OMP_PRIVATE_OUTER_REF        gfc_omp_private_outer_ref
 156 #define LANG_HOOKS_OMP_FIRSTPRIVATIZE_TYPE_SIZES \
 157   gfc_omp_firstprivatize_type_sizes
 158 #define LANG_HOOKS_BUILTIN_FUNCTION          gfc_builtin_function
 159 #define LANG_HOOKS_GET_ARRAY_DESCR_INFO      gfc_get_array_descr_info
 160
 161 struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
 162
 163 #define NULL_BINDING_LEVEL (struct binding_level *) NULL
 164
 165 /* A chain of binding_level structures awaiting reuse.  */
 166
 167 static GTY(()) struct binding_level *free_binding_level;
 168
 169 /* The elements of `ridpointers' are identifier nodes
 170    for the reserved type names and storage classes.
 171    It is indexed by a RID_... value.  */
 172 tree *ridpointers = NULL;
 173
 174 /* True means we've initialized exception handling.  */
 175 bool gfc_eh_initialized_p;
 176
 177 /* The current translation unit.  */
 178 static GTY(()) tree current_translation_unit;
 179
 180
 181 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
 182    or validate its data type for an `if' or `while' statement or ?..: exp.
 183
 184    This preparation consists of taking the ordinary
 185    representation of an expression expr and producing a valid tree
 186    boolean expression describing whether expr is nonzero.  We could
 187    simply always do build_binary_op (NE_EXPR, expr, boolean_false_node, 1),
 188    but we optimize comparisons, &&, ||, and !.
 189
 190    The resulting type should always be `boolean_type_node'.
 191    This is much simpler than the corresponding C version because we have a
 192    distinct boolean type.  */
 193
 194 tree
 195 gfc_truthvalue_conversion (tree expr)
 196 {
 197   switch (TREE_CODE (TREE_TYPE (expr)))
 198     {
 199     case BOOLEAN_TYPE:
 200       if (TREE_TYPE (expr) == boolean_type_node)
 201         return expr;
 202       else if (COMPARISON_CLASS_P (expr))
 203         {
 204           TREE_TYPE (expr) = boolean_type_node;
 205           return expr;
 206         }
 207       else if (TREE_CODE (expr) == NOP_EXPR)
 208         return fold_build1_loc (input_location, NOP_EXPR,
 209                             boolean_type_node, TREE_OPERAND (expr, 0));
 210       else
 211         return fold_build1_loc (input_location, NOP_EXPR, boolean_type_node,
 212                                 expr);
 213
 214     case INTEGER_TYPE:
 215       if (TREE_CODE (expr) == INTEGER_CST)
 216         return integer_zerop (expr) ? boolean_false_node : boolean_true_node;
 217       else
 218         return fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
 219                                 expr, build_int_cst (TREE_TYPE (expr), 0));
 220
 221     default:
 222       internal_error ("Unexpected type in truthvalue_conversion");
 223     }
 224 }
 225
 226
 227 static void
 228 gfc_create_decls (void)
 229 {
 230   /* GCC builtins.  */
 231   gfc_init_builtin_functions ();
 232
 233   /* Runtime/IO library functions.  */
 234   gfc_build_builtin_function_decls ();
 235
 236   gfc_init_constants ();
 237
 238   /* Build our translation-unit decl.  */
 239   current_translation_unit = build_translation_unit_decl (NULL_TREE);
 240 }
 241
 242
 243 static void
 244 gfc_be_parse_file (void)
 245 {
 246   int errors;
 247   int warnings;
 248
 249   gfc_create_decls ();
 250   gfc_parse_file ();
 251   gfc_generate_constructors ();
 252
 253   /* Tell the frontend about any errors.  */
 254   gfc_get_errors (&warnings, &errors);
 255   errorcount += errors;
 256   warningcount += warnings;
 257
 258   clear_binding_stack ();
 259 }
 260
 261
 262 /* Initialize everything.  */
 263
 264 static bool
 265 gfc_init (void)
 266 {
 267   if (!gfc_cpp_enabled ())
 268     {
 269       linemap_add (line_table, LC_ENTER, false, gfc_source_file, 1);
 270       linemap_add (line_table, LC_RENAME, false, "<built-in>", 0);
 271     }
 272   else
 273     gfc_cpp_init_0 ();
 274
 275   gfc_init_decl_processing ();
 276   gfc_static_ctors = NULL_TREE;
 277
 278   if (gfc_cpp_enabled ())
 279     gfc_cpp_init ();
 280
 281   gfc_init_1 ();
 282
 283   if (gfc_new_file () != SUCCESS)
 284     fatal_error ("can't open input file: %s", gfc_source_file);
 285
 286   return true;
 287 }
 288
 289
 290 static void
 291 gfc_finish (void)
 292 {
 293   gfc_cpp_done ();
 294   gfc_done_1 ();
 295   gfc_release_include_path ();
 296   return;
 297 }
 298
 299 /* ??? This is something of a hack.
 300
 301    Emulated tls lowering needs to see all TLS variables before we call
 302    cgraph_finalize_compilation_unit.  The C/C++ front ends manage this
 303    by calling decl_rest_of_compilation on each global and static variable
 304    as they are seen.  The Fortran front end waits until this hook.
 305
 306    A Correct solution is for cgraph_finalize_compilation_unit not to be
 307    called during the WRITE_GLOBALS langhook, and have that hook only do what
 308    its name suggests and write out globals.  But the C++ and Java front ends
 309    have (unspecified) problems with aliases that gets in the way.  It has
 310    been suggested that these problems would be solved by completing the
 311    conversion to cgraph-based aliases.  */
 312
 313 static void
 314 gfc_write_global_declarations (void)
 315 {
 316   tree decl;
 317
 318   /* Finalize all of the globals.  */
 319   for (decl = getdecls(); decl ; decl = DECL_CHAIN (decl))
 320     rest_of_decl_compilation (decl, true, true);
 321
 322   write_global_declarations ();
 323 }
 324
 325
 326 static void
 327 gfc_print_identifier (FILE * file ATTRIBUTE_UNUSED,
 328                       tree node ATTRIBUTE_UNUSED,
 329                       int indent ATTRIBUTE_UNUSED)
 330 {
 331   return;
 332 }
 333
 334
 335 /* These functions and variables deal with binding contours.  We only
 336    need these functions for the list of PARM_DECLs, but we leave the
 337    functions more general; these are a simplified version of the
 338    functions from GNAT.  */
 339
 340 /* For each binding contour we allocate a binding_level structure which
 341    records the entities defined or declared in that contour.  Contours
 342    include:
 343
 344         the global one
 345         one for each subprogram definition
 346         one for each compound statement (declare block)
 347
 348    Binding contours are used to create GCC tree BLOCK nodes.  */
 349
 350 struct GTY(())
 351 binding_level {
 352   /* A chain of ..._DECL nodes for all variables, constants, functions,
 353      parameters and type declarations.  These ..._DECL nodes are chained
 354      through the DECL_CHAIN field. Note that these ..._DECL nodes are stored
 355      in the reverse of the order supplied to be compatible with the
 356      back-end.  */
 357   tree names;
 358   /* For each level (except the global one), a chain of BLOCK nodes for all
 359      the levels that were entered and exited one level down from this one.  */
 360   tree blocks;
 361   /* The binding level containing this one (the enclosing binding level).  */
 362   struct binding_level *level_chain;
 363 };
 364
 365 /* The binding level currently in effect.  */
 366 static GTY(()) struct binding_level *current_binding_level = NULL;
 367
 368 /* The outermost binding level. This binding level is created when the
 369    compiler is started and it will exist through the entire compilation.  */
 370 static GTY(()) struct binding_level *global_binding_level;
 371
 372 /* Binding level structures are initialized by copying this one.  */
 373 static struct binding_level clear_binding_level = { NULL, NULL, NULL };
 374
 375
 376 /* Return true if we are in the global binding level.  */
 377
 378 bool
 379 global_bindings_p (void)
 380 {
 381   return current_binding_level == global_binding_level;
 382 }
 383
 384 tree
 385 getdecls (void)
 386 {
 387   return current_binding_level->names;
 388 }
 389
 390 /* Enter a new binding level. The input parameter is ignored, but has to be
 391    specified for back-end compatibility.  */
 392
 393 void
 394 pushlevel (int ignore ATTRIBUTE_UNUSED)
 395 {
 396   struct binding_level *newlevel = ggc_alloc_binding_level ();
 397
 398   *newlevel = clear_binding_level;
 399
 400   /* Add this level to the front of the chain (stack) of levels that are
 401      active.  */
 402   newlevel->level_chain = current_binding_level;
 403   current_binding_level = newlevel;
 404 }
 405
 406 /* Exit a binding level.
 407    Pop the level off, and restore the state of the identifier-decl mappings
 408    that were in effect when this level was entered.
 409
 410    If KEEP is nonzero, this level had explicit declarations, so
 411    and create a "block" (a BLOCK node) for the level
 412    to record its declarations and subblocks for symbol table output.
 413
 414    If FUNCTIONBODY is nonzero, this level is the body of a function,
 415    so create a block as if KEEP were set and also clear out all
 416    label names.
 417
 418    If REVERSE is nonzero, reverse the order of decls before putting
 419    them into the BLOCK.  */
 420
 421 tree
 422 poplevel (int keep, int reverse, int functionbody)
 423 {
 424   /* Points to a BLOCK tree node. This is the BLOCK node constructed for the
 425      binding level that we are about to exit and which is returned by this
 426      routine.  */
 427   tree block_node = NULL_TREE;
 428   tree decl_chain;
 429   tree subblock_chain = current_binding_level->blocks;
 430   tree subblock_node;
 431
 432   /* Reverse the list of XXXX_DECL nodes if desired.  Note that the ..._DECL
 433      nodes chained through the `names' field of current_binding_level are in
 434      reverse order except for PARM_DECL node, which are explicitly stored in
 435      the right order.  */
 436   decl_chain = (reverse) ? nreverse (current_binding_level->names)
 437                          : current_binding_level->names;
 438
 439   /* If there were any declarations in the current binding level, or if this
 440      binding level is a function body, or if there are any nested blocks then
 441      create a BLOCK node to record them for the life of this function.  */
 442   if (keep || functionbody)
 443     block_node = build_block (keep ? decl_chain : 0, subblock_chain, 0, 0);
 444
 445   /* Record the BLOCK node just built as the subblock its enclosing scope.  */
 446   for (subblock_node = subblock_chain; subblock_node;
 447        subblock_node = BLOCK_CHAIN (subblock_node))
 448     BLOCK_SUPERCONTEXT (subblock_node) = block_node;
 449
 450   /* Clear out the meanings of the local variables of this level.  */
 451
 452   for (subblock_node = decl_chain; subblock_node;
 453        subblock_node = DECL_CHAIN (subblock_node))
 454     if (DECL_NAME (subblock_node) != 0)
 455       /* If the identifier was used or addressed via a local extern decl,
 456          don't forget that fact.  */
 457       if (DECL_EXTERNAL (subblock_node))
 458         {
 459           if (TREE_USED (subblock_node))
 460             TREE_USED (DECL_NAME (subblock_node)) = 1;
 461           if (TREE_ADDRESSABLE (subblock_node))
 462             TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (subblock_node)) = 1;
 463         }
 464
 465   /* Pop the current level.  */
 466   current_binding_level = current_binding_level->level_chain;
 467
 468   if (functionbody)
 469     /* This is the top level block of a function. */
 470     DECL_INITIAL (current_function_decl) = block_node;
 471   else if (current_binding_level == global_binding_level)
 472     /* When using gfc_start_block/gfc_finish_block from middle-end hooks,
 473        don't add newly created BLOCKs as subblocks of global_binding_level.  */
 474     ;
 475   else if (block_node)
 476     {
 477       current_binding_level->blocks
 478         = block_chainon (current_binding_level->blocks, block_node);
 479     }
 480
 481   /* If we did not make a block for the level just exited, any blocks made for
 482      inner levels (since they cannot be recorded as subblocks in that level)
 483      must be carried forward so they will later become subblocks of something
 484      else.  */
 485   else if (subblock_chain)
 486     current_binding_level->blocks
 487       = block_chainon (current_binding_level->blocks, subblock_chain);
 488   if (block_node)
 489     TREE_USED (block_node) = 1;
 490
 491   return block_node;
 492 }
 493
 494
 495 /* Records a ..._DECL node DECL as belonging to the current lexical scope.
 496    Returns the ..._DECL node.  */
 497
 498 tree
 499 pushdecl (tree decl)
 500 {
 501   if (global_bindings_p ())
 502     DECL_CONTEXT (decl) = current_translation_unit;
 503   else
 504     {
 505       /* External objects aren't nested.  For debug info insert a copy
 506          of the decl into the binding level.  */
 507       if (DECL_EXTERNAL (decl))
 508         {
 509           tree orig = decl;
 510           decl = copy_node (decl);
 511           DECL_CONTEXT (orig) = NULL_TREE;
 512         }
 513       DECL_CONTEXT (decl) = current_function_decl;
 514     }
 515
 516   /* Put the declaration on the list.  The list of declarations is in reverse
 517      order. The list will be reversed later if necessary.  This needs to be
 518      this way for compatibility with the back-end.  */
 519
 520   DECL_CHAIN (decl) = current_binding_level->names;
 521   current_binding_level->names = decl;
 522
 523   /* For the declaration of a type, set its name if it is not already set.  */
 524
 525   if (TREE_CODE (decl) == TYPE_DECL && TYPE_NAME (TREE_TYPE (decl)) == 0)
 526     {
 527       if (DECL_SOURCE_LINE (decl) == 0)
 528         TYPE_NAME (TREE_TYPE (decl)) = decl;
 529       else
 530         TYPE_NAME (TREE_TYPE (decl)) = DECL_NAME (decl);
 531     }
 532
 533   return decl;
 534 }
 535
 536
 537 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL.  */
 538
 539 tree
 540 pushdecl_top_level (tree x)
 541 {
 542   tree t;
 543   struct binding_level *b = current_binding_level;
 544
 545   current_binding_level = global_binding_level;
 546   t = pushdecl (x);
 547   current_binding_level = b;
 548   return t;
 549 }
 550
 551
 552 /* Clear the binding stack.  */
 553 static void
 554 clear_binding_stack (void)
 555 {
 556   while (!global_bindings_p ())
 557     poplevel (0, 0, 0);
 558 }
 559
 560
 561 #ifndef CHAR_TYPE_SIZE
 562 #define CHAR_TYPE_SIZE BITS_PER_UNIT
 563 #endif
 564
 565 #ifndef INT_TYPE_SIZE
 566 #define INT_TYPE_SIZE BITS_PER_WORD
 567 #endif
 568
 569 #undef SIZE_TYPE
 570 #define SIZE_TYPE "long unsigned int"
 571
 572 /* Create tree nodes for the basic scalar types of Fortran 95,
 573    and some nodes representing standard constants (0, 1, (void *) 0).
 574    Initialize the global binding level.
 575    Make definitions for built-in primitive functions.  */
 576 static void
 577 gfc_init_decl_processing (void)
 578 {
 579   current_function_decl = NULL;
 580   current_binding_level = NULL_BINDING_LEVEL;
 581   free_binding_level = NULL_BINDING_LEVEL;
 582
 583   /* Make the binding_level structure for global names. We move all
 584      variables that are in a COMMON block to this binding level.  */
 585   pushlevel (0);
 586   global_binding_level = current_binding_level;
 587
 588   /* Build common tree nodes. char_type_node is unsigned because we
 589      only use it for actual characters, not for INTEGER(1). Also, we
 590      want double_type_node to actually have double precision.  */
 591   build_common_tree_nodes (false, false);
 592
 593   void_list_node = build_tree_list (NULL_TREE, void_type_node);
 594
 595   /* Set up F95 type nodes.  */
 596   gfc_init_kinds ();
 597   gfc_init_types ();
 598 }
 599
 600
 601 /* Return the typed-based alias set for T, which may be an expression
 602    or a type.  Return -1 if we don't do anything special.  */
 603
 604 static alias_set_type
 605 gfc_get_alias_set (tree t)
 606 {
 607   tree u;
 608
 609   /* Permit type-punning when accessing an EQUIVALENCEd variable or
 610      mixed type entry master's return value.  */
 611   for (u = t; handled_component_p (u); u = TREE_OPERAND (u, 0))
 612     if (TREE_CODE (u) == COMPONENT_REF
 613         && TREE_CODE (TREE_TYPE (TREE_OPERAND (u, 0))) == UNION_TYPE)
 614       return 0;
 615
 616   return -1;
 617 }
 618
 619
 620 /* press the big red button - garbage (ggc) collection is on */
 621
 622 int ggc_p = 1;
 623
 624 /* Builtin function initialization.  */
 625
 626 tree
 627 gfc_builtin_function (tree decl)
 628 {
 629   make_decl_rtl (decl);
 630   pushdecl (decl);
 631   return decl;
 632 }
 633
 634 /* So far we need just these 4 attribute types.  */
 635 #define ATTR_NOTHROW_LEAF_LIST          (ECF_NOTHROW | ECF_LEAF)
 636 #define ATTR_CONST_NOTHROW_LEAF_LIST    (ECF_NOTHROW | ECF_LEAF | ECF_CONST)
 637 #define ATTR_NOTHROW_LIST               (ECF_NOTHROW)
 638 #define ATTR_CONST_NOTHROW_LIST         (ECF_NOTHROW | ECF_CONST)
 639
 640 static void
 641 gfc_define_builtin (const char *name, tree type, int code,
 642                     const char *library_name, int attr)
 643 {
 644   tree decl;
 645
 646   decl = add_builtin_function (name, type, code, BUILT_IN_NORMAL,
 647                                library_name, NULL_TREE);
 648   if (attr & ECF_CONST)
 649     TREE_READONLY (decl) = 1;
 650   if (attr & ECF_NOTHROW)
 651     TREE_NOTHROW (decl) = 1;
 652   if (attr & ECF_LEAF)
 653     DECL_ATTRIBUTES (decl) = tree_cons (get_identifier ("leaf"),
 654                                         NULL, DECL_ATTRIBUTES (decl));
 655
 656   built_in_decls[code] = decl;
 657   implicit_built_in_decls[code] = decl;
 658 }
 659
 660
 661 #define DO_DEFINE_MATH_BUILTIN(code, name, argtype, tbase) \
 662     gfc_define_builtin ("__builtin_" name "l", tbase##longdouble[argtype], \
 663                         BUILT_IN_ ## code ## L, name "l", \
 664                         ATTR_CONST_NOTHROW_LEAF_LIST); \
 665     gfc_define_builtin ("__builtin_" name, tbase##double[argtype], \
 666                         BUILT_IN_ ## code, name, \
 667                         ATTR_CONST_NOTHROW_LEAF_LIST); \
 668     gfc_define_builtin ("__builtin_" name "f", tbase##float[argtype], \
 669                         BUILT_IN_ ## code ## F, name "f", \
 670                         ATTR_CONST_NOTHROW_LEAF_LIST);
 671
 672 #define DEFINE_MATH_BUILTIN(code, name, argtype) \
 673     DO_DEFINE_MATH_BUILTIN (code, name, argtype, mfunc_)
 674
 675 #define DEFINE_MATH_BUILTIN_C(code, name, argtype) \
 676     DO_DEFINE_MATH_BUILTIN (code, name, argtype, mfunc_) \
 677     DO_DEFINE_MATH_BUILTIN (C##code, "c" name, argtype, mfunc_c)
 678
 679
 680 /* Create function types for builtin functions.  */
 681
 682 static void
 683 build_builtin_fntypes (tree *fntype, tree type)
 684 {
 685   /* type (*) (type) */
 686   fntype[0] = build_function_type_list (type, type, NULL_TREE);
 687   /* type (*) (type, type) */
 688   fntype[1] = build_function_type_list (type, type, type, NULL_TREE);
 689   /* type (*) (type, int) */
 690   fntype[2] = build_function_type_list (type,
 691                                         type, integer_type_node, NULL_TREE);
 692   /* type (*) (void) */
 693   fntype[3] = build_function_type_list (type, NULL_TREE);
 694   /* type (*) (type, &int) */
 695   fntype[4] = build_function_type_list (type, type,
 696                                         build_pointer_type (integer_type_node),
 697                                         NULL_TREE);
 698   /* type (*) (int, type) */
 699   fntype[5] = build_function_type_list (type,
 700                                         integer_type_node, type, NULL_TREE);
 701 }
 702
 703
 704 static tree
 705 builtin_type_for_size (int size, bool unsignedp)
 706 {
 707   tree type = lang_hooks.types.type_for_size (size, unsignedp);
 708   return type ? type : error_mark_node;
 709 }
 710
 711 /* Initialization of builtin function nodes.  */
 712
 713 static void
 714 gfc_init_builtin_functions (void)
 715 {
 716   enum builtin_type
 717   {
 718 #define DEF_PRIMITIVE_TYPE(NAME, VALUE) NAME,
 719 #define DEF_FUNCTION_TYPE_0(NAME, RETURN) NAME,
 720 #define DEF_FUNCTION_TYPE_1(NAME, RETURN, ARG1) NAME,
 721 #define DEF_FUNCTION_TYPE_2(NAME, RETURN, ARG1, ARG2) NAME,
 722 #define DEF_FUNCTION_TYPE_3(NAME, RETURN, ARG1, ARG2, ARG3) NAME,
 723 #define DEF_FUNCTION_TYPE_4(NAME, RETURN, ARG1, ARG2, ARG3, ARG4) NAME,
 724 #define DEF_FUNCTION_TYPE_5(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) NAME,
 725 #define DEF_FUNCTION_TYPE_6(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6) NAME,
 726 #define DEF_FUNCTION_TYPE_7(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6, ARG7) NAME,
 727 #define DEF_FUNCTION_TYPE_VAR_0(NAME, RETURN) NAME,
 728 #define DEF_POINTER_TYPE(NAME, TYPE) NAME,
 729 #include "types.def"
 730 #undef DEF_PRIMITIVE_TYPE
 731 #undef DEF_FUNCTION_TYPE_0
 732 #undef DEF_FUNCTION_TYPE_1
 733 #undef DEF_FUNCTION_TYPE_2
 734 #undef DEF_FUNCTION_TYPE_3
 735 #undef DEF_FUNCTION_TYPE_4
 736 #undef DEF_FUNCTION_TYPE_5
 737 #undef DEF_FUNCTION_TYPE_6
 738 #undef DEF_FUNCTION_TYPE_7
 739 #undef DEF_FUNCTION_TYPE_VAR_0
 740 #undef DEF_POINTER_TYPE
 741     BT_LAST
 742   };
 743   typedef enum builtin_type builtin_type;
 744
 745   tree mfunc_float[6];
 746   tree mfunc_double[6];
 747   tree mfunc_longdouble[6];
 748   tree mfunc_cfloat[6];
 749   tree mfunc_cdouble[6];
 750   tree mfunc_clongdouble[6];
 751   tree func_cfloat_float, func_float_cfloat;
 752   tree func_cdouble_double, func_double_cdouble;
 753   tree func_clongdouble_longdouble, func_longdouble_clongdouble;
 754   tree func_float_floatp_floatp;
 755   tree func_double_doublep_doublep;
 756   tree func_longdouble_longdoublep_longdoublep;
 757   tree ftype, ptype;
 758   tree builtin_types[(int) BT_LAST + 1];
 759
 760   build_builtin_fntypes (mfunc_float, float_type_node);
 761   build_builtin_fntypes (mfunc_double, double_type_node);
 762   build_builtin_fntypes (mfunc_longdouble, long_double_type_node);
 763   build_builtin_fntypes (mfunc_cfloat, complex_float_type_node);
 764   build_builtin_fntypes (mfunc_cdouble, complex_double_type_node);
 765   build_builtin_fntypes (mfunc_clongdouble, complex_long_double_type_node);
 766
 767   func_cfloat_float = build_function_type_list (float_type_node,
 768                                                 complex_float_type_node,
 769                                                 NULL_TREE);
 770
 771   func_float_cfloat = build_function_type_list (complex_float_type_node,
 772                                                 float_type_node, NULL_TREE);
 773
 774   func_cdouble_double = build_function_type_list (double_type_node,
 775                                                   complex_double_type_node,
 776                                                   NULL_TREE);
 777
 778   func_double_cdouble = build_function_type_list (complex_double_type_node,
 779                                                   double_type_node, NULL_TREE);
 780
 781   func_clongdouble_longdouble =
 782     build_function_type_list (long_double_type_node,
 783                               complex_long_double_type_node, NULL_TREE);
 784
 785   func_longdouble_clongdouble =
 786     build_function_type_list (complex_long_double_type_node,
 787                               long_double_type_node, NULL_TREE);
 788
 789   ptype = build_pointer_type (float_type_node);
 790   func_float_floatp_floatp =
 791     build_function_type_list (void_type_node, ptype, ptype, NULL_TREE);
 792
 793   ptype = build_pointer_type (double_type_node);
 794   func_double_doublep_doublep =
 795     build_function_type_list (void_type_node, ptype, ptype, NULL_TREE);
 796
 797   ptype = build_pointer_type (long_double_type_node);
 798   func_longdouble_longdoublep_longdoublep =
 799     build_function_type_list (void_type_node, ptype, ptype, NULL_TREE);
 800
 801 /* Non-math builtins are defined manually, so they're not included here.  */
 802 #define OTHER_BUILTIN(ID,NAME,TYPE,CONST)
 803
 804 #include "mathbuiltins.def"
 805
 806   gfc_define_builtin ("__builtin_roundl", mfunc_longdouble[0],
 807                       BUILT_IN_ROUNDL, "roundl", ATTR_CONST_NOTHROW_LEAF_LIST);
 808   gfc_define_builtin ("__builtin_round", mfunc_double[0],
 809                       BUILT_IN_ROUND, "round", ATTR_CONST_NOTHROW_LEAF_LIST);
 810   gfc_define_builtin ("__builtin_roundf", mfunc_float[0],
 811                       BUILT_IN_ROUNDF, "roundf", ATTR_CONST_NOTHROW_LEAF_LIST);
 812
 813   gfc_define_builtin ("__builtin_truncl", mfunc_longdouble[0],
 814                       BUILT_IN_TRUNCL, "truncl", ATTR_CONST_NOTHROW_LEAF_LIST);
 815   gfc_define_builtin ("__builtin_trunc", mfunc_double[0],
 816                       BUILT_IN_TRUNC, "trunc", ATTR_CONST_NOTHROW_LEAF_LIST);
 817   gfc_define_builtin ("__builtin_truncf", mfunc_float[0],
 818                       BUILT_IN_TRUNCF, "truncf", ATTR_CONST_NOTHROW_LEAF_LIST);
 819
 820   gfc_define_builtin ("__builtin_cabsl", func_clongdouble_longdouble,
 821                       BUILT_IN_CABSL, "cabsl", ATTR_CONST_NOTHROW_LEAF_LIST);
 822   gfc_define_builtin ("__builtin_cabs", func_cdouble_double,
 823                       BUILT_IN_CABS, "cabs", ATTR_CONST_NOTHROW_LEAF_LIST);
 824   gfc_define_builtin ("__builtin_cabsf", func_cfloat_float,
 825                       BUILT_IN_CABSF, "cabsf", ATTR_CONST_NOTHROW_LEAF_LIST);
 826
 827   gfc_define_builtin ("__builtin_copysignl", mfunc_longdouble[1],
 828                       BUILT_IN_COPYSIGNL, "copysignl",
 829                       ATTR_CONST_NOTHROW_LEAF_LIST);
 830   gfc_define_builtin ("__builtin_copysign", mfunc_double[1],
 831                       BUILT_IN_COPYSIGN, "copysign",
 832                       ATTR_CONST_NOTHROW_LEAF_LIST);
 833   gfc_define_builtin ("__builtin_copysignf", mfunc_float[1],
 834                       BUILT_IN_COPYSIGNF, "copysignf",
 835                       ATTR_CONST_NOTHROW_LEAF_LIST);
 836
 837   gfc_define_builtin ("__builtin_nextafterl", mfunc_longdouble[1],
 838                       BUILT_IN_NEXTAFTERL, "nextafterl",
 839                       ATTR_CONST_NOTHROW_LEAF_LIST);
 840   gfc_define_builtin ("__builtin_nextafter", mfunc_double[1],
 841                       BUILT_IN_NEXTAFTER, "nextafter",
 842                       ATTR_CONST_NOTHROW_LEAF_LIST);
 843   gfc_define_builtin ("__builtin_nextafterf", mfunc_float[1],
 844                       BUILT_IN_NEXTAFTERF, "nextafterf",
 845                       ATTR_CONST_NOTHROW_LEAF_LIST);
 846
 847   gfc_define_builtin ("__builtin_frexpl", mfunc_longdouble[4],
 848                       BUILT_IN_FREXPL, "frexpl", ATTR_NOTHROW_LEAF_LIST);
 849   gfc_define_builtin ("__builtin_frexp", mfunc_double[4],
 850                       BUILT_IN_FREXP, "frexp", ATTR_NOTHROW_LEAF_LIST);
 851   gfc_define_builtin ("__builtin_frexpf", mfunc_float[4],
 852                       BUILT_IN_FREXPF, "frexpf", ATTR_NOTHROW_LEAF_LIST);
 853
 854   gfc_define_builtin ("__builtin_fabsl", mfunc_longdouble[0],
 855                       BUILT_IN_FABSL, "fabsl", ATTR_CONST_NOTHROW_LEAF_LIST);
 856   gfc_define_builtin ("__builtin_fabs", mfunc_double[0],
 857                       BUILT_IN_FABS, "fabs", ATTR_CONST_NOTHROW_LEAF_LIST);
 858   gfc_define_builtin ("__builtin_fabsf", mfunc_float[0],
 859                       BUILT_IN_FABSF, "fabsf", ATTR_CONST_NOTHROW_LEAF_LIST);
 860
 861   gfc_define_builtin ("__builtin_scalbnl", mfunc_longdouble[5],
 862                       BUILT_IN_SCALBNL, "scalbnl", ATTR_CONST_NOTHROW_LEAF_LIST);
 863   gfc_define_builtin ("__builtin_scalbn", mfunc_double[5],
 864                       BUILT_IN_SCALBN, "scalbn", ATTR_CONST_NOTHROW_LEAF_LIST);
 865   gfc_define_builtin ("__builtin_scalbnf", mfunc_float[5],
 866                       BUILT_IN_SCALBNF, "scalbnf", ATTR_CONST_NOTHROW_LEAF_LIST);
 867
 868   gfc_define_builtin ("__builtin_fmodl", mfunc_longdouble[1],
 869                       BUILT_IN_FMODL, "fmodl", ATTR_CONST_NOTHROW_LEAF_LIST);
 870   gfc_define_builtin ("__builtin_fmod", mfunc_double[1],
 871                       BUILT_IN_FMOD, "fmod", ATTR_CONST_NOTHROW_LEAF_LIST);
 872   gfc_define_builtin ("__builtin_fmodf", mfunc_float[1],
 873                       BUILT_IN_FMODF, "fmodf", ATTR_CONST_NOTHROW_LEAF_LIST);
 874
 875   /* lround{f,,l} and llround{f,,l} */
 876   ftype = build_function_type_list (long_integer_type_node,
 877                                     float_type_node, NULL_TREE);
 878   gfc_define_builtin ("__builtin_lroundf", ftype, BUILT_IN_LROUNDF,
 879                       "lroundf", ATTR_CONST_NOTHROW_LEAF_LIST);
 880   ftype = build_function_type_list (long_long_integer_type_node,
 881                                     float_type_node, NULL_TREE);
 882   gfc_define_builtin ("__builtin_llroundf", ftype, BUILT_IN_LLROUNDF,
 883                       "llroundf", ATTR_CONST_NOTHROW_LEAF_LIST);
 884
 885   ftype = build_function_type_list (long_integer_type_node,
 886                                     double_type_node, NULL_TREE);
 887   gfc_define_builtin ("__builtin_lround", ftype, BUILT_IN_LROUND,
 888                       "lround", ATTR_CONST_NOTHROW_LEAF_LIST);
 889   ftype = build_function_type_list (long_long_integer_type_node,
 890                                     double_type_node, NULL_TREE);
 891   gfc_define_builtin ("__builtin_llround", ftype, BUILT_IN_LLROUND,
 892                       "llround", ATTR_CONST_NOTHROW_LEAF_LIST);
 893
 894   ftype = build_function_type_list (long_integer_type_node,
 895                                     long_double_type_node, NULL_TREE);
 896   gfc_define_builtin ("__builtin_lroundl", ftype, BUILT_IN_LROUNDL,
 897                       "lroundl", ATTR_CONST_NOTHROW_LEAF_LIST);
 898   ftype = build_function_type_list (long_long_integer_type_node,
 899                                     long_double_type_node, NULL_TREE);
 900   gfc_define_builtin ("__builtin_llroundl", ftype, BUILT_IN_LLROUNDL,
 901                       "llroundl", ATTR_CONST_NOTHROW_LEAF_LIST);
 902
 903   /* These are used to implement the ** operator.  */
 904   gfc_define_builtin ("__builtin_powl", mfunc_longdouble[1],
 905                       BUILT_IN_POWL, "powl", ATTR_CONST_NOTHROW_LEAF_LIST);
 906   gfc_define_builtin ("__builtin_pow", mfunc_double[1],
 907                       BUILT_IN_POW, "pow", ATTR_CONST_NOTHROW_LEAF_LIST);
 908   gfc_define_builtin ("__builtin_powf", mfunc_float[1],
 909                       BUILT_IN_POWF, "powf", ATTR_CONST_NOTHROW_LEAF_LIST);
 910   gfc_define_builtin ("__builtin_cpowl", mfunc_clongdouble[1],
 911                       BUILT_IN_CPOWL, "cpowl", ATTR_CONST_NOTHROW_LEAF_LIST);
 912   gfc_define_builtin ("__builtin_cpow", mfunc_cdouble[1],
 913                       BUILT_IN_CPOW, "cpow", ATTR_CONST_NOTHROW_LEAF_LIST);
 914   gfc_define_builtin ("__builtin_cpowf", mfunc_cfloat[1],
 915                       BUILT_IN_CPOWF, "cpowf", ATTR_CONST_NOTHROW_LEAF_LIST);
 916   gfc_define_builtin ("__builtin_powil", mfunc_longdouble[2],
 917                       BUILT_IN_POWIL, "powil", ATTR_CONST_NOTHROW_LEAF_LIST);
 918   gfc_define_builtin ("__builtin_powi", mfunc_double[2],
 919                       BUILT_IN_POWI, "powi", ATTR_CONST_NOTHROW_LEAF_LIST);
 920   gfc_define_builtin ("__builtin_powif", mfunc_float[2],
 921                       BUILT_IN_POWIF, "powif", ATTR_CONST_NOTHROW_LEAF_LIST);
 922
 923
 924   if (TARGET_C99_FUNCTIONS)
 925     {
 926       gfc_define_builtin ("__builtin_cbrtl", mfunc_longdouble[0],
 927                           BUILT_IN_CBRTL, "cbrtl",
 928                           ATTR_CONST_NOTHROW_LEAF_LIST);
 929       gfc_define_builtin ("__builtin_cbrt", mfunc_double[0],
 930                           BUILT_IN_CBRT, "cbrt",
 931                           ATTR_CONST_NOTHROW_LEAF_LIST);
 932       gfc_define_builtin ("__builtin_cbrtf", mfunc_float[0],
 933                           BUILT_IN_CBRTF, "cbrtf",
 934                           ATTR_CONST_NOTHROW_LEAF_LIST);
 935       gfc_define_builtin ("__builtin_cexpil", func_longdouble_clongdouble,
 936                           BUILT_IN_CEXPIL, "cexpil",
 937                           ATTR_CONST_NOTHROW_LEAF_LIST);
 938       gfc_define_builtin ("__builtin_cexpi", func_double_cdouble,
 939                           BUILT_IN_CEXPI, "cexpi",
 940                           ATTR_CONST_NOTHROW_LEAF_LIST);
 941       gfc_define_builtin ("__builtin_cexpif", func_float_cfloat,
 942                           BUILT_IN_CEXPIF, "cexpif",
 943                           ATTR_CONST_NOTHROW_LEAF_LIST);
 944     }
 945
 946   if (TARGET_HAS_SINCOS)
 947     {
 948       gfc_define_builtin ("__builtin_sincosl",
 949                           func_longdouble_longdoublep_longdoublep,
 950                           BUILT_IN_SINCOSL, "sincosl", ATTR_NOTHROW_LEAF_LIST);
 951       gfc_define_builtin ("__builtin_sincos", func_double_doublep_doublep,
 952                           BUILT_IN_SINCOS, "sincos", ATTR_NOTHROW_LEAF_LIST);
 953       gfc_define_builtin ("__builtin_sincosf", func_float_floatp_floatp,
 954                           BUILT_IN_SINCOSF, "sincosf", ATTR_NOTHROW_LEAF_LIST);
 955     }
 956
 957   /* For LEADZ, TRAILZ, POPCNT and POPPAR.  */
 958   ftype = build_function_type_list (integer_type_node,
 959                                     unsigned_type_node, NULL_TREE);
 960   gfc_define_builtin ("__builtin_clz", ftype, BUILT_IN_CLZ,
 961                       "__builtin_clz", ATTR_CONST_NOTHROW_LEAF_LIST);
 962   gfc_define_builtin ("__builtin_ctz", ftype, BUILT_IN_CTZ,
 963                       "__builtin_ctz", ATTR_CONST_NOTHROW_LEAF_LIST);
 964   gfc_define_builtin ("__builtin_parity", ftype, BUILT_IN_PARITY,
 965                       "__builtin_parity", ATTR_CONST_NOTHROW_LEAF_LIST);
 966   gfc_define_builtin ("__builtin_popcount", ftype, BUILT_IN_POPCOUNT,
 967                       "__builtin_popcount", ATTR_CONST_NOTHROW_LEAF_LIST);
 968
 969   ftype = build_function_type_list (integer_type_node,
 970                                     long_unsigned_type_node, NULL_TREE);
 971   gfc_define_builtin ("__builtin_clzl", ftype, BUILT_IN_CLZL,
 972                       "__builtin_clzl", ATTR_CONST_NOTHROW_LEAF_LIST);
 973   gfc_define_builtin ("__builtin_ctzl", ftype, BUILT_IN_CTZL,
 974                       "__builtin_ctzl", ATTR_CONST_NOTHROW_LEAF_LIST);
 975   gfc_define_builtin ("__builtin_parityl", ftype, BUILT_IN_PARITYL,
 976                       "__builtin_parityl", ATTR_CONST_NOTHROW_LEAF_LIST);
 977   gfc_define_builtin ("__builtin_popcountl", ftype, BUILT_IN_POPCOUNTL,
 978                       "__builtin_popcountl", ATTR_CONST_NOTHROW_LEAF_LIST);
 979
 980   ftype = build_function_type_list (integer_type_node,
 981                                     long_long_unsigned_type_node, NULL_TREE);
 982   gfc_define_builtin ("__builtin_clzll", ftype, BUILT_IN_CLZLL,
 983                       "__builtin_clzll", ATTR_CONST_NOTHROW_LEAF_LIST);
 984   gfc_define_builtin ("__builtin_ctzll", ftype, BUILT_IN_CTZLL,
 985                       "__builtin_ctzll", ATTR_CONST_NOTHROW_LEAF_LIST);
 986   gfc_define_builtin ("__builtin_parityll", ftype, BUILT_IN_PARITYLL,
 987                       "__builtin_parityll", ATTR_CONST_NOTHROW_LEAF_LIST);
 988   gfc_define_builtin ("__builtin_popcountll", ftype, BUILT_IN_POPCOUNTLL,
 989                       "__builtin_popcountll", ATTR_CONST_NOTHROW_LEAF_LIST);
 990
 991   /* Other builtin functions we use.  */
 992
 993   ftype = build_function_type_list (long_integer_type_node,
 994                                     long_integer_type_node,
 995                                     long_integer_type_node, NULL_TREE);
 996   gfc_define_builtin ("__builtin_expect", ftype, BUILT_IN_EXPECT,
 997                       "__builtin_expect", ATTR_CONST_NOTHROW_LEAF_LIST);
 998
 999   ftype = build_function_type_list (void_type_node,
1000                                     pvoid_type_node, NULL_TREE);
1001   gfc_define_builtin ("__builtin_free", ftype, BUILT_IN_FREE,
1002                       "free", ATTR_NOTHROW_LEAF_LIST);
1003
1004   ftype = build_function_type_list (pvoid_type_node,
1005                                     size_type_node, NULL_TREE);
1006   gfc_define_builtin ("__builtin_malloc", ftype, BUILT_IN_MALLOC,
1007                       "malloc", ATTR_NOTHROW_LEAF_LIST);
1008   DECL_IS_MALLOC (built_in_decls[BUILT_IN_MALLOC]) = 1;
1009
1010   ftype = build_function_type_list (pvoid_type_node,
1011                                     size_type_node, pvoid_type_node,
1012                                     NULL_TREE);
1013   gfc_define_builtin ("__builtin_realloc", ftype, BUILT_IN_REALLOC,
1014                       "realloc", ATTR_NOTHROW_LEAF_LIST);
1015
1016   ftype = build_function_type_list (integer_type_node,
1017                                     void_type_node, NULL_TREE);
1018   gfc_define_builtin ("__builtin_isnan", ftype, BUILT_IN_ISNAN,
1019                       "__builtin_isnan", ATTR_CONST_NOTHROW_LEAF_LIST);
1020
1021 #define DEF_PRIMITIVE_TYPE(ENUM, VALUE) \
1022   builtin_types[(int) ENUM] = VALUE;
1023 #define DEF_FUNCTION_TYPE_0(ENUM, RETURN)                       \
1024   builtin_types[(int) ENUM]                                     \
1025     = build_function_type_list (builtin_types[(int) RETURN],    \
1026                                 NULL_TREE);
1027 #define DEF_FUNCTION_TYPE_1(ENUM, RETURN, ARG1)                         \
1028   builtin_types[(int) ENUM]                                             \
1029     = build_function_type_list (builtin_types[(int) RETURN],            \
1030                                 builtin_types[(int) ARG1],              \
1031                                 NULL_TREE);
1032 #define DEF_FUNCTION_TYPE_2(ENUM, RETURN, ARG1, ARG2)           \
1033   builtin_types[(int) ENUM]                                     \
1034     = build_function_type_list (builtin_types[(int) RETURN],    \
1035                                 builtin_types[(int) ARG1],      \
1036                                 builtin_types[(int) ARG2],      \
1037                                 NULL_TREE);
1038 #define DEF_FUNCTION_TYPE_3(ENUM, RETURN, ARG1, ARG2, ARG3)             \
1039   builtin_types[(int) ENUM]                                             \
1040     = build_function_type_list (builtin_types[(int) RETURN],            \
1041                                 builtin_types[(int) ARG1],              \
1042                                 builtin_types[(int) ARG2],              \
1043                                 builtin_types[(int) ARG3],              \
1044                                 NULL_TREE);
1045 #define DEF_FUNCTION_TYPE_4(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4)       \
1046   builtin_types[(int) ENUM]                                             \
1047     = build_function_type_list (builtin_types[(int) RETURN],            \
1048                                 builtin_types[(int) ARG1],              \
1049                                 builtin_types[(int) ARG2],              \
1050                                 builtin_types[(int) ARG3],              \
1051                                 builtin_types[(int) ARG4],              \
1052                                 NULL_TREE);
1053 #define DEF_FUNCTION_TYPE_5(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) \
1054   builtin_types[(int) ENUM]                                             \
1055     = build_function_type_list (builtin_types[(int) RETURN],            \
1056                                 builtin_types[(int) ARG1],              \
1057                                 builtin_types[(int) ARG2],              \
1058                                 builtin_types[(int) ARG3],              \
1059                                 builtin_types[(int) ARG4],              \
1060                                 builtin_types[(int) ARG5],              \
1061                                 NULL_TREE);
1062 #define DEF_FUNCTION_TYPE_6(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \
1063                             ARG6)                                       \
1064   builtin_types[(int) ENUM]                                             \
1065     = build_function_type_list (builtin_types[(int) RETURN],            \
1066                                 builtin_types[(int) ARG1],              \
1067                                 builtin_types[(int) ARG2],              \
1068                                 builtin_types[(int) ARG3],              \
1069                                 builtin_types[(int) ARG4],              \
1070                                 builtin_types[(int) ARG5],              \
1071                                 builtin_types[(int) ARG6],              \
1072                                 NULL_TREE);
1073 #define DEF_FUNCTION_TYPE_7(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \
1074                             ARG6, ARG7)                                 \
1075   builtin_types[(int) ENUM]                                             \
1076     = build_function_type_list (builtin_types[(int) RETURN],            \
1077                                 builtin_types[(int) ARG1],              \
1078                                 builtin_types[(int) ARG2],              \
1079                                 builtin_types[(int) ARG3],              \
1080                                 builtin_types[(int) ARG4],              \
1081                                 builtin_types[(int) ARG5],              \
1082                                 builtin_types[(int) ARG6],              \
1083                                 builtin_types[(int) ARG7],              \
1084                                 NULL_TREE);
1085 #define DEF_FUNCTION_TYPE_VAR_0(ENUM, RETURN)                           \
1086   builtin_types[(int) ENUM]                                             \
1087     = build_varargs_function_type_list (builtin_types[(int) RETURN],    \
1088                                         NULL_TREE);
1089 #define DEF_POINTER_TYPE(ENUM, TYPE)                    \
1090   builtin_types[(int) ENUM]                             \
1091     = build_pointer_type (builtin_types[(int) TYPE]);
1092 #include "types.def"
1093 #undef DEF_PRIMITIVE_TYPE
1094 #undef DEF_FUNCTION_TYPE_1
1095 #undef DEF_FUNCTION_TYPE_2
1096 #undef DEF_FUNCTION_TYPE_3
1097 #undef DEF_FUNCTION_TYPE_4
1098 #undef DEF_FUNCTION_TYPE_5
1099 #undef DEF_FUNCTION_TYPE_6
1100 #undef DEF_FUNCTION_TYPE_VAR_0
1101 #undef DEF_POINTER_TYPE
1102   builtin_types[(int) BT_LAST] = NULL_TREE;
1103
1104   /* Initialize synchronization builtins.  */
1105 #undef DEF_SYNC_BUILTIN
1106 #define DEF_SYNC_BUILTIN(code, name, type, attr) \
1107     gfc_define_builtin (name, builtin_types[type], code, name, \
1108                         attr);
1109 #include "../sync-builtins.def"
1110 #undef DEF_SYNC_BUILTIN
1111
1112   if (gfc_option.gfc_flag_openmp || flag_tree_parallelize_loops)
1113     {
1114 #undef DEF_GOMP_BUILTIN
1115 #define DEF_GOMP_BUILTIN(code, name, type, attr) \
1116       gfc_define_builtin ("__builtin_" name, builtin_types[type], \
1117                           code, name, attr);
1118 #include "../omp-builtins.def"
1119 #undef DEF_GOMP_BUILTIN
1120     }
1121
1122   gfc_define_builtin ("__builtin_trap", builtin_types[BT_FN_VOID],
1123                       BUILT_IN_TRAP, NULL, ATTR_NOTHROW_LEAF_LIST);
1124   TREE_THIS_VOLATILE (built_in_decls[BUILT_IN_TRAP]) = 1;
1125
1126   gfc_define_builtin ("__emutls_get_address",
1127                       builtin_types[BT_FN_PTR_PTR],
1128                       BUILT_IN_EMUTLS_GET_ADDRESS,
1129                       "__emutls_get_address", ATTR_CONST_NOTHROW_LEAF_LIST);
1130   gfc_define_builtin ("__emutls_register_common",
1131                       builtin_types[BT_FN_VOID_PTR_WORD_WORD_PTR],
1132                       BUILT_IN_EMUTLS_REGISTER_COMMON,
1133                       "__emutls_register_common", ATTR_NOTHROW_LEAF_LIST);
1134
1135   build_common_builtin_nodes ();
1136   targetm.init_builtins ();
1137 }
1138
1139 #undef DEFINE_MATH_BUILTIN_C
1140 #undef DEFINE_MATH_BUILTIN
1141
1142 static void
1143 gfc_init_ts (void)
1144 {
1145   tree_contains_struct[NAMESPACE_DECL][TS_DECL_NON_COMMON] = 1;
1146   tree_contains_struct[NAMESPACE_DECL][TS_DECL_WITH_VIS] = 1;
1147   tree_contains_struct[NAMESPACE_DECL][TS_DECL_WRTL] = 1;
1148   tree_contains_struct[NAMESPACE_DECL][TS_DECL_COMMON] = 1;
1149   tree_contains_struct[NAMESPACE_DECL][TS_DECL_MINIMAL] = 1;
1150 }
1151
1152 void
1153 gfc_maybe_initialize_eh (void)
1154 {
1155   if (!flag_exceptions || gfc_eh_initialized_p)
1156     return;
1157
1158   gfc_eh_initialized_p = true;
1159   using_eh_for_cleanups ();
1160 }
1161
1162
1163 #include "gt-fortran-f95-lang.h"
1164 #include "gtype-fortran.h"