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