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