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