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