gcc/fortran/f95-lang.c

   1 /* gfortran backend interface
   2    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
   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 /* For gfc_maybe_initialize_eh.  */
  47 #include "libfuncs.h"
  48 #include "expr.h"
  49 #include "except.h"
  50
  51 #include "gfortran.h"
  52 #include "cpp.h"
  53 #include "trans.h"
  54 #include "trans-types.h"
  55 #include "trans-const.h"
  56
  57 /* Language-dependent contents of an identifier.  */
  58
  59 struct GTY(())
  60 lang_identifier {
  61   struct tree_identifier common;
  62 };
  63
  64 /* The resulting tree type.  */
  65
  66 union GTY((desc ("TREE_CODE (&%h.generic) == IDENTIFIER_NODE"),
  67      chain_next ("(union lang_tree_node *)TREE_CHAIN (&%h.generic)")))
  68
  69 lang_tree_node {
  70   union tree_node GTY((tag ("0"),
  71                        desc ("tree_node_structure (&%h)"))) generic;
  72   struct lang_identifier GTY((tag ("1"))) identifier;
  73 };
  74
  75 /* Save and restore the variables in this file and elsewhere
  76    that keep track of the progress of compilation of the current function.
  77    Used for nested functions.  */
  78
  79 struct GTY(())
  80 language_function {
  81   /* struct gfc_language_function base; */
  82   struct binding_level *binding_level;
  83 };
  84
  85 /* We don't have a lex/yacc lexer/parser, but toplev expects these to
  86    exist anyway.  */
  87 void yyerror (const char *str);
  88 int yylex (void);
  89
  90 static void gfc_init_decl_processing (void);
  91 static void gfc_init_builtin_functions (void);
  92
  93 /* Each front end provides its own.  */
  94 static bool gfc_init (void);
  95 static void gfc_finish (void);
  96 static void gfc_print_identifier (FILE *, tree, int);
  97 static bool gfc_mark_addressable (tree);
  98 void do_function_end (void);
  99 int global_bindings_p (void);
 100 static void clear_binding_stack (void);
 101 static void gfc_be_parse_file (int);
 102 static alias_set_type gfc_get_alias_set (tree);
 103 static void gfc_init_ts (void);
 104
 105 #undef LANG_HOOKS_NAME
 106 #undef LANG_HOOKS_INIT
 107 #undef LANG_HOOKS_FINISH
 108 #undef LANG_HOOKS_INIT_OPTIONS
 109 #undef LANG_HOOKS_HANDLE_OPTION
 110 #undef LANG_HOOKS_POST_OPTIONS
 111 #undef LANG_HOOKS_PRINT_IDENTIFIER
 112 #undef LANG_HOOKS_PARSE_FILE
 113 #undef LANG_HOOKS_MARK_ADDRESSABLE
 114 #undef LANG_HOOKS_TYPE_FOR_MODE
 115 #undef LANG_HOOKS_TYPE_FOR_SIZE
 116 #undef LANG_HOOKS_GET_ALIAS_SET
 117 #undef LANG_HOOKS_INIT_TS
 118 #undef LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE
 119 #undef LANG_HOOKS_OMP_PREDETERMINED_SHARING
 120 #undef LANG_HOOKS_OMP_CLAUSE_DEFAULT_CTOR
 121 #undef LANG_HOOKS_OMP_CLAUSE_COPY_CTOR
 122 #undef LANG_HOOKS_OMP_CLAUSE_ASSIGN_OP
 123 #undef LANG_HOOKS_OMP_CLAUSE_DTOR
 124 #undef LANG_HOOKS_OMP_DISREGARD_VALUE_EXPR
 125 #undef LANG_HOOKS_OMP_PRIVATE_DEBUG_CLAUSE
 126 #undef LANG_HOOKS_OMP_PRIVATE_OUTER_REF
 127 #undef LANG_HOOKS_OMP_FIRSTPRIVATIZE_TYPE_SIZES
 128 #undef LANG_HOOKS_BUILTIN_FUNCTION
 129 #undef LANG_HOOKS_GET_ARRAY_DESCR_INFO
 130
 131 /* Define lang hooks.  */
 132 #define LANG_HOOKS_NAME                 "GNU Fortran"
 133 #define LANG_HOOKS_INIT                 gfc_init
 134 #define LANG_HOOKS_FINISH               gfc_finish
 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_MARK_ADDRESSABLE     gfc_mark_addressable
 141 #define LANG_HOOKS_TYPE_FOR_MODE        gfc_type_for_mode
 142 #define LANG_HOOKS_TYPE_FOR_SIZE        gfc_type_for_size
 143 #define LANG_HOOKS_GET_ALIAS_SET        gfc_get_alias_set
 144 #define LANG_HOOKS_INIT_TS              gfc_init_ts
 145 #define LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE   gfc_omp_privatize_by_reference
 146 #define LANG_HOOKS_OMP_PREDETERMINED_SHARING    gfc_omp_predetermined_sharing
 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 const 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 static void
 291 gfc_print_identifier (FILE * file ATTRIBUTE_UNUSED,
 292                       tree node ATTRIBUTE_UNUSED,
 293                       int indent ATTRIBUTE_UNUSED)
 294 {
 295   return;
 296 }
 297
 298
 299 /* These functions and variables deal with binding contours.  We only
 300    need these functions for the list of PARM_DECLs, but we leave the
 301    functions more general; these are a simplified version of the
 302    functions from GNAT.  */
 303
 304 /* For each binding contour we allocate a binding_level structure which
 305    records the entities defined or declared in that contour.  Contours
 306    include:
 307
 308         the global one
 309         one for each subprogram definition
 310         one for each compound statement (declare block)
 311
 312    Binding contours are used to create GCC tree BLOCK nodes.  */
 313
 314 struct GTY(())
 315 binding_level {
 316   /* A chain of ..._DECL nodes for all variables, constants, functions,
 317      parameters and type declarations.  These ..._DECL nodes are chained
 318      through the TREE_CHAIN field. Note that these ..._DECL nodes are stored
 319      in the reverse of the order supplied to be compatible with the
 320      back-end.  */
 321   tree names;
 322   /* For each level (except the global one), a chain of BLOCK nodes for all
 323      the levels that were entered and exited one level down from this one.  */
 324   tree blocks;
 325   /* The binding level containing this one (the enclosing binding level).  */
 326   struct binding_level *level_chain;
 327 };
 328
 329 /* The binding level currently in effect.  */
 330 static GTY(()) struct binding_level *current_binding_level = NULL;
 331
 332 /* The outermost binding level. This binding level is created when the
 333    compiler is started and it will exist through the entire compilation.  */
 334 static GTY(()) struct binding_level *global_binding_level;
 335
 336 /* Binding level structures are initialized by copying this one.  */
 337 static struct binding_level clear_binding_level = { NULL, NULL, NULL };
 338
 339
 340 /* Return nonzero if we are currently in the global binding level.  */
 341
 342 int
 343 global_bindings_p (void)
 344 {
 345   return current_binding_level == global_binding_level ? -1 : 0;
 346 }
 347
 348 tree
 349 getdecls (void)
 350 {
 351   return current_binding_level->names;
 352 }
 353
 354 /* Enter a new binding level. The input parameter is ignored, but has to be
 355    specified for back-end compatibility.  */
 356
 357 void
 358 pushlevel (int ignore ATTRIBUTE_UNUSED)
 359 {
 360   struct binding_level *newlevel
 361     = (struct binding_level *) ggc_alloc (sizeof (struct binding_level));
 362
 363   *newlevel = clear_binding_level;
 364
 365   /* Add this level to the front of the chain (stack) of levels that are
 366      active.  */
 367   newlevel->level_chain = current_binding_level;
 368   current_binding_level = newlevel;
 369 }
 370
 371 /* Exit a binding level.
 372    Pop the level off, and restore the state of the identifier-decl mappings
 373    that were in effect when this level was entered.
 374
 375    If KEEP is nonzero, this level had explicit declarations, so
 376    and create a "block" (a BLOCK node) for the level
 377    to record its declarations and subblocks for symbol table output.
 378
 379    If FUNCTIONBODY is nonzero, this level is the body of a function,
 380    so create a block as if KEEP were set and also clear out all
 381    label names.
 382
 383    If REVERSE is nonzero, reverse the order of decls before putting
 384    them into the BLOCK.  */
 385
 386 tree
 387 poplevel (int keep, int reverse, int functionbody)
 388 {
 389   /* Points to a BLOCK tree node. This is the BLOCK node constructed for the
 390      binding level that we are about to exit and which is returned by this
 391      routine.  */
 392   tree block_node = NULL_TREE;
 393   tree decl_chain;
 394   tree subblock_chain = current_binding_level->blocks;
 395   tree subblock_node;
 396
 397   /* Reverse the list of XXXX_DECL nodes if desired.  Note that the ..._DECL
 398      nodes chained through the `names' field of current_binding_level are in
 399      reverse order except for PARM_DECL node, which are explicitly stored in
 400      the right order.  */
 401   decl_chain = (reverse) ? nreverse (current_binding_level->names)
 402                          : current_binding_level->names;
 403
 404   /* If there were any declarations in the current binding level, or if this
 405      binding level is a function body, or if there are any nested blocks then
 406      create a BLOCK node to record them for the life of this function.  */
 407   if (keep || functionbody)
 408     block_node = build_block (keep ? decl_chain : 0, subblock_chain, 0, 0);
 409
 410   /* Record the BLOCK node just built as the subblock its enclosing scope.  */
 411   for (subblock_node = subblock_chain; subblock_node;
 412        subblock_node = TREE_CHAIN (subblock_node))
 413     BLOCK_SUPERCONTEXT (subblock_node) = block_node;
 414
 415   /* Clear out the meanings of the local variables of this level.  */
 416
 417   for (subblock_node = decl_chain; subblock_node;
 418        subblock_node = TREE_CHAIN (subblock_node))
 419     if (DECL_NAME (subblock_node) != 0)
 420       /* If the identifier was used or addressed via a local extern decl,
 421          don't forget that fact.  */
 422       if (DECL_EXTERNAL (subblock_node))
 423         {
 424           if (TREE_USED (subblock_node))
 425             TREE_USED (DECL_NAME (subblock_node)) = 1;
 426           if (TREE_ADDRESSABLE (subblock_node))
 427             TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (subblock_node)) = 1;
 428         }
 429
 430   /* Pop the current level.  */
 431   current_binding_level = current_binding_level->level_chain;
 432
 433   if (functionbody)
 434     /* This is the top level block of a function. */
 435     DECL_INITIAL (current_function_decl) = block_node;
 436   else if (current_binding_level == global_binding_level)
 437     /* When using gfc_start_block/gfc_finish_block from middle-end hooks,
 438        don't add newly created BLOCKs as subblocks of global_binding_level.  */
 439     ;
 440   else if (block_node)
 441     {
 442       current_binding_level->blocks
 443         = chainon (current_binding_level->blocks, block_node);
 444     }
 445
 446   /* If we did not make a block for the level just exited, any blocks made for
 447      inner levels (since they cannot be recorded as subblocks in that level)
 448      must be carried forward so they will later become subblocks of something
 449      else.  */
 450   else if (subblock_chain)
 451     current_binding_level->blocks
 452       = chainon (current_binding_level->blocks, subblock_chain);
 453   if (block_node)
 454     TREE_USED (block_node) = 1;
 455
 456   return block_node;
 457 }
 458
 459
 460 /* Records a ..._DECL node DECL as belonging to the current lexical scope.
 461    Returns the ..._DECL node.  */
 462
 463 tree
 464 pushdecl (tree decl)
 465 {
 466   /* External objects aren't nested, other objects may be.  */
 467   if ((DECL_EXTERNAL (decl)) || (decl == current_function_decl))
 468     DECL_CONTEXT (decl) = 0;
 469   else
 470     DECL_CONTEXT (decl) = current_function_decl;
 471
 472   /* Put the declaration on the list.  The list of declarations is in reverse
 473      order. The list will be reversed later if necessary.  This needs to be
 474      this way for compatibility with the back-end.  */
 475
 476   TREE_CHAIN (decl) = current_binding_level->names;
 477   current_binding_level->names = decl;
 478
 479   /* For the declaration of a type, set its name if it is not already set.  */
 480
 481   if (TREE_CODE (decl) == TYPE_DECL && TYPE_NAME (TREE_TYPE (decl)) == 0)
 482     {
 483       if (DECL_SOURCE_LINE (decl) == 0)
 484         TYPE_NAME (TREE_TYPE (decl)) = decl;
 485       else
 486         TYPE_NAME (TREE_TYPE (decl)) = DECL_NAME (decl);
 487     }
 488
 489   return decl;
 490 }
 491
 492
 493 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL.  */
 494
 495 tree
 496 pushdecl_top_level (tree x)
 497 {
 498   tree t;
 499   struct binding_level *b = current_binding_level;
 500
 501   current_binding_level = global_binding_level;
 502   t = pushdecl (x);
 503   current_binding_level = b;
 504   return t;
 505 }
 506
 507
 508 /* Clear the binding stack.  */
 509 static void
 510 clear_binding_stack (void)
 511 {
 512   while (!global_bindings_p ())
 513     poplevel (0, 0, 0);
 514 }
 515
 516
 517 #ifndef CHAR_TYPE_SIZE
 518 #define CHAR_TYPE_SIZE BITS_PER_UNIT
 519 #endif
 520
 521 #ifndef INT_TYPE_SIZE
 522 #define INT_TYPE_SIZE BITS_PER_WORD
 523 #endif
 524
 525 #undef SIZE_TYPE
 526 #define SIZE_TYPE "long unsigned int"
 527
 528 /* Create tree nodes for the basic scalar types of Fortran 95,
 529    and some nodes representing standard constants (0, 1, (void *) 0).
 530    Initialize the global binding level.
 531    Make definitions for built-in primitive functions.  */
 532 static void
 533 gfc_init_decl_processing (void)
 534 {
 535   current_function_decl = NULL;
 536   current_binding_level = NULL_BINDING_LEVEL;
 537   free_binding_level = NULL_BINDING_LEVEL;
 538
 539   /* Make the binding_level structure for global names. We move all
 540      variables that are in a COMMON block to this binding level.  */
 541   pushlevel (0);
 542   global_binding_level = current_binding_level;
 543
 544   /* Build common tree nodes. char_type_node is unsigned because we
 545      only use it for actual characters, not for INTEGER(1). Also, we
 546      want double_type_node to actually have double precision.  */
 547   build_common_tree_nodes (false, false);
 548   /* x86_64 mingw32 has a sizetype of "unsigned long long", most other hosts
 549      have a sizetype of "unsigned long". Therefore choose the correct size
 550      in mostly target independent way.  */
 551   if (TYPE_MODE (long_unsigned_type_node) == ptr_mode)
 552     set_sizetype (long_unsigned_type_node);
 553   else if (TYPE_MODE (long_long_unsigned_type_node) == ptr_mode)
 554     set_sizetype (long_long_unsigned_type_node);
 555   else
 556     set_sizetype (long_unsigned_type_node);
 557   build_common_tree_nodes_2 (0);
 558   void_list_node = build_tree_list (NULL_TREE, void_type_node);
 559
 560   /* Set up F95 type nodes.  */
 561   gfc_init_kinds ();
 562   gfc_init_types ();
 563 }
 564
 565
 566 /* Mark EXP saying that we need to be able to take the
 567    address of it; it should not be allocated in a register.
 568    In Fortran 95 this is only the case for variables with
 569    the TARGET attribute, but we implement it here for a
 570    likely future Cray pointer extension.
 571    Value is 1 if successful.  */
 572 /* TODO: Check/fix mark_addressable.  */
 573
 574 bool
 575 gfc_mark_addressable (tree exp)
 576 {
 577   register tree x = exp;
 578   while (1)
 579     switch (TREE_CODE (x))
 580       {
 581       case COMPONENT_REF:
 582       case ADDR_EXPR:
 583       case ARRAY_REF:
 584       case REALPART_EXPR:
 585       case IMAGPART_EXPR:
 586         x = TREE_OPERAND (x, 0);
 587         break;
 588
 589       case CONSTRUCTOR:
 590         TREE_ADDRESSABLE (x) = 1;
 591         return true;
 592
 593       case VAR_DECL:
 594       case CONST_DECL:
 595       case PARM_DECL:
 596       case RESULT_DECL:
 597         if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x) && DECL_NONLOCAL (x))
 598           {
 599             if (TREE_PUBLIC (x))
 600               {
 601                 error ("global register variable %qs used in nested function",
 602                        IDENTIFIER_POINTER (DECL_NAME (x)));
 603                 return false;
 604               }
 605             pedwarn (input_location, 0, "register variable %qs used in nested function",
 606                      IDENTIFIER_POINTER (DECL_NAME (x)));
 607           }
 608         else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
 609           {
 610             if (TREE_PUBLIC (x))
 611               {
 612                 error ("address of global register variable %qs requested",
 613                        IDENTIFIER_POINTER (DECL_NAME (x)));
 614                 return true;
 615               }
 616
 617 #if 0
 618             /* If we are making this addressable due to its having
 619                volatile components, give a different error message.  Also
 620                handle the case of an unnamed parameter by not trying
 621                to give the name.  */
 622
 623             else if (C_TYPE_FIELDS_VOLATILE (TREE_TYPE (x)))
 624               {
 625                 error ("cannot put object with volatile field into register");
 626                 return false;
 627               }
 628 #endif
 629
 630             pedwarn (input_location, 0, "address of register variable %qs requested",
 631                      IDENTIFIER_POINTER (DECL_NAME (x)));
 632           }
 633
 634         /* drops in */
 635       case FUNCTION_DECL:
 636         TREE_ADDRESSABLE (x) = 1;
 637
 638       default:
 639         return true;
 640       }
 641 }
 642
 643
 644 /* Return the typed-based alias set for T, which may be an expression
 645    or a type.  Return -1 if we don't do anything special.  */
 646
 647 static alias_set_type
 648 gfc_get_alias_set (tree t)
 649 {
 650   tree u;
 651
 652   /* Permit type-punning when accessing an EQUIVALENCEd variable or
 653      mixed type entry master's return value.  */
 654   for (u = t; handled_component_p (u); u = TREE_OPERAND (u, 0))
 655     if (TREE_CODE (u) == COMPONENT_REF
 656         && TREE_CODE (TREE_TYPE (TREE_OPERAND (u, 0))) == UNION_TYPE)
 657       return 0;
 658
 659   return -1;
 660 }
 661
 662
 663 /* press the big red button - garbage (ggc) collection is on */
 664
 665 int ggc_p = 1;
 666
 667 /* Builtin function initialization.  */
 668
 669 tree
 670 gfc_builtin_function (tree decl)
 671 {
 672   make_decl_rtl (decl);
 673   pushdecl (decl);
 674   return decl;
 675 }
 676
 677
 678 static void
 679 gfc_define_builtin (const char *name,
 680                     tree type,
 681                     int code,
 682                     const char *library_name,
 683                     bool const_p)
 684 {
 685   tree decl;
 686
 687   decl = add_builtin_function (name, type, code, BUILT_IN_NORMAL,
 688                                library_name, NULL_TREE);
 689   if (const_p)
 690     TREE_READONLY (decl) = 1;
 691
 692   built_in_decls[code] = decl;
 693   implicit_built_in_decls[code] = decl;
 694 }
 695
 696
 697 #define DO_DEFINE_MATH_BUILTIN(code, name, argtype, tbase) \
 698     gfc_define_builtin ("__builtin_" name "l", tbase##longdouble[argtype], \
 699                        BUILT_IN_ ## code ## L, name "l", true); \
 700     gfc_define_builtin ("__builtin_" name, tbase##double[argtype], \
 701                         BUILT_IN_ ## code, name, true); \
 702     gfc_define_builtin ("__builtin_" name "f", tbase##float[argtype], \
 703                         BUILT_IN_ ## code ## F, name "f", true);
 704
 705 #define DEFINE_MATH_BUILTIN(code, name, argtype) \
 706     DO_DEFINE_MATH_BUILTIN (code, name, argtype, mfunc_)
 707
 708 #define DEFINE_MATH_BUILTIN_C(code, name, argtype) \
 709     DO_DEFINE_MATH_BUILTIN (code, name, argtype, mfunc_) \
 710     DO_DEFINE_MATH_BUILTIN (C##code, "c" name, argtype, mfunc_c)
 711
 712
 713 /* Create function types for builtin functions.  */
 714
 715 static void
 716 build_builtin_fntypes (tree *fntype, tree type)
 717 {
 718   tree tmp;
 719
 720   /* type (*) (type) */
 721   tmp = tree_cons (NULL_TREE, type, void_list_node);
 722   fntype[0] = build_function_type (type, tmp);
 723   /* type (*) (type, type) */
 724   tmp = tree_cons (NULL_TREE, type, tmp);
 725   fntype[1] = build_function_type (type, tmp);
 726   /* type (*) (int, type) */
 727   tmp = tree_cons (NULL_TREE, integer_type_node, void_list_node);
 728   tmp = tree_cons (NULL_TREE, type, tmp);
 729   fntype[2] = build_function_type (type, tmp);
 730   /* type (*) (void) */
 731   fntype[3] = build_function_type (type, void_list_node);
 732   /* type (*) (type, &int) */
 733   tmp = tree_cons (NULL_TREE, type, void_list_node);
 734   tmp = tree_cons (NULL_TREE, build_pointer_type (integer_type_node), tmp);
 735   fntype[4] = build_function_type (type, tmp);
 736   /* type (*) (type, int) */
 737   tmp = tree_cons (NULL_TREE, type, void_list_node);
 738   tmp = tree_cons (NULL_TREE, integer_type_node, tmp);
 739   fntype[5] = build_function_type (type, tmp);
 740 }
 741
 742
 743 static tree
 744 builtin_type_for_size (int size, bool unsignedp)
 745 {
 746   tree type = lang_hooks.types.type_for_size (size, unsignedp);
 747   return type ? type : error_mark_node;
 748 }
 749
 750 /* Initialization of builtin function nodes.  */
 751
 752 static void
 753 gfc_init_builtin_functions (void)
 754 {
 755   enum builtin_type
 756   {
 757 #define DEF_PRIMITIVE_TYPE(NAME, VALUE) NAME,
 758 #define DEF_FUNCTION_TYPE_0(NAME, RETURN) NAME,
 759 #define DEF_FUNCTION_TYPE_1(NAME, RETURN, ARG1) NAME,
 760 #define DEF_FUNCTION_TYPE_2(NAME, RETURN, ARG1, ARG2) NAME,
 761 #define DEF_FUNCTION_TYPE_3(NAME, RETURN, ARG1, ARG2, ARG3) NAME,
 762 #define DEF_FUNCTION_TYPE_4(NAME, RETURN, ARG1, ARG2, ARG3, ARG4) NAME,
 763 #define DEF_FUNCTION_TYPE_5(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) NAME,
 764 #define DEF_FUNCTION_TYPE_6(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6) NAME,
 765 #define DEF_FUNCTION_TYPE_7(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6, ARG7) NAME,
 766 #define DEF_FUNCTION_TYPE_VAR_0(NAME, RETURN) NAME,
 767 #define DEF_POINTER_TYPE(NAME, TYPE) NAME,
 768 #include "types.def"
 769 #undef DEF_PRIMITIVE_TYPE
 770 #undef DEF_FUNCTION_TYPE_0
 771 #undef DEF_FUNCTION_TYPE_1
 772 #undef DEF_FUNCTION_TYPE_2
 773 #undef DEF_FUNCTION_TYPE_3
 774 #undef DEF_FUNCTION_TYPE_4
 775 #undef DEF_FUNCTION_TYPE_5
 776 #undef DEF_FUNCTION_TYPE_6
 777 #undef DEF_FUNCTION_TYPE_7
 778 #undef DEF_FUNCTION_TYPE_VAR_0
 779 #undef DEF_POINTER_TYPE
 780     BT_LAST
 781   };
 782   typedef enum builtin_type builtin_type;
 783   enum
 784   {
 785     /* So far we need just these 2 attribute types.  */
 786     ATTR_NOTHROW_LIST,
 787     ATTR_CONST_NOTHROW_LIST
 788   };
 789
 790   tree mfunc_float[6];
 791   tree mfunc_double[6];
 792   tree mfunc_longdouble[6];
 793   tree mfunc_cfloat[6];
 794   tree mfunc_cdouble[6];
 795   tree mfunc_clongdouble[6];
 796   tree func_cfloat_float, func_float_cfloat;
 797   tree func_cdouble_double, func_double_cdouble;
 798   tree func_clongdouble_longdouble, func_longdouble_clongdouble;
 799   tree func_float_floatp_floatp;
 800   tree func_double_doublep_doublep;
 801   tree func_longdouble_longdoublep_longdoublep;
 802   tree ftype, ptype;
 803   tree tmp, type;
 804   tree builtin_types[(int) BT_LAST + 1];
 805
 806   build_builtin_fntypes (mfunc_float, float_type_node);
 807   build_builtin_fntypes (mfunc_double, double_type_node);
 808   build_builtin_fntypes (mfunc_longdouble, long_double_type_node);
 809   build_builtin_fntypes (mfunc_cfloat, complex_float_type_node);
 810   build_builtin_fntypes (mfunc_cdouble, complex_double_type_node);
 811   build_builtin_fntypes (mfunc_clongdouble, complex_long_double_type_node);
 812
 813   tmp = tree_cons (NULL_TREE, complex_float_type_node, void_list_node);
 814   func_cfloat_float = build_function_type (float_type_node, tmp);
 815
 816   tmp = tree_cons (NULL_TREE, float_type_node, void_list_node);
 817   func_float_cfloat = build_function_type (complex_float_type_node, tmp);
 818
 819   tmp = tree_cons (NULL_TREE, complex_double_type_node, void_list_node);
 820   func_cdouble_double = build_function_type (double_type_node, tmp);
 821
 822   tmp = tree_cons (NULL_TREE, double_type_node, void_list_node);
 823   func_double_cdouble = build_function_type (complex_double_type_node, tmp);
 824
 825   tmp = tree_cons (NULL_TREE, complex_long_double_type_node, void_list_node);
 826   func_clongdouble_longdouble =
 827     build_function_type (long_double_type_node, tmp);
 828
 829   tmp = tree_cons (NULL_TREE, long_double_type_node, void_list_node);
 830   func_longdouble_clongdouble =
 831     build_function_type (complex_long_double_type_node, tmp);
 832
 833   ptype = build_pointer_type (float_type_node);
 834   tmp = tree_cons (NULL_TREE, float_type_node,
 835                    tree_cons (NULL_TREE, ptype,
 836                               tree_cons (NULL_TREE, ptype, void_list_node)));
 837   func_float_floatp_floatp =
 838     build_function_type (void_type_node, tmp);
 839
 840   ptype = build_pointer_type (double_type_node);
 841   tmp = tree_cons (NULL_TREE, double_type_node,
 842                    tree_cons (NULL_TREE, ptype,
 843                               tree_cons (NULL_TREE, ptype, void_list_node)));
 844   func_double_doublep_doublep =
 845     build_function_type (void_type_node, tmp);
 846
 847   ptype = build_pointer_type (long_double_type_node);
 848   tmp = tree_cons (NULL_TREE, long_double_type_node,
 849                    tree_cons (NULL_TREE, ptype,
 850                               tree_cons (NULL_TREE, ptype, void_list_node)));
 851   func_longdouble_longdoublep_longdoublep =
 852     build_function_type (void_type_node, tmp);
 853
 854 #include "mathbuiltins.def"
 855
 856   /* We define these separately as the fortran versions have different
 857      semantics (they return an integer type) */
 858   gfc_define_builtin ("__builtin_roundl", mfunc_longdouble[0],
 859                       BUILT_IN_ROUNDL, "roundl", true);
 860   gfc_define_builtin ("__builtin_round", mfunc_double[0],
 861                       BUILT_IN_ROUND, "round", true);
 862   gfc_define_builtin ("__builtin_roundf", mfunc_float[0],
 863                       BUILT_IN_ROUNDF, "roundf", true);
 864
 865   gfc_define_builtin ("__builtin_truncl", mfunc_longdouble[0],
 866                       BUILT_IN_TRUNCL, "truncl", true);
 867   gfc_define_builtin ("__builtin_trunc", mfunc_double[0],
 868                       BUILT_IN_TRUNC, "trunc", true);
 869   gfc_define_builtin ("__builtin_truncf", mfunc_float[0],
 870                       BUILT_IN_TRUNCF, "truncf", true);
 871
 872   gfc_define_builtin ("__builtin_cabsl", func_clongdouble_longdouble,
 873                       BUILT_IN_CABSL, "cabsl", true);
 874   gfc_define_builtin ("__builtin_cabs", func_cdouble_double,
 875                       BUILT_IN_CABS, "cabs", true);
 876   gfc_define_builtin ("__builtin_cabsf", func_cfloat_float,
 877                       BUILT_IN_CABSF, "cabsf", true);
 878
 879   gfc_define_builtin ("__builtin_copysignl", mfunc_longdouble[1],
 880                       BUILT_IN_COPYSIGNL, "copysignl", true);
 881   gfc_define_builtin ("__builtin_copysign", mfunc_double[1],
 882                       BUILT_IN_COPYSIGN, "copysign", true);
 883   gfc_define_builtin ("__builtin_copysignf", mfunc_float[1],
 884                       BUILT_IN_COPYSIGNF, "copysignf", true);
 885
 886   gfc_define_builtin ("__builtin_nextafterl", mfunc_longdouble[1],
 887                       BUILT_IN_NEXTAFTERL, "nextafterl", true);
 888   gfc_define_builtin ("__builtin_nextafter", mfunc_double[1],
 889                       BUILT_IN_NEXTAFTER, "nextafter", true);
 890   gfc_define_builtin ("__builtin_nextafterf", mfunc_float[1],
 891                       BUILT_IN_NEXTAFTERF, "nextafterf", true);
 892
 893   gfc_define_builtin ("__builtin_frexpl", mfunc_longdouble[4],
 894                       BUILT_IN_FREXPL, "frexpl", false);
 895   gfc_define_builtin ("__builtin_frexp", mfunc_double[4],
 896                       BUILT_IN_FREXP, "frexp", false);
 897   gfc_define_builtin ("__builtin_frexpf", mfunc_float[4],
 898                       BUILT_IN_FREXPF, "frexpf", false);
 899
 900   gfc_define_builtin ("__builtin_fabsl", mfunc_longdouble[0],
 901                       BUILT_IN_FABSL, "fabsl", true);
 902   gfc_define_builtin ("__builtin_fabs", mfunc_double[0],
 903                       BUILT_IN_FABS, "fabs", true);
 904   gfc_define_builtin ("__builtin_fabsf", mfunc_float[0],
 905                       BUILT_IN_FABSF, "fabsf", true);
 906
 907   gfc_define_builtin ("__builtin_scalbnl", mfunc_longdouble[5],
 908                       BUILT_IN_SCALBNL, "scalbnl", true);
 909   gfc_define_builtin ("__builtin_scalbn", mfunc_double[5],
 910                       BUILT_IN_SCALBN, "scalbn", true);
 911   gfc_define_builtin ("__builtin_scalbnf", mfunc_float[5],
 912                       BUILT_IN_SCALBNF, "scalbnf", true);
 913
 914   gfc_define_builtin ("__builtin_fmodl", mfunc_longdouble[1],
 915                       BUILT_IN_FMODL, "fmodl", true);
 916   gfc_define_builtin ("__builtin_fmod", mfunc_double[1],
 917                       BUILT_IN_FMOD, "fmod", true);
 918   gfc_define_builtin ("__builtin_fmodf", mfunc_float[1],
 919                       BUILT_IN_FMODF, "fmodf", true);
 920
 921   gfc_define_builtin ("__builtin_huge_vall", mfunc_longdouble[3],
 922                       BUILT_IN_HUGE_VALL, "__builtin_huge_vall", true);
 923   gfc_define_builtin ("__builtin_huge_val", mfunc_double[3],
 924                       BUILT_IN_HUGE_VAL, "__builtin_huge_val", true);
 925   gfc_define_builtin ("__builtin_huge_valf", mfunc_float[3],
 926                       BUILT_IN_HUGE_VALF, "__builtin_huge_valf", true);
 927
 928   /* lround{f,,l} and llround{f,,l} */
 929   type = tree_cons (NULL_TREE, float_type_node, void_list_node);
 930   tmp = build_function_type (long_integer_type_node, type);
 931   gfc_define_builtin ("__builtin_lroundf", tmp, BUILT_IN_LROUNDF,
 932                       "lroundf", true);
 933   tmp = build_function_type (long_long_integer_type_node, type);
 934   gfc_define_builtin ("__builtin_llroundf", tmp, BUILT_IN_LLROUNDF,
 935                       "llroundf", true);
 936
 937   type = tree_cons (NULL_TREE, double_type_node, void_list_node);
 938   tmp = build_function_type (long_integer_type_node, type);
 939   gfc_define_builtin ("__builtin_lround", tmp, BUILT_IN_LROUND,
 940                       "lround", true);
 941   tmp = build_function_type (long_long_integer_type_node, type);
 942   gfc_define_builtin ("__builtin_llround", tmp, BUILT_IN_LLROUND,
 943                       "llround", true);
 944
 945   type = tree_cons (NULL_TREE, long_double_type_node, void_list_node);
 946   tmp = build_function_type (long_integer_type_node, type);
 947   gfc_define_builtin ("__builtin_lroundl", tmp, BUILT_IN_LROUNDL,
 948                       "lroundl", true);
 949   tmp = build_function_type (long_long_integer_type_node, type);
 950   gfc_define_builtin ("__builtin_llroundl", tmp, BUILT_IN_LLROUNDL,
 951                       "llroundl", true);
 952
 953   /* These are used to implement the ** operator.  */
 954   gfc_define_builtin ("__builtin_powl", mfunc_longdouble[1],
 955                       BUILT_IN_POWL, "powl", true);
 956   gfc_define_builtin ("__builtin_pow", mfunc_double[1],
 957                       BUILT_IN_POW, "pow", true);
 958   gfc_define_builtin ("__builtin_powf", mfunc_float[1],
 959                       BUILT_IN_POWF, "powf", true);
 960   gfc_define_builtin ("__builtin_cpowl", mfunc_clongdouble[1],
 961                       BUILT_IN_CPOWL, "cpowl", true);
 962   gfc_define_builtin ("__builtin_cpow", mfunc_cdouble[1],
 963                       BUILT_IN_CPOW, "cpow", true);
 964   gfc_define_builtin ("__builtin_cpowf", mfunc_cfloat[1],
 965                       BUILT_IN_CPOWF, "cpowf", true);
 966   gfc_define_builtin ("__builtin_powil", mfunc_longdouble[2],
 967                       BUILT_IN_POWIL, "powil", true);
 968   gfc_define_builtin ("__builtin_powi", mfunc_double[2],
 969                       BUILT_IN_POWI, "powi", true);
 970   gfc_define_builtin ("__builtin_powif", mfunc_float[2],
 971                       BUILT_IN_POWIF, "powif", true);
 972
 973
 974   if (TARGET_C99_FUNCTIONS)
 975     {
 976       gfc_define_builtin ("__builtin_cbrtl", mfunc_longdouble[0],
 977                           BUILT_IN_CBRTL, "cbrtl", true);
 978       gfc_define_builtin ("__builtin_cbrt", mfunc_double[0],
 979                           BUILT_IN_CBRT, "cbrt", true);
 980       gfc_define_builtin ("__builtin_cbrtf", mfunc_float[0],
 981                           BUILT_IN_CBRTF, "cbrtf", true);
 982       gfc_define_builtin ("__builtin_cexpil", func_longdouble_clongdouble,
 983                           BUILT_IN_CEXPIL, "cexpil", true);
 984       gfc_define_builtin ("__builtin_cexpi", func_double_cdouble,
 985                           BUILT_IN_CEXPI, "cexpi", true);
 986       gfc_define_builtin ("__builtin_cexpif", func_float_cfloat,
 987                           BUILT_IN_CEXPIF, "cexpif", true);
 988     }
 989
 990   if (TARGET_HAS_SINCOS)
 991     {
 992       gfc_define_builtin ("__builtin_sincosl",
 993                           func_longdouble_longdoublep_longdoublep,
 994                           BUILT_IN_SINCOSL, "sincosl", false);
 995       gfc_define_builtin ("__builtin_sincos", func_double_doublep_doublep,
 996                           BUILT_IN_SINCOS, "sincos", false);
 997       gfc_define_builtin ("__builtin_sincosf", func_float_floatp_floatp,
 998                           BUILT_IN_SINCOSF, "sincosf", false);
 999     }
1000
1001   /* For LEADZ / TRAILZ.  */
1002   tmp = tree_cons (NULL_TREE, unsigned_type_node, void_list_node);
1003   ftype = build_function_type (integer_type_node, tmp);
1004   gfc_define_builtin ("__builtin_clz", ftype, BUILT_IN_CLZ,
1005                       "__builtin_clz", true);
1006
1007   tmp = tree_cons (NULL_TREE, long_unsigned_type_node, void_list_node);
1008   ftype = build_function_type (integer_type_node, tmp);
1009   gfc_define_builtin ("__builtin_clzl", ftype, BUILT_IN_CLZL,
1010                       "__builtin_clzl", true);
1011
1012   tmp = tree_cons (NULL_TREE, long_long_unsigned_type_node, void_list_node);
1013   ftype = build_function_type (integer_type_node, tmp);
1014   gfc_define_builtin ("__builtin_clzll", ftype, BUILT_IN_CLZLL,
1015                       "__builtin_clzll", true);
1016
1017   tmp = tree_cons (NULL_TREE, unsigned_type_node, void_list_node);
1018   ftype = build_function_type (integer_type_node, tmp);
1019   gfc_define_builtin ("__builtin_ctz", ftype, BUILT_IN_CTZ,
1020                       "__builtin_ctz", true);
1021
1022   tmp = tree_cons (NULL_TREE, long_unsigned_type_node, void_list_node);
1023   ftype = build_function_type (integer_type_node, tmp);
1024   gfc_define_builtin ("__builtin_ctzl", ftype, BUILT_IN_CTZL,
1025                       "__builtin_ctzl", true);
1026
1027   tmp = tree_cons (NULL_TREE, long_long_unsigned_type_node, void_list_node);
1028   ftype = build_function_type (integer_type_node, tmp);
1029   gfc_define_builtin ("__builtin_ctzll", ftype, BUILT_IN_CTZLL,
1030                       "__builtin_ctzll", true);
1031
1032   /* Other builtin functions we use.  */
1033
1034   tmp = tree_cons (NULL_TREE, long_integer_type_node, void_list_node);
1035   tmp = tree_cons (NULL_TREE, long_integer_type_node, tmp);
1036   ftype = build_function_type (long_integer_type_node, tmp);
1037   gfc_define_builtin ("__builtin_expect", ftype, BUILT_IN_EXPECT,
1038                       "__builtin_expect", true);
1039
1040   tmp = tree_cons (NULL_TREE, pvoid_type_node, void_list_node);
1041   ftype = build_function_type (void_type_node, tmp);
1042   gfc_define_builtin ("__builtin_free", ftype, BUILT_IN_FREE,
1043                       "free", false);
1044
1045   tmp = tree_cons (NULL_TREE, size_type_node, void_list_node);
1046   ftype = build_function_type (pvoid_type_node, tmp);
1047   gfc_define_builtin ("__builtin_malloc", ftype, BUILT_IN_MALLOC,
1048                       "malloc", false);
1049   DECL_IS_MALLOC (built_in_decls[BUILT_IN_MALLOC]) = 1;
1050
1051   tmp = tree_cons (NULL_TREE, pvoid_type_node, void_list_node);
1052   tmp = tree_cons (NULL_TREE, size_type_node, tmp);
1053   ftype = build_function_type (pvoid_type_node, tmp);
1054   gfc_define_builtin ("__builtin_realloc", ftype, BUILT_IN_REALLOC,
1055                       "realloc", false);
1056
1057   tmp = tree_cons (NULL_TREE, void_type_node, void_list_node);
1058   ftype = build_function_type (integer_type_node, tmp);
1059   gfc_define_builtin ("__builtin_isnan", ftype, BUILT_IN_ISNAN,
1060                       "__builtin_isnan", true);
1061
1062 #define DEF_PRIMITIVE_TYPE(ENUM, VALUE) \
1063   builtin_types[(int) ENUM] = VALUE;
1064 #define DEF_FUNCTION_TYPE_0(ENUM, RETURN)               \
1065   builtin_types[(int) ENUM]                             \
1066     = build_function_type (builtin_types[(int) RETURN], \
1067                            void_list_node);
1068 #define DEF_FUNCTION_TYPE_1(ENUM, RETURN, ARG1)                         \
1069   builtin_types[(int) ENUM]                                             \
1070     = build_function_type (builtin_types[(int) RETURN],                 \
1071                            tree_cons (NULL_TREE,                        \
1072                                       builtin_types[(int) ARG1],        \
1073                                       void_list_node));
1074 #define DEF_FUNCTION_TYPE_2(ENUM, RETURN, ARG1, ARG2)   \
1075   builtin_types[(int) ENUM]                             \
1076     = build_function_type                               \
1077       (builtin_types[(int) RETURN],                     \
1078        tree_cons (NULL_TREE,                            \
1079                   builtin_types[(int) ARG1],            \
1080                   tree_cons (NULL_TREE,                 \
1081                              builtin_types[(int) ARG2], \
1082                              void_list_node)));
1083 #define DEF_FUNCTION_TYPE_3(ENUM, RETURN, ARG1, ARG2, ARG3)              \
1084   builtin_types[(int) ENUM]                                              \
1085     = build_function_type                                                \
1086       (builtin_types[(int) RETURN],                                      \
1087        tree_cons (NULL_TREE,                                             \
1088                   builtin_types[(int) ARG1],                             \
1089                   tree_cons (NULL_TREE,                                  \
1090                              builtin_types[(int) ARG2],                  \
1091                              tree_cons (NULL_TREE,                       \
1092                                         builtin_types[(int) ARG3],       \
1093                                         void_list_node))));
1094 #define DEF_FUNCTION_TYPE_4(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4)       \
1095   builtin_types[(int) ENUM]                                             \
1096     = build_function_type                                               \
1097       (builtin_types[(int) RETURN],                                     \
1098        tree_cons (NULL_TREE,                                            \
1099                   builtin_types[(int) ARG1],                            \
1100                   tree_cons (NULL_TREE,                                 \
1101                              builtin_types[(int) ARG2],                 \
1102                              tree_cons                                  \
1103                              (NULL_TREE,                                \
1104                               builtin_types[(int) ARG3],                \
1105                               tree_cons (NULL_TREE,                     \
1106                                          builtin_types[(int) ARG4],     \
1107                                          void_list_node)))));
1108 #define DEF_FUNCTION_TYPE_5(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) \
1109   builtin_types[(int) ENUM]                                             \
1110     = build_function_type                                               \
1111       (builtin_types[(int) RETURN],                                     \
1112        tree_cons (NULL_TREE,                                            \
1113                   builtin_types[(int) ARG1],                            \
1114                   tree_cons (NULL_TREE,                                 \
1115                              builtin_types[(int) ARG2],                 \
1116                              tree_cons                                  \
1117                              (NULL_TREE,                                \
1118                               builtin_types[(int) ARG3],                \
1119                               tree_cons (NULL_TREE,                     \
1120                                          builtin_types[(int) ARG4],     \
1121                                          tree_cons (NULL_TREE,          \
1122                                               builtin_types[(int) ARG5],\
1123                                               void_list_node))))));
1124 #define DEF_FUNCTION_TYPE_6(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \
1125                             ARG6)                                       \
1126   builtin_types[(int) ENUM]                                             \
1127     = build_function_type                                               \
1128       (builtin_types[(int) RETURN],                                     \
1129        tree_cons (NULL_TREE,                                            \
1130                   builtin_types[(int) ARG1],                            \
1131                   tree_cons (NULL_TREE,                                 \
1132                              builtin_types[(int) ARG2],                 \
1133                              tree_cons                                  \
1134                              (NULL_TREE,                                \
1135                               builtin_types[(int) ARG3],                \
1136                               tree_cons                                 \
1137                               (NULL_TREE,                               \
1138                                builtin_types[(int) ARG4],               \
1139                                tree_cons (NULL_TREE,                    \
1140                                          builtin_types[(int) ARG5],     \
1141                                          tree_cons (NULL_TREE,          \
1142                                               builtin_types[(int) ARG6],\
1143                                               void_list_node)))))));
1144 #define DEF_FUNCTION_TYPE_7(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \
1145                             ARG6, ARG7)                                 \
1146   builtin_types[(int) ENUM]                                             \
1147     = build_function_type                                               \
1148       (builtin_types[(int) RETURN],                                     \
1149        tree_cons (NULL_TREE,                                            \
1150                   builtin_types[(int) ARG1],                            \
1151                   tree_cons (NULL_TREE,                                 \
1152                              builtin_types[(int) ARG2],                 \
1153                              tree_cons                                  \
1154                              (NULL_TREE,                                \
1155                               builtin_types[(int) ARG3],                \
1156                               tree_cons                                 \
1157                               (NULL_TREE,                               \
1158                                builtin_types[(int) ARG4],               \
1159                                tree_cons (NULL_TREE,                    \
1160                                          builtin_types[(int) ARG5],     \
1161                                          tree_cons (NULL_TREE,          \
1162                                               builtin_types[(int) ARG6],\
1163                                          tree_cons (NULL_TREE,          \
1164                                               builtin_types[(int) ARG6], \
1165                                               void_list_node))))))));
1166 #define DEF_FUNCTION_TYPE_VAR_0(ENUM, RETURN)                           \
1167   builtin_types[(int) ENUM]                                             \
1168     = build_function_type (builtin_types[(int) RETURN], NULL_TREE);
1169 #define DEF_POINTER_TYPE(ENUM, TYPE)                    \
1170   builtin_types[(int) ENUM]                             \
1171     = build_pointer_type (builtin_types[(int) TYPE]);
1172 #include "types.def"
1173 #undef DEF_PRIMITIVE_TYPE
1174 #undef DEF_FUNCTION_TYPE_1
1175 #undef DEF_FUNCTION_TYPE_2
1176 #undef DEF_FUNCTION_TYPE_3
1177 #undef DEF_FUNCTION_TYPE_4
1178 #undef DEF_FUNCTION_TYPE_5
1179 #undef DEF_FUNCTION_TYPE_6
1180 #undef DEF_FUNCTION_TYPE_VAR_0
1181 #undef DEF_POINTER_TYPE
1182   builtin_types[(int) BT_LAST] = NULL_TREE;
1183
1184   /* Initialize synchronization builtins.  */
1185 #undef DEF_SYNC_BUILTIN
1186 #define DEF_SYNC_BUILTIN(code, name, type, attr) \
1187     gfc_define_builtin (name, builtin_types[type], code, name, \
1188                         attr == ATTR_CONST_NOTHROW_LIST);
1189 #include "../sync-builtins.def"
1190 #undef DEF_SYNC_BUILTIN
1191
1192   if (gfc_option.flag_openmp || flag_tree_parallelize_loops)
1193     {
1194 #undef DEF_GOMP_BUILTIN
1195 #define DEF_GOMP_BUILTIN(code, name, type, attr) \
1196       gfc_define_builtin ("__builtin_" name, builtin_types[type], \
1197                           code, name, attr == ATTR_CONST_NOTHROW_LIST);
1198 #include "../omp-builtins.def"
1199 #undef DEF_GOMP_BUILTIN
1200     }
1201
1202   gfc_define_builtin ("__builtin_trap", builtin_types[BT_FN_VOID],
1203                       BUILT_IN_TRAP, NULL, false);
1204   TREE_THIS_VOLATILE (built_in_decls[BUILT_IN_TRAP]) = 1;
1205
1206   gfc_define_builtin ("__emutls_get_address",
1207                       builtin_types[BT_FN_PTR_PTR], BUILT_IN_EMUTLS_GET_ADDRESS,
1208                       "__emutls_get_address", true);
1209   gfc_define_builtin ("__emutls_register_common",
1210                       builtin_types[BT_FN_VOID_PTR_WORD_WORD_PTR],
1211                       BUILT_IN_EMUTLS_REGISTER_COMMON,
1212                       "__emutls_register_common", false);
1213
1214   build_common_builtin_nodes ();
1215   targetm.init_builtins ();
1216 }
1217
1218 #undef DEFINE_MATH_BUILTIN_C
1219 #undef DEFINE_MATH_BUILTIN
1220
1221 static void
1222 gfc_init_ts (void)
1223 {
1224   tree_contains_struct[NAMESPACE_DECL][TS_DECL_NON_COMMON] = 1;
1225   tree_contains_struct[NAMESPACE_DECL][TS_DECL_WITH_VIS] = 1;
1226   tree_contains_struct[NAMESPACE_DECL][TS_DECL_WRTL] = 1;
1227   tree_contains_struct[NAMESPACE_DECL][TS_DECL_COMMON] = 1;
1228   tree_contains_struct[NAMESPACE_DECL][TS_DECL_MINIMAL] = 1;
1229 }
1230
1231 void
1232 gfc_maybe_initialize_eh (void)
1233 {
1234   if (!flag_exceptions || gfc_eh_initialized_p)
1235     return;
1236
1237   gfc_eh_initialized_p = true;
1238   eh_personality_libfunc
1239     = init_one_libfunc (USING_SJLJ_EXCEPTIONS
1240                        ? "__gcc_personality_sj0"
1241                        : "__gcc_personality_v0");
1242   default_init_unwind_resume_libfunc ();
1243   using_eh_for_cleanups ();
1244 }
1245
1246
1247 #include "gt-fortran-f95-lang.h"
1248 #include "gtype-fortran.h"