gcc/fortran/f95-lang.c

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