gcc/fortran/trans-decl.c

   1 /* Backend function setup
   2    Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software
   3    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 /* trans-decl.c -- Handling of backend function and variable decls, etc */
  23
  24 #include "config.h"
  25 #include "system.h"
  26 #include "coretypes.h"
  27 #include "tree.h"
  28 #include "tree-dump.h"
  29 #include "gimple.h"
  30 #include "ggc.h"
  31 #include "toplev.h"
  32 #include "tm.h"
  33 #include "rtl.h"
  34 #include "target.h"
  35 #include "function.h"
  36 #include "flags.h"
  37 #include "cgraph.h"
  38 #include "gfortran.h"
  39 #include "trans.h"
  40 #include "trans-types.h"
  41 #include "trans-array.h"
  42 #include "trans-const.h"
  43 /* Only for gfc_trans_code.  Shouldn't need to include this.  */
  44 #include "trans-stmt.h"
  45
  46 #define MAX_LABEL_VALUE 99999
  47
  48
  49 /* Holds the result of the function if no result variable specified.  */
  50
  51 static GTY(()) tree current_fake_result_decl;
  52 static GTY(()) tree parent_fake_result_decl;
  53
  54 static GTY(()) tree current_function_return_label;
  55
  56
  57 /* Holds the variable DECLs for the current function.  */
  58
  59 static GTY(()) tree saved_function_decls;
  60 static GTY(()) tree saved_parent_function_decls;
  61
  62
  63 /* The namespace of the module we're currently generating.  Only used while
  64    outputting decls for module variables.  Do not rely on this being set.  */
  65
  66 static gfc_namespace *module_namespace;
  67
  68
  69 /* List of static constructor functions.  */
  70
  71 tree gfc_static_ctors;
  72
  73
  74 /* Function declarations for builtin library functions.  */
  75
  76 tree gfor_fndecl_pause_numeric;
  77 tree gfor_fndecl_pause_string;
  78 tree gfor_fndecl_stop_numeric;
  79 tree gfor_fndecl_stop_string;
  80 tree gfor_fndecl_runtime_error;
  81 tree gfor_fndecl_runtime_error_at;
  82 tree gfor_fndecl_runtime_warning_at;
  83 tree gfor_fndecl_os_error;
  84 tree gfor_fndecl_generate_error;
  85 tree gfor_fndecl_set_fpe;
  86 tree gfor_fndecl_set_options;
  87 tree gfor_fndecl_set_convert;
  88 tree gfor_fndecl_set_record_marker;
  89 tree gfor_fndecl_set_max_subrecord_length;
  90 tree gfor_fndecl_ctime;
  91 tree gfor_fndecl_fdate;
  92 tree gfor_fndecl_ttynam;
  93 tree gfor_fndecl_in_pack;
  94 tree gfor_fndecl_in_unpack;
  95 tree gfor_fndecl_associated;
  96
  97
  98 /* Math functions.  Many other math functions are handled in
  99    trans-intrinsic.c.  */
 100
 101 gfc_powdecl_list gfor_fndecl_math_powi[4][3];
 102 tree gfor_fndecl_math_ishftc4;
 103 tree gfor_fndecl_math_ishftc8;
 104 tree gfor_fndecl_math_ishftc16;
 105
 106
 107 /* String functions.  */
 108
 109 tree gfor_fndecl_compare_string;
 110 tree gfor_fndecl_concat_string;
 111 tree gfor_fndecl_string_len_trim;
 112 tree gfor_fndecl_string_index;
 113 tree gfor_fndecl_string_scan;
 114 tree gfor_fndecl_string_verify;
 115 tree gfor_fndecl_string_trim;
 116 tree gfor_fndecl_string_minmax;
 117 tree gfor_fndecl_adjustl;
 118 tree gfor_fndecl_adjustr;
 119 tree gfor_fndecl_select_string;
 120 tree gfor_fndecl_compare_string_char4;
 121 tree gfor_fndecl_concat_string_char4;
 122 tree gfor_fndecl_string_len_trim_char4;
 123 tree gfor_fndecl_string_index_char4;
 124 tree gfor_fndecl_string_scan_char4;
 125 tree gfor_fndecl_string_verify_char4;
 126 tree gfor_fndecl_string_trim_char4;
 127 tree gfor_fndecl_string_minmax_char4;
 128 tree gfor_fndecl_adjustl_char4;
 129 tree gfor_fndecl_adjustr_char4;
 130 tree gfor_fndecl_select_string_char4;
 131
 132
 133 /* Conversion between character kinds.  */
 134 tree gfor_fndecl_convert_char1_to_char4;
 135 tree gfor_fndecl_convert_char4_to_char1;
 136
 137
 138 /* Other misc. runtime library functions.  */
 139
 140 tree gfor_fndecl_size0;
 141 tree gfor_fndecl_size1;
 142 tree gfor_fndecl_iargc;
 143
 144 /* Intrinsic functions implemented in Fortran.  */
 145 tree gfor_fndecl_sc_kind;
 146 tree gfor_fndecl_si_kind;
 147 tree gfor_fndecl_sr_kind;
 148
 149 /* BLAS gemm functions.  */
 150 tree gfor_fndecl_sgemm;
 151 tree gfor_fndecl_dgemm;
 152 tree gfor_fndecl_cgemm;
 153 tree gfor_fndecl_zgemm;
 154
 155
 156 static void
 157 gfc_add_decl_to_parent_function (tree decl)
 158 {
 159   gcc_assert (decl);
 160   DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl);
 161   DECL_NONLOCAL (decl) = 1;
 162   TREE_CHAIN (decl) = saved_parent_function_decls;
 163   saved_parent_function_decls = decl;
 164 }
 165
 166 void
 167 gfc_add_decl_to_function (tree decl)
 168 {
 169   gcc_assert (decl);
 170   TREE_USED (decl) = 1;
 171   DECL_CONTEXT (decl) = current_function_decl;
 172   TREE_CHAIN (decl) = saved_function_decls;
 173   saved_function_decls = decl;
 174 }
 175
 176
 177 /* Build a  backend label declaration.  Set TREE_USED for named labels.
 178    The context of the label is always the current_function_decl.  All
 179    labels are marked artificial.  */
 180
 181 tree
 182 gfc_build_label_decl (tree label_id)
 183 {
 184   /* 2^32 temporaries should be enough.  */
 185   static unsigned int tmp_num = 1;
 186   tree label_decl;
 187   char *label_name;
 188
 189   if (label_id == NULL_TREE)
 190     {
 191       /* Build an internal label name.  */
 192       ASM_FORMAT_PRIVATE_NAME (label_name, "L", tmp_num++);
 193       label_id = get_identifier (label_name);
 194     }
 195   else
 196     label_name = NULL;
 197
 198   /* Build the LABEL_DECL node. Labels have no type.  */
 199   label_decl = build_decl (LABEL_DECL, label_id, void_type_node);
 200   DECL_CONTEXT (label_decl) = current_function_decl;
 201   DECL_MODE (label_decl) = VOIDmode;
 202
 203   /* We always define the label as used, even if the original source
 204      file never references the label.  We don't want all kinds of
 205      spurious warnings for old-style Fortran code with too many
 206      labels.  */
 207   TREE_USED (label_decl) = 1;
 208
 209   DECL_ARTIFICIAL (label_decl) = 1;
 210   return label_decl;
 211 }
 212
 213
 214 /* Returns the return label for the current function.  */
 215
 216 tree
 217 gfc_get_return_label (void)
 218 {
 219   char name[GFC_MAX_SYMBOL_LEN + 10];
 220
 221   if (current_function_return_label)
 222     return current_function_return_label;
 223
 224   sprintf (name, "__return_%s",
 225            IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
 226
 227   current_function_return_label =
 228     gfc_build_label_decl (get_identifier (name));
 229
 230   DECL_ARTIFICIAL (current_function_return_label) = 1;
 231
 232   return current_function_return_label;
 233 }
 234
 235
 236 /* Set the backend source location of a decl.  */
 237
 238 void
 239 gfc_set_decl_location (tree decl, locus * loc)
 240 {
 241   DECL_SOURCE_LOCATION (decl) = loc->lb->location;
 242 }
 243
 244
 245 /* Return the backend label declaration for a given label structure,
 246    or create it if it doesn't exist yet.  */
 247
 248 tree
 249 gfc_get_label_decl (gfc_st_label * lp)
 250 {
 251   if (lp->backend_decl)
 252     return lp->backend_decl;
 253   else
 254     {
 255       char label_name[GFC_MAX_SYMBOL_LEN + 1];
 256       tree label_decl;
 257
 258       /* Validate the label declaration from the front end.  */
 259       gcc_assert (lp != NULL && lp->value <= MAX_LABEL_VALUE);
 260
 261       /* Build a mangled name for the label.  */
 262       sprintf (label_name, "__label_%.6d", lp->value);
 263
 264       /* Build the LABEL_DECL node.  */
 265       label_decl = gfc_build_label_decl (get_identifier (label_name));
 266
 267       /* Tell the debugger where the label came from.  */
 268       if (lp->value <= MAX_LABEL_VALUE) /* An internal label.  */
 269         gfc_set_decl_location (label_decl, &lp->where);
 270       else
 271         DECL_ARTIFICIAL (label_decl) = 1;
 272
 273       /* Store the label in the label list and return the LABEL_DECL.  */
 274       lp->backend_decl = label_decl;
 275       return label_decl;
 276     }
 277 }
 278
 279
 280 /* Convert a gfc_symbol to an identifier of the same name.  */
 281
 282 static tree
 283 gfc_sym_identifier (gfc_symbol * sym)
 284 {
 285   return (get_identifier (sym->name));
 286 }
 287
 288
 289 /* Construct mangled name from symbol name.  */
 290
 291 static tree
 292 gfc_sym_mangled_identifier (gfc_symbol * sym)
 293 {
 294   char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
 295
 296   /* Prevent the mangling of identifiers that have an assigned
 297      binding label (mainly those that are bind(c)).  */
 298   if (sym->attr.is_bind_c == 1
 299       && sym->binding_label[0] != '\0')
 300     return get_identifier(sym->binding_label);
 301
 302   if (sym->module == NULL)
 303     return gfc_sym_identifier (sym);
 304   else
 305     {
 306       snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
 307       return get_identifier (name);
 308     }
 309 }
 310
 311
 312 /* Construct mangled function name from symbol name.  */
 313
 314 static tree
 315 gfc_sym_mangled_function_id (gfc_symbol * sym)
 316 {
 317   int has_underscore;
 318   char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
 319
 320   /* It may be possible to simply use the binding label if it's
 321      provided, and remove the other checks.  Then we could use it
 322      for other things if we wished.  */
 323   if ((sym->attr.is_bind_c == 1 || sym->attr.is_iso_c == 1) &&
 324       sym->binding_label[0] != '\0')
 325     /* use the binding label rather than the mangled name */
 326     return get_identifier (sym->binding_label);
 327
 328   if (sym->module == NULL || sym->attr.proc == PROC_EXTERNAL
 329       || (sym->module != NULL && (sym->attr.external
 330             || sym->attr.if_source == IFSRC_IFBODY)))
 331     {
 332       /* Main program is mangled into MAIN__.  */
 333       if (sym->attr.is_main_program)
 334         return get_identifier ("MAIN__");
 335
 336       /* Intrinsic procedures are never mangled.  */
 337       if (sym->attr.proc == PROC_INTRINSIC)
 338         return get_identifier (sym->name);
 339
 340       if (gfc_option.flag_underscoring)
 341         {
 342           has_underscore = strchr (sym->name, '_') != 0;
 343           if (gfc_option.flag_second_underscore && has_underscore)
 344             snprintf (name, sizeof name, "%s__", sym->name);
 345           else
 346             snprintf (name, sizeof name, "%s_", sym->name);
 347           return get_identifier (name);
 348         }
 349       else
 350         return get_identifier (sym->name);
 351     }
 352   else
 353     {
 354       snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
 355       return get_identifier (name);
 356     }
 357 }
 358
 359
 360 /* Returns true if a variable of specified size should go on the stack.  */
 361
 362 int
 363 gfc_can_put_var_on_stack (tree size)
 364 {
 365   unsigned HOST_WIDE_INT low;
 366
 367   if (!INTEGER_CST_P (size))
 368     return 0;
 369
 370   if (gfc_option.flag_max_stack_var_size < 0)
 371     return 1;
 372
 373   if (TREE_INT_CST_HIGH (size) != 0)
 374     return 0;
 375
 376   low = TREE_INT_CST_LOW (size);
 377   if (low > (unsigned HOST_WIDE_INT) gfc_option.flag_max_stack_var_size)
 378     return 0;
 379
 380 /* TODO: Set a per-function stack size limit.  */
 381
 382   return 1;
 383 }
 384
 385
 386 /* gfc_finish_cray_pointee sets DECL_VALUE_EXPR for a Cray pointee to
 387    an expression involving its corresponding pointer.  There are
 388    2 cases; one for variable size arrays, and one for everything else,
 389    because variable-sized arrays require one fewer level of
 390    indirection.  */
 391
 392 static void
 393 gfc_finish_cray_pointee (tree decl, gfc_symbol *sym)
 394 {
 395   tree ptr_decl = gfc_get_symbol_decl (sym->cp_pointer);
 396   tree value;
 397
 398   /* Parameters need to be dereferenced.  */
 399   if (sym->cp_pointer->attr.dummy)
 400     ptr_decl = build_fold_indirect_ref (ptr_decl);
 401
 402   /* Check to see if we're dealing with a variable-sized array.  */
 403   if (sym->attr.dimension
 404       && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE)
 405     {
 406       /* These decls will be dereferenced later, so we don't dereference
 407          them here.  */
 408       value = convert (TREE_TYPE (decl), ptr_decl);
 409     }
 410   else
 411     {
 412       ptr_decl = convert (build_pointer_type (TREE_TYPE (decl)),
 413                           ptr_decl);
 414       value = build_fold_indirect_ref (ptr_decl);
 415     }
 416
 417   SET_DECL_VALUE_EXPR (decl, value);
 418   DECL_HAS_VALUE_EXPR_P (decl) = 1;
 419   GFC_DECL_CRAY_POINTEE (decl) = 1;
 420   /* This is a fake variable just for debugging purposes.  */
 421   TREE_ASM_WRITTEN (decl) = 1;
 422 }
 423
 424
 425 /* Finish processing of a declaration without an initial value.  */
 426
 427 static void
 428 gfc_finish_decl (tree decl)
 429 {
 430   gcc_assert (TREE_CODE (decl) == PARM_DECL
 431               || DECL_INITIAL (decl) == NULL_TREE);
 432
 433   if (TREE_CODE (decl) != VAR_DECL)
 434     return;
 435
 436   if (DECL_SIZE (decl) == NULL_TREE
 437       && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
 438     layout_decl (decl, 0);
 439
 440   /* A few consistency checks.  */
 441   /* A static variable with an incomplete type is an error if it is
 442      initialized. Also if it is not file scope. Otherwise, let it
 443      through, but if it is not `extern' then it may cause an error
 444      message later.  */
 445   /* An automatic variable with an incomplete type is an error.  */
 446
 447   /* We should know the storage size.  */
 448   gcc_assert (DECL_SIZE (decl) != NULL_TREE
 449               || (TREE_STATIC (decl)
 450                   ? (!DECL_INITIAL (decl) || !DECL_CONTEXT (decl))
 451                   : DECL_EXTERNAL (decl)));
 452
 453   /* The storage size should be constant.  */
 454   gcc_assert ((!DECL_EXTERNAL (decl) && !TREE_STATIC (decl))
 455               || !DECL_SIZE (decl)
 456               || TREE_CODE (DECL_SIZE (decl)) == INTEGER_CST);
 457 }
 458
 459
 460 /* Apply symbol attributes to a variable, and add it to the function scope.  */
 461
 462 static void
 463 gfc_finish_var_decl (tree decl, gfc_symbol * sym)
 464 {
 465   tree new_type;
 466   /* TREE_ADDRESSABLE means the address of this variable is actually needed.
 467      This is the equivalent of the TARGET variables.
 468      We also need to set this if the variable is passed by reference in a
 469      CALL statement.  */
 470
 471   /* Set DECL_VALUE_EXPR for Cray Pointees.  */
 472   if (sym->attr.cray_pointee)
 473     gfc_finish_cray_pointee (decl, sym);
 474
 475   if (sym->attr.target)
 476     TREE_ADDRESSABLE (decl) = 1;
 477   /* If it wasn't used we wouldn't be getting it.  */
 478   TREE_USED (decl) = 1;
 479
 480   /* Chain this decl to the pending declarations.  Don't do pushdecl()
 481      because this would add them to the current scope rather than the
 482      function scope.  */
 483   if (current_function_decl != NULL_TREE)
 484     {
 485       if (sym->ns->proc_name->backend_decl == current_function_decl
 486           || sym->result == sym)
 487         gfc_add_decl_to_function (decl);
 488       else
 489         gfc_add_decl_to_parent_function (decl);
 490     }
 491
 492   if (sym->attr.cray_pointee)
 493     return;
 494
 495   if(sym->attr.is_bind_c == 1)
 496     {
 497       /* We need to put variables that are bind(c) into the common
 498          segment of the object file, because this is what C would do.
 499          gfortran would typically put them in either the BSS or
 500          initialized data segments, and only mark them as common if
 501          they were part of common blocks.  However, if they are not put
 502          into common space, then C cannot initialize global fortran
 503          variables that it interoperates with and the draft says that
 504          either Fortran or C should be able to initialize it (but not
 505          both, of course.) (J3/04-007, section 15.3).  */
 506       TREE_PUBLIC(decl) = 1;
 507       DECL_COMMON(decl) = 1;
 508     }
 509
 510   /* If a variable is USE associated, it's always external.  */
 511   if (sym->attr.use_assoc)
 512     {
 513       DECL_EXTERNAL (decl) = 1;
 514       TREE_PUBLIC (decl) = 1;
 515     }
 516   else if (sym->module && !sym->attr.result && !sym->attr.dummy)
 517     {
 518       /* TODO: Don't set sym->module for result or dummy variables.  */
 519       gcc_assert (current_function_decl == NULL_TREE || sym->result == sym);
 520       /* This is the declaration of a module variable.  */
 521       TREE_PUBLIC (decl) = 1;
 522       TREE_STATIC (decl) = 1;
 523     }
 524
 525   /* Derived types are a bit peculiar because of the possibility of
 526      a default initializer; this must be applied each time the variable
 527      comes into scope it therefore need not be static.  These variables
 528      are SAVE_NONE but have an initializer.  Otherwise explicitly
 529      initialized variables are SAVE_IMPLICIT and explicitly saved are
 530      SAVE_EXPLICIT.  */
 531   if (!sym->attr.use_assoc
 532         && (sym->attr.save != SAVE_NONE || sym->attr.data
 533               || (sym->value && sym->ns->proc_name->attr.is_main_program)))
 534     TREE_STATIC (decl) = 1;
 535
 536   if (sym->attr.volatile_)
 537     {
 538       TREE_THIS_VOLATILE (decl) = 1;
 539       new_type = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE);
 540       TREE_TYPE (decl) = new_type;
 541     }
 542
 543   /* Keep variables larger than max-stack-var-size off stack.  */
 544   if (!sym->ns->proc_name->attr.recursive
 545       && INTEGER_CST_P (DECL_SIZE_UNIT (decl))
 546       && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
 547          /* Put variable length auto array pointers always into stack.  */
 548       && (TREE_CODE (TREE_TYPE (decl)) != POINTER_TYPE
 549           || sym->attr.dimension == 0
 550           || sym->as->type != AS_EXPLICIT
 551           || sym->attr.pointer
 552           || sym->attr.allocatable)
 553       && !DECL_ARTIFICIAL (decl))
 554     TREE_STATIC (decl) = 1;
 555
 556   /* Handle threadprivate variables.  */
 557   if (sym->attr.threadprivate
 558       && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
 559     DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
 560 }
 561
 562
 563 /* Allocate the lang-specific part of a decl.  */
 564
 565 void
 566 gfc_allocate_lang_decl (tree decl)
 567 {
 568   DECL_LANG_SPECIFIC (decl) = (struct lang_decl *)
 569     ggc_alloc_cleared (sizeof (struct lang_decl));
 570 }
 571
 572 /* Remember a symbol to generate initialization/cleanup code at function
 573    entry/exit.  */
 574
 575 static void
 576 gfc_defer_symbol_init (gfc_symbol * sym)
 577 {
 578   gfc_symbol *p;
 579   gfc_symbol *last;
 580   gfc_symbol *head;
 581
 582   /* Don't add a symbol twice.  */
 583   if (sym->tlink)
 584     return;
 585
 586   last = head = sym->ns->proc_name;
 587   p = last->tlink;
 588
 589   /* Make sure that setup code for dummy variables which are used in the
 590      setup of other variables is generated first.  */
 591   if (sym->attr.dummy)
 592     {
 593       /* Find the first dummy arg seen after us, or the first non-dummy arg.
 594          This is a circular list, so don't go past the head.  */
 595       while (p != head
 596              && (!p->attr.dummy || p->dummy_order > sym->dummy_order))
 597         {
 598           last = p;
 599           p = p->tlink;
 600         }
 601     }
 602   /* Insert in between last and p.  */
 603   last->tlink = sym;
 604   sym->tlink = p;
 605 }
 606
 607
 608 /* Create an array index type variable with function scope.  */
 609
 610 static tree
 611 create_index_var (const char * pfx, int nest)
 612 {
 613   tree decl;
 614
 615   decl = gfc_create_var_np (gfc_array_index_type, pfx);
 616   if (nest)
 617     gfc_add_decl_to_parent_function (decl);
 618   else
 619     gfc_add_decl_to_function (decl);
 620   return decl;
 621 }
 622
 623
 624 /* Create variables to hold all the non-constant bits of info for a
 625    descriptorless array.  Remember these in the lang-specific part of the
 626    type.  */
 627
 628 static void
 629 gfc_build_qualified_array (tree decl, gfc_symbol * sym)
 630 {
 631   tree type;
 632   int dim;
 633   int nest;
 634
 635   type = TREE_TYPE (decl);
 636
 637   /* We just use the descriptor, if there is one.  */
 638   if (GFC_DESCRIPTOR_TYPE_P (type))
 639     return;
 640
 641   gcc_assert (GFC_ARRAY_TYPE_P (type));
 642   nest = (sym->ns->proc_name->backend_decl != current_function_decl)
 643          && !sym->attr.contained;
 644
 645   for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)
 646     {
 647       if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
 648         {
 649           GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
 650           TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 1;
 651         }
 652       /* Don't try to use the unknown bound for assumed shape arrays.  */
 653       if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
 654           && (sym->as->type != AS_ASSUMED_SIZE
 655               || dim < GFC_TYPE_ARRAY_RANK (type) - 1))
 656         {
 657           GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
 658           TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 1;
 659         }
 660
 661       if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE)
 662         {
 663           GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest);
 664           TREE_NO_WARNING (GFC_TYPE_ARRAY_STRIDE (type, dim)) = 1;
 665         }
 666     }
 667   if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)
 668     {
 669       GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,
 670                                                         "offset");
 671       TREE_NO_WARNING (GFC_TYPE_ARRAY_OFFSET (type)) = 1;
 672
 673       if (nest)
 674         gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type));
 675       else
 676         gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));
 677     }
 678
 679   if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE
 680       && sym->as->type != AS_ASSUMED_SIZE)
 681     {
 682       GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest);
 683       TREE_NO_WARNING (GFC_TYPE_ARRAY_SIZE (type)) = 1;
 684     }
 685
 686   if (POINTER_TYPE_P (type))
 687     {
 688       gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (type)));
 689       gcc_assert (TYPE_LANG_SPECIFIC (type)
 690                   == TYPE_LANG_SPECIFIC (TREE_TYPE (type)));
 691       type = TREE_TYPE (type);
 692     }
 693
 694   if (! COMPLETE_TYPE_P (type) && GFC_TYPE_ARRAY_SIZE (type))
 695     {
 696       tree size, range;
 697
 698       size = fold_build2 (MINUS_EXPR, gfc_array_index_type,
 699                           GFC_TYPE_ARRAY_SIZE (type), gfc_index_one_node);
 700       range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
 701                                 size);
 702       TYPE_DOMAIN (type) = range;
 703       layout_type (type);
 704     }
 705 }
 706
 707
 708 /* For some dummy arguments we don't use the actual argument directly.
 709    Instead we create a local decl and use that.  This allows us to perform
 710    initialization, and construct full type information.  */
 711
 712 static tree
 713 gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
 714 {
 715   tree decl;
 716   tree type;
 717   gfc_array_spec *as;
 718   char *name;
 719   gfc_packed packed;
 720   int n;
 721   bool known_size;
 722
 723   if (sym->attr.pointer || sym->attr.allocatable)
 724     return dummy;
 725
 726   /* Add to list of variables if not a fake result variable.  */
 727   if (sym->attr.result || sym->attr.dummy)
 728     gfc_defer_symbol_init (sym);
 729
 730   type = TREE_TYPE (dummy);
 731   gcc_assert (TREE_CODE (dummy) == PARM_DECL
 732           && POINTER_TYPE_P (type));
 733
 734   /* Do we know the element size?  */
 735   known_size = sym->ts.type != BT_CHARACTER
 736           || INTEGER_CST_P (sym->ts.cl->backend_decl);
 737
 738   if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
 739     {
 740       /* For descriptorless arrays with known element size the actual
 741          argument is sufficient.  */
 742       gcc_assert (GFC_ARRAY_TYPE_P (type));
 743       gfc_build_qualified_array (dummy, sym);
 744       return dummy;
 745     }
 746
 747   type = TREE_TYPE (type);
 748   if (GFC_DESCRIPTOR_TYPE_P (type))
 749     {
 750       /* Create a descriptorless array pointer.  */
 751       as = sym->as;
 752       packed = PACKED_NO;
 753
 754       /* Even when -frepack-arrays is used, symbols with TARGET attribute
 755          are not repacked.  */
 756       if (!gfc_option.flag_repack_arrays || sym->attr.target)
 757         {
 758           if (as->type == AS_ASSUMED_SIZE)
 759             packed = PACKED_FULL;
 760         }
 761       else
 762         {
 763           if (as->type == AS_EXPLICIT)
 764             {
 765               packed = PACKED_FULL;
 766               for (n = 0; n < as->rank; n++)
 767                 {
 768                   if (!(as->upper[n]
 769                         && as->lower[n]
 770                         && as->upper[n]->expr_type == EXPR_CONSTANT
 771                         && as->lower[n]->expr_type == EXPR_CONSTANT))
 772                     packed = PACKED_PARTIAL;
 773                 }
 774             }
 775           else
 776             packed = PACKED_PARTIAL;
 777         }
 778
 779       type = gfc_typenode_for_spec (&sym->ts);
 780       type = gfc_get_nodesc_array_type (type, sym->as, packed);
 781     }
 782   else
 783     {
 784       /* We now have an expression for the element size, so create a fully
 785          qualified type.  Reset sym->backend decl or this will just return the
 786          old type.  */
 787       DECL_ARTIFICIAL (sym->backend_decl) = 1;
 788       sym->backend_decl = NULL_TREE;
 789       type = gfc_sym_type (sym);
 790       packed = PACKED_FULL;
 791     }
 792
 793   ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);
 794   decl = build_decl (VAR_DECL, get_identifier (name), type);
 795
 796   DECL_ARTIFICIAL (decl) = 1;
 797   TREE_PUBLIC (decl) = 0;
 798   TREE_STATIC (decl) = 0;
 799   DECL_EXTERNAL (decl) = 0;
 800
 801   /* We should never get deferred shape arrays here.  We used to because of
 802      frontend bugs.  */
 803   gcc_assert (sym->as->type != AS_DEFERRED);
 804
 805   if (packed == PACKED_PARTIAL)
 806     GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;
 807   else if (packed == PACKED_FULL)
 808     GFC_DECL_PACKED_ARRAY (decl) = 1;
 809
 810   gfc_build_qualified_array (decl, sym);
 811
 812   if (DECL_LANG_SPECIFIC (dummy))
 813     DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (dummy);
 814   else
 815     gfc_allocate_lang_decl (decl);
 816
 817   GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy;
 818
 819   if (sym->ns->proc_name->backend_decl == current_function_decl
 820       || sym->attr.contained)
 821     gfc_add_decl_to_function (decl);
 822   else
 823     gfc_add_decl_to_parent_function (decl);
 824
 825   return decl;
 826 }
 827
 828
 829 /* Return a constant or a variable to use as a string length.  Does not
 830    add the decl to the current scope.  */
 831
 832 static tree
 833 gfc_create_string_length (gfc_symbol * sym)
 834 {
 835   tree length;
 836
 837   gcc_assert (sym->ts.cl);
 838   gfc_conv_const_charlen (sym->ts.cl);
 839
 840   if (sym->ts.cl->backend_decl == NULL_TREE)
 841     {
 842       char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
 843
 844       /* Also prefix the mangled name.  */
 845       strcpy (&name[1], sym->name);
 846       name[0] = '.';
 847       length = build_decl (VAR_DECL, get_identifier (name),
 848                            gfc_charlen_type_node);
 849       DECL_ARTIFICIAL (length) = 1;
 850       TREE_USED (length) = 1;
 851       if (sym->ns->proc_name->tlink != NULL)
 852         gfc_defer_symbol_init (sym);
 853       sym->ts.cl->backend_decl = length;
 854     }
 855
 856   return sym->ts.cl->backend_decl;
 857 }
 858
 859 /* If a variable is assigned a label, we add another two auxiliary
 860    variables.  */
 861
 862 static void
 863 gfc_add_assign_aux_vars (gfc_symbol * sym)
 864 {
 865   tree addr;
 866   tree length;
 867   tree decl;
 868
 869   gcc_assert (sym->backend_decl);
 870
 871   decl = sym->backend_decl;
 872   gfc_allocate_lang_decl (decl);
 873   GFC_DECL_ASSIGN (decl) = 1;
 874   length = build_decl (VAR_DECL, create_tmp_var_name (sym->name),
 875                        gfc_charlen_type_node);
 876   addr = build_decl (VAR_DECL, create_tmp_var_name (sym->name),
 877                      pvoid_type_node);
 878   gfc_finish_var_decl (length, sym);
 879   gfc_finish_var_decl (addr, sym);
 880   /*  STRING_LENGTH is also used as flag. Less than -1 means that
 881       ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
 882       target label's address. Otherwise, value is the length of a format string
 883       and ASSIGN_ADDR is its address.  */
 884   if (TREE_STATIC (length))
 885     DECL_INITIAL (length) = build_int_cst (NULL_TREE, -2);
 886   else
 887     gfc_defer_symbol_init (sym);
 888
 889   GFC_DECL_STRING_LEN (decl) = length;
 890   GFC_DECL_ASSIGN_ADDR (decl) = addr;
 891 }
 892
 893 /* Return the decl for a gfc_symbol, create it if it doesn't already
 894    exist.  */
 895
 896 tree
 897 gfc_get_symbol_decl (gfc_symbol * sym)
 898 {
 899   tree decl;
 900   tree length = NULL_TREE;
 901   int byref;
 902
 903   gcc_assert (sym->attr.referenced
 904                 || sym->attr.use_assoc
 905                 || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY);
 906
 907   if (sym->ns && sym->ns->proc_name->attr.function)
 908     byref = gfc_return_by_reference (sym->ns->proc_name);
 909   else
 910     byref = 0;
 911
 912   if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
 913     {
 914       /* Return via extra parameter.  */
 915       if (sym->attr.result && byref
 916           && !sym->backend_decl)
 917         {
 918           sym->backend_decl =
 919             DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);
 920           /* For entry master function skip over the __entry
 921              argument.  */
 922           if (sym->ns->proc_name->attr.entry_master)
 923             sym->backend_decl = TREE_CHAIN (sym->backend_decl);
 924         }
 925
 926       /* Dummy variables should already have been created.  */
 927       gcc_assert (sym->backend_decl);
 928
 929       /* Create a character length variable.  */
 930       if (sym->ts.type == BT_CHARACTER)
 931         {
 932           if (sym->ts.cl->backend_decl == NULL_TREE)
 933             length = gfc_create_string_length (sym);
 934           else
 935             length = sym->ts.cl->backend_decl;
 936           if (TREE_CODE (length) == VAR_DECL
 937               && DECL_CONTEXT (length) == NULL_TREE)
 938             {
 939               /* Add the string length to the same context as the symbol.  */
 940               if (DECL_CONTEXT (sym->backend_decl) == current_function_decl)
 941                 gfc_add_decl_to_function (length);
 942               else
 943                 gfc_add_decl_to_parent_function (length);
 944
 945               gcc_assert (DECL_CONTEXT (sym->backend_decl) ==
 946                             DECL_CONTEXT (length));
 947
 948               gfc_defer_symbol_init (sym);
 949             }
 950         }
 951
 952       /* Use a copy of the descriptor for dummy arrays.  */
 953       if (sym->attr.dimension && !TREE_USED (sym->backend_decl))
 954         {
 955           decl = gfc_build_dummy_array_decl (sym, sym->backend_decl);
 956           /* Prevent the dummy from being detected as unused if it is copied.  */
 957           if (sym->backend_decl != NULL && decl != sym->backend_decl)
 958             DECL_ARTIFICIAL (sym->backend_decl) = 1;
 959           sym->backend_decl = decl;
 960         }
 961
 962       TREE_USED (sym->backend_decl) = 1;
 963       if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0)
 964         {
 965           gfc_add_assign_aux_vars (sym);
 966         }
 967       return sym->backend_decl;
 968     }
 969
 970   if (sym->backend_decl)
 971     return sym->backend_decl;
 972
 973   /* Catch function declarations.  Only used for actual parameters.  */
 974   if (sym->attr.flavor == FL_PROCEDURE)
 975     {
 976       decl = gfc_get_extern_function_decl (sym);
 977       return decl;
 978     }
 979
 980   if (sym->attr.intrinsic)
 981     internal_error ("intrinsic variable which isn't a procedure");
 982
 983   /* Create string length decl first so that they can be used in the
 984      type declaration.  */
 985   if (sym->ts.type == BT_CHARACTER)
 986     length = gfc_create_string_length (sym);
 987
 988   /* Create the decl for the variable.  */
 989   decl = build_decl (VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
 990
 991   gfc_set_decl_location (decl, &sym->declared_at);
 992
 993   /* Symbols from modules should have their assembler names mangled.
 994      This is done here rather than in gfc_finish_var_decl because it
 995      is different for string length variables.  */
 996   if (sym->module)
 997     SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_identifier (sym));
 998
 999   if (sym->attr.dimension)
1000     {
1001       /* Create variables to hold the non-constant bits of array info.  */
1002       gfc_build_qualified_array (decl, sym);
1003
1004       /* Remember this variable for allocation/cleanup.  */
1005       gfc_defer_symbol_init (sym);
1006
1007       if ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer)
1008         GFC_DECL_PACKED_ARRAY (decl) = 1;
1009     }
1010
1011   if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
1012     gfc_defer_symbol_init (sym);
1013   /* This applies a derived type default initializer.  */
1014   else if (sym->ts.type == BT_DERIVED
1015              && sym->attr.save == SAVE_NONE
1016              && !sym->attr.data
1017              && !sym->attr.allocatable
1018              && (sym->value && !sym->ns->proc_name->attr.is_main_program)
1019              && !sym->attr.use_assoc)
1020     gfc_defer_symbol_init (sym);
1021
1022   gfc_finish_var_decl (decl, sym);
1023
1024   if (sym->ts.type == BT_CHARACTER)
1025     {
1026       /* Character variables need special handling.  */
1027       gfc_allocate_lang_decl (decl);
1028
1029       if (TREE_CODE (length) != INTEGER_CST)
1030         {
1031           char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
1032
1033           if (sym->module)
1034             {
1035               /* Also prefix the mangled name for symbols from modules.  */
1036               strcpy (&name[1], sym->name);
1037               name[0] = '.';
1038               strcpy (&name[1],
1039                       IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length)));
1040               SET_DECL_ASSEMBLER_NAME (decl, get_identifier (name));
1041             }
1042           gfc_finish_var_decl (length, sym);
1043           gcc_assert (!sym->value);
1044         }
1045     }
1046   else if (sym->attr.subref_array_pointer)
1047     {
1048       /* We need the span for these beasts.  */
1049       gfc_allocate_lang_decl (decl);
1050     }
1051
1052   if (sym->attr.subref_array_pointer)
1053     {
1054       tree span;
1055       GFC_DECL_SUBREF_ARRAY_P (decl) = 1;
1056       span = build_decl (VAR_DECL, create_tmp_var_name ("span"),
1057                          gfc_array_index_type);
1058       gfc_finish_var_decl (span, sym);
1059       TREE_STATIC (span) = 1;
1060       DECL_INITIAL (span) = build_int_cst (NULL_TREE, 0);
1061
1062       GFC_DECL_SPAN (decl) = span;
1063     }
1064
1065   sym->backend_decl = decl;
1066
1067   if (sym->attr.assign)
1068     gfc_add_assign_aux_vars (sym);
1069
1070   if (TREE_STATIC (decl) && !sym->attr.use_assoc)
1071     {
1072       /* Add static initializer.  */
1073       DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1074           TREE_TYPE (decl), sym->attr.dimension,
1075           sym->attr.pointer || sym->attr.allocatable);
1076     }
1077
1078   return decl;
1079 }
1080
1081
1082 /* Substitute a temporary variable in place of the real one.  */
1083
1084 void
1085 gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
1086 {
1087   save->attr = sym->attr;
1088   save->decl = sym->backend_decl;
1089
1090   gfc_clear_attr (&sym->attr);
1091   sym->attr.referenced = 1;
1092   sym->attr.flavor = FL_VARIABLE;
1093
1094   sym->backend_decl = decl;
1095 }
1096
1097
1098 /* Restore the original variable.  */
1099
1100 void
1101 gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
1102 {
1103   sym->attr = save->attr;
1104   sym->backend_decl = save->decl;
1105 }
1106
1107
1108 /* Declare a procedure pointer.  */
1109
1110 static tree
1111 get_proc_pointer_decl (gfc_symbol *sym)
1112 {
1113   tree decl;
1114
1115   decl = sym->backend_decl;
1116   if (decl)
1117     return decl;
1118
1119   decl = build_decl (VAR_DECL, get_identifier (sym->name),
1120                      build_pointer_type (gfc_get_function_type (sym)));
1121
1122   if (sym->ns->proc_name->backend_decl == current_function_decl
1123       || sym->attr.contained)
1124     gfc_add_decl_to_function (decl);
1125   else
1126     gfc_add_decl_to_parent_function (decl);
1127
1128   sym->backend_decl = decl;
1129
1130   if (!sym->attr.use_assoc
1131         && (sym->attr.save != SAVE_NONE || sym->attr.data
1132               || (sym->value && sym->ns->proc_name->attr.is_main_program)))
1133     TREE_STATIC (decl) = 1;
1134
1135   if (TREE_STATIC (decl) && sym->value)
1136     {
1137       /* Add static initializer.  */
1138       DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1139           TREE_TYPE (decl), sym->attr.dimension, sym->attr.proc_pointer);
1140     }
1141
1142   return decl;
1143 }
1144
1145
1146 /* Get a basic decl for an external function.  */
1147
1148 tree
1149 gfc_get_extern_function_decl (gfc_symbol * sym)
1150 {
1151   tree type;
1152   tree fndecl;
1153   gfc_expr e;
1154   gfc_intrinsic_sym *isym;
1155   gfc_expr argexpr;
1156   char s[GFC_MAX_SYMBOL_LEN + 23]; /* "_gfortran_f2c_specific" and '\0'.  */
1157   tree name;
1158   tree mangled_name;
1159
1160   if (sym->backend_decl)
1161     return sym->backend_decl;
1162
1163   /* We should never be creating external decls for alternate entry points.
1164      The procedure may be an alternate entry point, but we don't want/need
1165      to know that.  */
1166   gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
1167
1168   if (sym->attr.proc_pointer)
1169     return get_proc_pointer_decl (sym);
1170
1171   if (sym->attr.intrinsic)
1172     {
1173       /* Call the resolution function to get the actual name.  This is
1174          a nasty hack which relies on the resolution functions only looking
1175          at the first argument.  We pass NULL for the second argument
1176          otherwise things like AINT get confused.  */
1177       isym = gfc_find_function (sym->name);
1178       gcc_assert (isym->resolve.f0 != NULL);
1179
1180       memset (&e, 0, sizeof (e));
1181       e.expr_type = EXPR_FUNCTION;
1182
1183       memset (&argexpr, 0, sizeof (argexpr));
1184       gcc_assert (isym->formal);
1185       argexpr.ts = isym->formal->ts;
1186
1187       if (isym->formal->next == NULL)
1188         isym->resolve.f1 (&e, &argexpr);
1189       else
1190         {
1191           if (isym->formal->next->next == NULL)
1192             isym->resolve.f2 (&e, &argexpr, NULL);
1193           else
1194             {
1195               if (isym->formal->next->next->next == NULL)
1196                 isym->resolve.f3 (&e, &argexpr, NULL, NULL);
1197               else
1198                 {
1199                   /* All specific intrinsics take less than 5 arguments.  */
1200                   gcc_assert (isym->formal->next->next->next->next == NULL);
1201                   isym->resolve.f4 (&e, &argexpr, NULL, NULL, NULL);
1202                 }
1203             }
1204         }
1205
1206       if (gfc_option.flag_f2c
1207           && ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)
1208               || e.ts.type == BT_COMPLEX))
1209         {
1210           /* Specific which needs a different implementation if f2c
1211              calling conventions are used.  */
1212           sprintf (s, "_gfortran_f2c_specific%s", e.value.function.name);
1213         }
1214       else
1215         sprintf (s, "_gfortran_specific%s", e.value.function.name);
1216
1217       name = get_identifier (s);
1218       mangled_name = name;
1219     }
1220   else
1221     {
1222       name = gfc_sym_identifier (sym);
1223       mangled_name = gfc_sym_mangled_function_id (sym);
1224     }
1225
1226   type = gfc_get_function_type (sym);
1227   fndecl = build_decl (FUNCTION_DECL, name, type);
1228
1229   SET_DECL_ASSEMBLER_NAME (fndecl, mangled_name);
1230   /* If the return type is a pointer, avoid alias issues by setting
1231      DECL_IS_MALLOC to nonzero. This means that the function should be
1232      treated as if it were a malloc, meaning it returns a pointer that
1233      is not an alias.  */
1234   if (POINTER_TYPE_P (type))
1235     DECL_IS_MALLOC (fndecl) = 1;
1236
1237   /* Set the context of this decl.  */
1238   if (0 && sym->ns && sym->ns->proc_name)
1239     {
1240       /* TODO: Add external decls to the appropriate scope.  */
1241       DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
1242     }
1243   else
1244     {
1245       /* Global declaration, e.g. intrinsic subroutine.  */
1246       DECL_CONTEXT (fndecl) = NULL_TREE;
1247     }
1248
1249   DECL_EXTERNAL (fndecl) = 1;
1250
1251   /* This specifies if a function is globally addressable, i.e. it is
1252      the opposite of declaring static in C.  */
1253   TREE_PUBLIC (fndecl) = 1;
1254
1255   /* Set attributes for PURE functions. A call to PURE function in the
1256      Fortran 95 sense is both pure and without side effects in the C
1257      sense.  */
1258   if (sym->attr.pure || sym->attr.elemental)
1259     {
1260       if (sym->attr.function && !gfc_return_by_reference (sym))
1261         DECL_PURE_P (fndecl) = 1;
1262       /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
1263          parameters and don't use alternate returns (is this
1264          allowed?). In that case, calls to them are meaningless, and
1265          can be optimized away. See also in build_function_decl().  */
1266       TREE_SIDE_EFFECTS (fndecl) = 0;
1267     }
1268
1269   /* Mark non-returning functions.  */
1270   if (sym->attr.noreturn)
1271       TREE_THIS_VOLATILE(fndecl) = 1;
1272
1273   sym->backend_decl = fndecl;
1274
1275   if (DECL_CONTEXT (fndecl) == NULL_TREE)
1276     pushdecl_top_level (fndecl);
1277
1278   return fndecl;
1279 }
1280
1281
1282 /* Create a declaration for a procedure.  For external functions (in the C
1283    sense) use gfc_get_extern_function_decl.  HAS_ENTRIES is true if this is
1284    a master function with alternate entry points.  */
1285
1286 static void
1287 build_function_decl (gfc_symbol * sym)
1288 {
1289   tree fndecl, type;
1290   symbol_attribute attr;
1291   tree result_decl;
1292   gfc_formal_arglist *f;
1293
1294   gcc_assert (!sym->backend_decl);
1295   gcc_assert (!sym->attr.external);
1296
1297   /* Set the line and filename.  sym->declared_at seems to point to the
1298      last statement for subroutines, but it'll do for now.  */
1299   gfc_set_backend_locus (&sym->declared_at);
1300
1301   /* Allow only one nesting level.  Allow public declarations.  */
1302   gcc_assert (current_function_decl == NULL_TREE
1303           || DECL_CONTEXT (current_function_decl) == NULL_TREE);
1304
1305   type = gfc_get_function_type (sym);
1306   fndecl = build_decl (FUNCTION_DECL, gfc_sym_identifier (sym), type);
1307
1308   /* Perform name mangling if this is a top level or module procedure.  */
1309   if (current_function_decl == NULL_TREE)
1310     SET_DECL_ASSEMBLER_NAME (fndecl, gfc_sym_mangled_function_id (sym));
1311
1312   /* Figure out the return type of the declared function, and build a
1313      RESULT_DECL for it.  If this is a subroutine with alternate
1314      returns, build a RESULT_DECL for it.  */
1315   attr = sym->attr;
1316
1317   result_decl = NULL_TREE;
1318   /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)).  */
1319   if (attr.function)
1320     {
1321       if (gfc_return_by_reference (sym))
1322         type = void_type_node;
1323       else
1324         {
1325           if (sym->result != sym)
1326             result_decl = gfc_sym_identifier (sym->result);
1327
1328           type = TREE_TYPE (TREE_TYPE (fndecl));
1329         }
1330     }
1331   else
1332     {
1333       /* Look for alternate return placeholders.  */
1334       int has_alternate_returns = 0;
1335       for (f = sym->formal; f; f = f->next)
1336         {
1337           if (f->sym == NULL)
1338             {
1339               has_alternate_returns = 1;
1340               break;
1341             }
1342         }
1343
1344       if (has_alternate_returns)
1345         type = integer_type_node;
1346       else
1347         type = void_type_node;
1348     }
1349
1350   result_decl = build_decl (RESULT_DECL, result_decl, type);
1351   DECL_ARTIFICIAL (result_decl) = 1;
1352   DECL_IGNORED_P (result_decl) = 1;
1353   DECL_CONTEXT (result_decl) = fndecl;
1354   DECL_RESULT (fndecl) = result_decl;
1355
1356   /* Don't call layout_decl for a RESULT_DECL.
1357      layout_decl (result_decl, 0);  */
1358
1359   /* If the return type is a pointer, avoid alias issues by setting
1360      DECL_IS_MALLOC to nonzero. This means that the function should be
1361      treated as if it were a malloc, meaning it returns a pointer that
1362      is not an alias.  */
1363   if (POINTER_TYPE_P (type))
1364     DECL_IS_MALLOC (fndecl) = 1;
1365
1366   /* Set up all attributes for the function.  */
1367   DECL_CONTEXT (fndecl) = current_function_decl;
1368   DECL_EXTERNAL (fndecl) = 0;
1369
1370   /* This specifies if a function is globally visible, i.e. it is
1371      the opposite of declaring static in C.  */
1372   if (DECL_CONTEXT (fndecl) == NULL_TREE
1373       && !sym->attr.entry_master)
1374     TREE_PUBLIC (fndecl) = 1;
1375
1376   /* TREE_STATIC means the function body is defined here.  */
1377   TREE_STATIC (fndecl) = 1;
1378
1379   /* Set attributes for PURE functions. A call to a PURE function in the
1380      Fortran 95 sense is both pure and without side effects in the C
1381      sense.  */
1382   if (attr.pure || attr.elemental)
1383     {
1384       /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
1385          including an alternate return. In that case it can also be
1386          marked as PURE. See also in gfc_get_extern_function_decl().  */
1387       if (attr.function && !gfc_return_by_reference (sym))
1388         DECL_PURE_P (fndecl) = 1;
1389       TREE_SIDE_EFFECTS (fndecl) = 0;
1390     }
1391
1392   /* For -fwhole-program to work well, the main program needs to have the
1393      "externally_visible" attribute.  */
1394   if (attr.is_main_program)
1395     DECL_ATTRIBUTES (fndecl)
1396       = tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE);
1397
1398   /* Layout the function declaration and put it in the binding level
1399      of the current function.  */
1400   pushdecl (fndecl);
1401
1402   sym->backend_decl = fndecl;
1403 }
1404
1405
1406 /* Create the DECL_ARGUMENTS for a procedure.  */
1407
1408 static void
1409 create_function_arglist (gfc_symbol * sym)
1410 {
1411   tree fndecl;
1412   gfc_formal_arglist *f;
1413   tree typelist, hidden_typelist;
1414   tree arglist, hidden_arglist;
1415   tree type;
1416   tree parm;
1417
1418   fndecl = sym->backend_decl;
1419
1420   /* Build formal argument list. Make sure that their TREE_CONTEXT is
1421      the new FUNCTION_DECL node.  */
1422   arglist = NULL_TREE;
1423   hidden_arglist = NULL_TREE;
1424   typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
1425
1426   if (sym->attr.entry_master)
1427     {
1428       type = TREE_VALUE (typelist);
1429       parm = build_decl (PARM_DECL, get_identifier ("__entry"), type);
1430
1431       DECL_CONTEXT (parm) = fndecl;
1432       DECL_ARG_TYPE (parm) = type;
1433       TREE_READONLY (parm) = 1;
1434       gfc_finish_decl (parm);
1435       DECL_ARTIFICIAL (parm) = 1;
1436
1437       arglist = chainon (arglist, parm);
1438       typelist = TREE_CHAIN (typelist);
1439     }
1440
1441   if (gfc_return_by_reference (sym))
1442     {
1443       tree type = TREE_VALUE (typelist), length = NULL;
1444
1445       if (sym->ts.type == BT_CHARACTER)
1446         {
1447           /* Length of character result.  */
1448           tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
1449           gcc_assert (len_type == gfc_charlen_type_node);
1450
1451           length = build_decl (PARM_DECL,
1452                                get_identifier (".__result"),
1453                                len_type);
1454           if (!sym->ts.cl->length)
1455             {
1456               sym->ts.cl->backend_decl = length;
1457               TREE_USED (length) = 1;
1458             }
1459           gcc_assert (TREE_CODE (length) == PARM_DECL);
1460           DECL_CONTEXT (length) = fndecl;
1461           DECL_ARG_TYPE (length) = len_type;
1462           TREE_READONLY (length) = 1;
1463           DECL_ARTIFICIAL (length) = 1;
1464           gfc_finish_decl (length);
1465           if (sym->ts.cl->backend_decl == NULL
1466               || sym->ts.cl->backend_decl == length)
1467             {
1468               gfc_symbol *arg;
1469               tree backend_decl;
1470
1471               if (sym->ts.cl->backend_decl == NULL)
1472                 {
1473                   tree len = build_decl (VAR_DECL,
1474                                          get_identifier ("..__result"),
1475                                          gfc_charlen_type_node);
1476                   DECL_ARTIFICIAL (len) = 1;
1477                   TREE_USED (len) = 1;
1478                   sym->ts.cl->backend_decl = len;
1479                 }
1480
1481               /* Make sure PARM_DECL type doesn't point to incomplete type.  */
1482               arg = sym->result ? sym->result : sym;
1483               backend_decl = arg->backend_decl;
1484               /* Temporary clear it, so that gfc_sym_type creates complete
1485                  type.  */
1486               arg->backend_decl = NULL;
1487               type = gfc_sym_type (arg);
1488               arg->backend_decl = backend_decl;
1489               type = build_reference_type (type);
1490             }
1491         }
1492
1493       parm = build_decl (PARM_DECL, get_identifier ("__result"), type);
1494
1495       DECL_CONTEXT (parm) = fndecl;
1496       DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1497       TREE_READONLY (parm) = 1;
1498       DECL_ARTIFICIAL (parm) = 1;
1499       gfc_finish_decl (parm);
1500
1501       arglist = chainon (arglist, parm);
1502       typelist = TREE_CHAIN (typelist);
1503
1504       if (sym->ts.type == BT_CHARACTER)
1505         {
1506           gfc_allocate_lang_decl (parm);
1507           arglist = chainon (arglist, length);
1508           typelist = TREE_CHAIN (typelist);
1509         }
1510     }
1511
1512   hidden_typelist = typelist;
1513   for (f = sym->formal; f; f = f->next)
1514     if (f->sym != NULL) /* Ignore alternate returns.  */
1515       hidden_typelist = TREE_CHAIN (hidden_typelist);
1516
1517   for (f = sym->formal; f; f = f->next)
1518     {
1519       char name[GFC_MAX_SYMBOL_LEN + 2];
1520
1521       /* Ignore alternate returns.  */
1522       if (f->sym == NULL)
1523         continue;
1524
1525       type = TREE_VALUE (typelist);
1526
1527       if (f->sym->ts.type == BT_CHARACTER)
1528         {
1529           tree len_type = TREE_VALUE (hidden_typelist);
1530           tree length = NULL_TREE;
1531           gcc_assert (len_type == gfc_charlen_type_node);
1532
1533           strcpy (&name[1], f->sym->name);
1534           name[0] = '_';
1535           length = build_decl (PARM_DECL, get_identifier (name), len_type);
1536
1537           hidden_arglist = chainon (hidden_arglist, length);
1538           DECL_CONTEXT (length) = fndecl;
1539           DECL_ARTIFICIAL (length) = 1;
1540           DECL_ARG_TYPE (length) = len_type;
1541           TREE_READONLY (length) = 1;
1542           gfc_finish_decl (length);
1543
1544           /* TODO: Check string lengths when -fbounds-check.  */
1545
1546           /* Use the passed value for assumed length variables.  */
1547           if (!f->sym->ts.cl->length)
1548             {
1549               TREE_USED (length) = 1;
1550               gcc_assert (!f->sym->ts.cl->backend_decl);
1551               f->sym->ts.cl->backend_decl = length;
1552             }
1553
1554           hidden_typelist = TREE_CHAIN (hidden_typelist);
1555
1556           if (f->sym->ts.cl->backend_decl == NULL
1557               || f->sym->ts.cl->backend_decl == length)
1558             {
1559               if (f->sym->ts.cl->backend_decl == NULL)
1560                 gfc_create_string_length (f->sym);
1561
1562               /* Make sure PARM_DECL type doesn't point to incomplete type.  */
1563               if (f->sym->attr.flavor == FL_PROCEDURE)
1564                 type = build_pointer_type (gfc_get_function_type (f->sym));
1565               else
1566                 type = gfc_sym_type (f->sym);
1567             }
1568         }
1569
1570       /* For non-constant length array arguments, make sure they use
1571          a different type node from TYPE_ARG_TYPES type.  */
1572       if (f->sym->attr.dimension
1573           && type == TREE_VALUE (typelist)
1574           && TREE_CODE (type) == POINTER_TYPE
1575           && GFC_ARRAY_TYPE_P (type)
1576           && f->sym->as->type != AS_ASSUMED_SIZE
1577           && ! COMPLETE_TYPE_P (TREE_TYPE (type)))
1578         {
1579           if (f->sym->attr.flavor == FL_PROCEDURE)
1580             type = build_pointer_type (gfc_get_function_type (f->sym));
1581           else
1582             type = gfc_sym_type (f->sym);
1583         }
1584
1585       if (f->sym->attr.proc_pointer)
1586         type = build_pointer_type (type);
1587
1588       /* Build the argument declaration.  */
1589       parm = build_decl (PARM_DECL, gfc_sym_identifier (f->sym), type);
1590
1591       /* Fill in arg stuff.  */
1592       DECL_CONTEXT (parm) = fndecl;
1593       DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1594       /* All implementation args are read-only.  */
1595       TREE_READONLY (parm) = 1;
1596
1597       gfc_finish_decl (parm);
1598
1599       f->sym->backend_decl = parm;
1600
1601       arglist = chainon (arglist, parm);
1602       typelist = TREE_CHAIN (typelist);
1603     }
1604
1605   /* Add the hidden string length parameters, unless the procedure
1606      is bind(C).  */
1607   if (!sym->attr.is_bind_c)
1608     arglist = chainon (arglist, hidden_arglist);
1609
1610   gcc_assert (hidden_typelist == NULL_TREE
1611               || TREE_VALUE (hidden_typelist) == void_type_node);
1612   DECL_ARGUMENTS (fndecl) = arglist;
1613 }
1614
1615 /* Convert FNDECL's code to GIMPLE and handle any nested functions.  */
1616
1617 static void
1618 gfc_gimplify_function (tree fndecl)
1619 {
1620   struct cgraph_node *cgn;
1621
1622   gimplify_function_tree (fndecl);
1623   dump_function (TDI_generic, fndecl);
1624
1625   /* Generate errors for structured block violations.  */
1626   /* ??? Could be done as part of resolve_labels.  */
1627   if (flag_openmp)
1628     diagnose_omp_structured_block_errors (fndecl);
1629
1630   /* Convert all nested functions to GIMPLE now.  We do things in this order
1631      so that items like VLA sizes are expanded properly in the context of the
1632      correct function.  */
1633   cgn = cgraph_node (fndecl);
1634   for (cgn = cgn->nested; cgn; cgn = cgn->next_nested)
1635     gfc_gimplify_function (cgn->decl);
1636 }
1637
1638
1639 /* Do the setup necessary before generating the body of a function.  */
1640
1641 static void
1642 trans_function_start (gfc_symbol * sym)
1643 {
1644   tree fndecl;
1645
1646   fndecl = sym->backend_decl;
1647
1648   /* Let GCC know the current scope is this function.  */
1649   current_function_decl = fndecl;
1650
1651   /* Let the world know what we're about to do.  */
1652   announce_function (fndecl);
1653
1654   if (DECL_CONTEXT (fndecl) == NULL_TREE)
1655     {
1656       /* Create RTL for function declaration.  */
1657       rest_of_decl_compilation (fndecl, 1, 0);
1658     }
1659
1660   /* Create RTL for function definition.  */
1661   make_decl_rtl (fndecl);
1662
1663   init_function_start (fndecl);
1664
1665   /* Even though we're inside a function body, we still don't want to
1666      call expand_expr to calculate the size of a variable-sized array.
1667      We haven't necessarily assigned RTL to all variables yet, so it's
1668      not safe to try to expand expressions involving them.  */
1669   cfun->dont_save_pending_sizes_p = 1;
1670
1671   /* function.c requires a push at the start of the function.  */
1672   pushlevel (0);
1673 }
1674
1675 /* Create thunks for alternate entry points.  */
1676
1677 static void
1678 build_entry_thunks (gfc_namespace * ns)
1679 {
1680   gfc_formal_arglist *formal;
1681   gfc_formal_arglist *thunk_formal;
1682   gfc_entry_list *el;
1683   gfc_symbol *thunk_sym;
1684   stmtblock_t body;
1685   tree thunk_fndecl;
1686   tree args;
1687   tree string_args;
1688   tree tmp;
1689   locus old_loc;
1690
1691   /* This should always be a toplevel function.  */
1692   gcc_assert (current_function_decl == NULL_TREE);
1693
1694   gfc_get_backend_locus (&old_loc);
1695   for (el = ns->entries; el; el = el->next)
1696     {
1697       thunk_sym = el->sym;
1698
1699       build_function_decl (thunk_sym);
1700       create_function_arglist (thunk_sym);
1701
1702       trans_function_start (thunk_sym);
1703
1704       thunk_fndecl = thunk_sym->backend_decl;
1705
1706       gfc_start_block (&body);
1707
1708       /* Pass extra parameter identifying this entry point.  */
1709       tmp = build_int_cst (gfc_array_index_type, el->id);
1710       args = tree_cons (NULL_TREE, tmp, NULL_TREE);
1711       string_args = NULL_TREE;
1712
1713       if (thunk_sym->attr.function)
1714         {
1715           if (gfc_return_by_reference (ns->proc_name))
1716             {
1717               tree ref = DECL_ARGUMENTS (current_function_decl);
1718               args = tree_cons (NULL_TREE, ref, args);
1719               if (ns->proc_name->ts.type == BT_CHARACTER)
1720                 args = tree_cons (NULL_TREE, TREE_CHAIN (ref),
1721                                   args);
1722             }
1723         }
1724
1725       for (formal = ns->proc_name->formal; formal; formal = formal->next)
1726         {
1727           /* Ignore alternate returns.  */
1728           if (formal->sym == NULL)
1729             continue;
1730
1731           /* We don't have a clever way of identifying arguments, so resort to
1732              a brute-force search.  */
1733           for (thunk_formal = thunk_sym->formal;
1734                thunk_formal;
1735                thunk_formal = thunk_formal->next)
1736             {
1737               if (thunk_formal->sym == formal->sym)
1738                 break;
1739             }
1740
1741           if (thunk_formal)
1742             {
1743               /* Pass the argument.  */
1744               DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1;
1745               args = tree_cons (NULL_TREE, thunk_formal->sym->backend_decl,
1746                                 args);
1747               if (formal->sym->ts.type == BT_CHARACTER)
1748                 {
1749                   tmp = thunk_formal->sym->ts.cl->backend_decl;
1750                   string_args = tree_cons (NULL_TREE, tmp, string_args);
1751                 }
1752             }
1753           else
1754             {
1755               /* Pass NULL for a missing argument.  */
1756               args = tree_cons (NULL_TREE, null_pointer_node, args);
1757               if (formal->sym->ts.type == BT_CHARACTER)
1758                 {
1759                   tmp = build_int_cst (gfc_charlen_type_node, 0);
1760                   string_args = tree_cons (NULL_TREE, tmp, string_args);
1761                 }
1762             }
1763         }
1764
1765       /* Call the master function.  */
1766       args = nreverse (args);
1767       args = chainon (args, nreverse (string_args));
1768       tmp = ns->proc_name->backend_decl;
1769       tmp = build_function_call_expr (tmp, args);
1770       if (ns->proc_name->attr.mixed_entry_master)
1771         {
1772           tree union_decl, field;
1773           tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
1774
1775           union_decl = build_decl (VAR_DECL, get_identifier ("__result"),
1776                                    TREE_TYPE (master_type));
1777           DECL_ARTIFICIAL (union_decl) = 1;
1778           DECL_EXTERNAL (union_decl) = 0;
1779           TREE_PUBLIC (union_decl) = 0;
1780           TREE_USED (union_decl) = 1;
1781           layout_decl (union_decl, 0);
1782           pushdecl (union_decl);
1783
1784           DECL_CONTEXT (union_decl) = current_function_decl;
1785           tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (union_decl),
1786                              union_decl, tmp);
1787           gfc_add_expr_to_block (&body, tmp);
1788
1789           for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
1790                field; field = TREE_CHAIN (field))
1791             if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
1792                 thunk_sym->result->name) == 0)
1793               break;
1794           gcc_assert (field != NULL_TREE);
1795           tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
1796                              union_decl, field, NULL_TREE);
1797           tmp = fold_build2 (MODIFY_EXPR,
1798                              TREE_TYPE (DECL_RESULT (current_function_decl)),
1799                              DECL_RESULT (current_function_decl), tmp);
1800           tmp = build1_v (RETURN_EXPR, tmp);
1801         }
1802       else if (TREE_TYPE (DECL_RESULT (current_function_decl))
1803                != void_type_node)
1804         {
1805           tmp = fold_build2 (MODIFY_EXPR,
1806                              TREE_TYPE (DECL_RESULT (current_function_decl)),
1807                              DECL_RESULT (current_function_decl), tmp);
1808           tmp = build1_v (RETURN_EXPR, tmp);
1809         }
1810       gfc_add_expr_to_block (&body, tmp);
1811
1812       /* Finish off this function and send it for code generation.  */
1813       DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
1814       poplevel (1, 0, 1);
1815       BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
1816
1817       /* Output the GENERIC tree.  */
1818       dump_function (TDI_original, thunk_fndecl);
1819
1820       /* Store the end of the function, so that we get good line number
1821          info for the epilogue.  */
1822       cfun->function_end_locus = input_location;
1823
1824       /* We're leaving the context of this function, so zap cfun.
1825          It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
1826          tree_rest_of_compilation.  */
1827       set_cfun (NULL);
1828
1829       current_function_decl = NULL_TREE;
1830
1831       gfc_gimplify_function (thunk_fndecl);
1832       cgraph_finalize_function (thunk_fndecl, false);
1833
1834       /* We share the symbols in the formal argument list with other entry
1835          points and the master function.  Clear them so that they are
1836          recreated for each function.  */
1837       for (formal = thunk_sym->formal; formal; formal = formal->next)
1838         if (formal->sym != NULL)  /* Ignore alternate returns.  */
1839           {
1840             formal->sym->backend_decl = NULL_TREE;
1841             if (formal->sym->ts.type == BT_CHARACTER)
1842               formal->sym->ts.cl->backend_decl = NULL_TREE;
1843           }
1844
1845       if (thunk_sym->attr.function)
1846         {
1847           if (thunk_sym->ts.type == BT_CHARACTER)
1848             thunk_sym->ts.cl->backend_decl = NULL_TREE;
1849           if (thunk_sym->result->ts.type == BT_CHARACTER)
1850             thunk_sym->result->ts.cl->backend_decl = NULL_TREE;
1851         }
1852     }
1853
1854   gfc_set_backend_locus (&old_loc);
1855 }
1856
1857
1858 /* Create a decl for a function, and create any thunks for alternate entry
1859    points.  */
1860
1861 void
1862 gfc_create_function_decl (gfc_namespace * ns)
1863 {
1864   /* Create a declaration for the master function.  */
1865   build_function_decl (ns->proc_name);
1866
1867   /* Compile the entry thunks.  */
1868   if (ns->entries)
1869     build_entry_thunks (ns);
1870
1871   /* Now create the read argument list.  */
1872   create_function_arglist (ns->proc_name);
1873 }
1874
1875 /* Return the decl used to hold the function return value.  If
1876    parent_flag is set, the context is the parent_scope.  */
1877
1878 tree
1879 gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
1880 {
1881   tree decl;
1882   tree length;
1883   tree this_fake_result_decl;
1884   tree this_function_decl;
1885
1886   char name[GFC_MAX_SYMBOL_LEN + 10];
1887
1888   if (parent_flag)
1889     {
1890       this_fake_result_decl = parent_fake_result_decl;
1891       this_function_decl = DECL_CONTEXT (current_function_decl);
1892     }
1893   else
1894     {
1895       this_fake_result_decl = current_fake_result_decl;
1896       this_function_decl = current_function_decl;
1897     }
1898
1899   if (sym
1900       && sym->ns->proc_name->backend_decl == this_function_decl
1901       && sym->ns->proc_name->attr.entry_master
1902       && sym != sym->ns->proc_name)
1903     {
1904       tree t = NULL, var;
1905       if (this_fake_result_decl != NULL)
1906         for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t))
1907           if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
1908             break;
1909       if (t)
1910         return TREE_VALUE (t);
1911       decl = gfc_get_fake_result_decl (sym->ns->proc_name, parent_flag);
1912
1913       if (parent_flag)
1914         this_fake_result_decl = parent_fake_result_decl;
1915       else
1916         this_fake_result_decl = current_fake_result_decl;
1917
1918       if (decl && sym->ns->proc_name->attr.mixed_entry_master)
1919         {
1920           tree field;
1921
1922           for (field = TYPE_FIELDS (TREE_TYPE (decl));
1923                field; field = TREE_CHAIN (field))
1924             if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
1925                 sym->name) == 0)
1926               break;
1927
1928           gcc_assert (field != NULL_TREE);
1929           decl = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
1930                               decl, field, NULL_TREE);
1931         }
1932
1933       var = create_tmp_var_raw (TREE_TYPE (decl), sym->name);
1934       if (parent_flag)
1935         gfc_add_decl_to_parent_function (var);
1936       else
1937         gfc_add_decl_to_function (var);
1938
1939       SET_DECL_VALUE_EXPR (var, decl);
1940       DECL_HAS_VALUE_EXPR_P (var) = 1;
1941       GFC_DECL_RESULT (var) = 1;
1942
1943       TREE_CHAIN (this_fake_result_decl)
1944           = tree_cons (get_identifier (sym->name), var,
1945                        TREE_CHAIN (this_fake_result_decl));
1946       return var;
1947     }
1948
1949   if (this_fake_result_decl != NULL_TREE)
1950     return TREE_VALUE (this_fake_result_decl);
1951
1952   /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
1953      sym is NULL.  */
1954   if (!sym)
1955     return NULL_TREE;
1956
1957   if (sym->ts.type == BT_CHARACTER)
1958     {
1959       if (sym->ts.cl->backend_decl == NULL_TREE)
1960         length = gfc_create_string_length (sym);
1961       else
1962         length = sym->ts.cl->backend_decl;
1963       if (TREE_CODE (length) == VAR_DECL
1964           && DECL_CONTEXT (length) == NULL_TREE)
1965         gfc_add_decl_to_function (length);
1966     }
1967
1968   if (gfc_return_by_reference (sym))
1969     {
1970       decl = DECL_ARGUMENTS (this_function_decl);
1971
1972       if (sym->ns->proc_name->backend_decl == this_function_decl
1973           && sym->ns->proc_name->attr.entry_master)
1974         decl = TREE_CHAIN (decl);
1975
1976       TREE_USED (decl) = 1;
1977       if (sym->as)
1978         decl = gfc_build_dummy_array_decl (sym, decl);
1979     }
1980   else
1981     {
1982       sprintf (name, "__result_%.20s",
1983                IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
1984
1985       if (!sym->attr.mixed_entry_master && sym->attr.function)
1986         decl = build_decl (VAR_DECL, get_identifier (name),
1987                            gfc_sym_type (sym));
1988       else
1989         decl = build_decl (VAR_DECL, get_identifier (name),
1990                            TREE_TYPE (TREE_TYPE (this_function_decl)));
1991       DECL_ARTIFICIAL (decl) = 1;
1992       DECL_EXTERNAL (decl) = 0;
1993       TREE_PUBLIC (decl) = 0;
1994       TREE_USED (decl) = 1;
1995       GFC_DECL_RESULT (decl) = 1;
1996       TREE_ADDRESSABLE (decl) = 1;
1997
1998       layout_decl (decl, 0);
1999
2000       if (parent_flag)
2001         gfc_add_decl_to_parent_function (decl);
2002       else
2003         gfc_add_decl_to_function (decl);
2004     }
2005
2006   if (parent_flag)
2007     parent_fake_result_decl = build_tree_list (NULL, decl);
2008   else
2009     current_fake_result_decl = build_tree_list (NULL, decl);
2010
2011   return decl;
2012 }
2013
2014
2015 /* Builds a function decl.  The remaining parameters are the types of the
2016    function arguments.  Negative nargs indicates a varargs function.  */
2017
2018 tree
2019 gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
2020 {
2021   tree arglist;
2022   tree argtype;
2023   tree fntype;
2024   tree fndecl;
2025   va_list p;
2026   int n;
2027
2028   /* Library functions must be declared with global scope.  */
2029   gcc_assert (current_function_decl == NULL_TREE);
2030
2031   va_start (p, nargs);
2032
2033
2034   /* Create a list of the argument types.  */
2035   for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
2036     {
2037       argtype = va_arg (p, tree);
2038       arglist = gfc_chainon_list (arglist, argtype);
2039     }
2040
2041   if (nargs >= 0)
2042     {
2043       /* Terminate the list.  */
2044       arglist = gfc_chainon_list (arglist, void_type_node);
2045     }
2046
2047   /* Build the function type and decl.  */
2048   fntype = build_function_type (rettype, arglist);
2049   fndecl = build_decl (FUNCTION_DECL, name, fntype);
2050
2051   /* Mark this decl as external.  */
2052   DECL_EXTERNAL (fndecl) = 1;
2053   TREE_PUBLIC (fndecl) = 1;
2054
2055   va_end (p);
2056
2057   pushdecl (fndecl);
2058
2059   rest_of_decl_compilation (fndecl, 1, 0);
2060
2061   return fndecl;
2062 }
2063
2064 static void
2065 gfc_build_intrinsic_function_decls (void)
2066 {
2067   tree gfc_int4_type_node = gfc_get_int_type (4);
2068   tree gfc_int8_type_node = gfc_get_int_type (8);
2069   tree gfc_int16_type_node = gfc_get_int_type (16);
2070   tree gfc_logical4_type_node = gfc_get_logical_type (4);
2071   tree pchar1_type_node = gfc_get_pchar_type (1);
2072   tree pchar4_type_node = gfc_get_pchar_type (4);
2073
2074   /* String functions.  */
2075   gfor_fndecl_compare_string =
2076     gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),
2077                                      integer_type_node, 4,
2078                                      gfc_charlen_type_node, pchar1_type_node,
2079                                      gfc_charlen_type_node, pchar1_type_node);
2080
2081   gfor_fndecl_concat_string =
2082     gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),
2083                                      void_type_node, 6,
2084                                      gfc_charlen_type_node, pchar1_type_node,
2085                                      gfc_charlen_type_node, pchar1_type_node,
2086                                      gfc_charlen_type_node, pchar1_type_node);
2087
2088   gfor_fndecl_string_len_trim =
2089     gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")),
2090                                      gfc_int4_type_node, 2,
2091                                      gfc_charlen_type_node, pchar1_type_node);
2092
2093   gfor_fndecl_string_index =
2094     gfc_build_library_function_decl (get_identifier (PREFIX("string_index")),
2095                                      gfc_int4_type_node, 5,
2096                                      gfc_charlen_type_node, pchar1_type_node,
2097                                      gfc_charlen_type_node, pchar1_type_node,
2098                                      gfc_logical4_type_node);
2099
2100   gfor_fndecl_string_scan =
2101     gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")),
2102                                      gfc_int4_type_node, 5,
2103                                      gfc_charlen_type_node, pchar1_type_node,
2104                                      gfc_charlen_type_node, pchar1_type_node,
2105                                      gfc_logical4_type_node);
2106
2107   gfor_fndecl_string_verify =
2108     gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")),
2109                                      gfc_int4_type_node, 5,
2110                                      gfc_charlen_type_node, pchar1_type_node,
2111                                      gfc_charlen_type_node, pchar1_type_node,
2112                                      gfc_logical4_type_node);
2113
2114   gfor_fndecl_string_trim =
2115     gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),
2116                                      void_type_node, 4,
2117                                      build_pointer_type (gfc_charlen_type_node),
2118                                      build_pointer_type (pchar1_type_node),
2119                                      gfc_charlen_type_node, pchar1_type_node);
2120
2121   gfor_fndecl_string_minmax =
2122     gfc_build_library_function_decl (get_identifier (PREFIX("string_minmax")),
2123                                      void_type_node, -4,
2124                                      build_pointer_type (gfc_charlen_type_node),
2125                                      build_pointer_type (pchar1_type_node),
2126                                      integer_type_node, integer_type_node);
2127
2128   gfor_fndecl_adjustl =
2129     gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),
2130                                      void_type_node, 3, pchar1_type_node,
2131                                      gfc_charlen_type_node, pchar1_type_node);
2132
2133   gfor_fndecl_adjustr =
2134     gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")),
2135                                      void_type_node, 3, pchar1_type_node,
2136                                      gfc_charlen_type_node, pchar1_type_node);
2137
2138   gfor_fndecl_select_string =
2139     gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
2140                                      integer_type_node, 4, pvoid_type_node,
2141                                      integer_type_node, pchar1_type_node,
2142                                      gfc_charlen_type_node);
2143
2144   gfor_fndecl_compare_string_char4 =
2145     gfc_build_library_function_decl (get_identifier
2146                                         (PREFIX("compare_string_char4")),
2147                                      integer_type_node, 4,
2148                                      gfc_charlen_type_node, pchar4_type_node,
2149                                      gfc_charlen_type_node, pchar4_type_node);
2150
2151   gfor_fndecl_concat_string_char4 =
2152     gfc_build_library_function_decl (get_identifier
2153                                         (PREFIX("concat_string_char4")),
2154                                      void_type_node, 6,
2155                                      gfc_charlen_type_node, pchar4_type_node,
2156                                      gfc_charlen_type_node, pchar4_type_node,
2157                                      gfc_charlen_type_node, pchar4_type_node);
2158
2159   gfor_fndecl_string_len_trim_char4 =
2160     gfc_build_library_function_decl (get_identifier
2161                                         (PREFIX("string_len_trim_char4")),
2162                                      gfc_charlen_type_node, 2,
2163                                      gfc_charlen_type_node, pchar4_type_node);
2164
2165   gfor_fndecl_string_index_char4 =
2166     gfc_build_library_function_decl (get_identifier
2167                                         (PREFIX("string_index_char4")),
2168                                      gfc_charlen_type_node, 5,
2169                                      gfc_charlen_type_node, pchar4_type_node,
2170                                      gfc_charlen_type_node, pchar4_type_node,
2171                                      gfc_logical4_type_node);
2172
2173   gfor_fndecl_string_scan_char4 =
2174     gfc_build_library_function_decl (get_identifier
2175                                         (PREFIX("string_scan_char4")),
2176                                      gfc_charlen_type_node, 5,
2177                                      gfc_charlen_type_node, pchar4_type_node,
2178                                      gfc_charlen_type_node, pchar4_type_node,
2179                                      gfc_logical4_type_node);
2180
2181   gfor_fndecl_string_verify_char4 =
2182     gfc_build_library_function_decl (get_identifier
2183                                         (PREFIX("string_verify_char4")),
2184                                      gfc_charlen_type_node, 5,
2185                                      gfc_charlen_type_node, pchar4_type_node,
2186                                      gfc_charlen_type_node, pchar4_type_node,
2187                                      gfc_logical4_type_node);
2188
2189   gfor_fndecl_string_trim_char4 =
2190     gfc_build_library_function_decl (get_identifier
2191                                         (PREFIX("string_trim_char4")),
2192                                      void_type_node, 4,
2193                                      build_pointer_type (gfc_charlen_type_node),
2194                                      build_pointer_type (pchar4_type_node),
2195                                      gfc_charlen_type_node, pchar4_type_node);
2196
2197   gfor_fndecl_string_minmax_char4 =
2198     gfc_build_library_function_decl (get_identifier
2199                                         (PREFIX("string_minmax_char4")),
2200                                      void_type_node, -4,
2201                                      build_pointer_type (gfc_charlen_type_node),
2202                                      build_pointer_type (pchar4_type_node),
2203                                      integer_type_node, integer_type_node);
2204
2205   gfor_fndecl_adjustl_char4 =
2206     gfc_build_library_function_decl (get_identifier (PREFIX("adjustl_char4")),
2207                                      void_type_node, 3, pchar4_type_node,
2208                                      gfc_charlen_type_node, pchar4_type_node);
2209
2210   gfor_fndecl_adjustr_char4 =
2211     gfc_build_library_function_decl (get_identifier (PREFIX("adjustr_char4")),
2212                                      void_type_node, 3, pchar4_type_node,
2213                                      gfc_charlen_type_node, pchar4_type_node);
2214
2215   gfor_fndecl_select_string_char4 =
2216     gfc_build_library_function_decl (get_identifier
2217                                         (PREFIX("select_string_char4")),
2218                                      integer_type_node, 4, pvoid_type_node,
2219                                      integer_type_node, pvoid_type_node,
2220                                      gfc_charlen_type_node);
2221
2222
2223   /* Conversion between character kinds.  */
2224
2225   gfor_fndecl_convert_char1_to_char4 =
2226     gfc_build_library_function_decl (get_identifier
2227                                         (PREFIX("convert_char1_to_char4")),
2228                                      void_type_node, 3,
2229                                      build_pointer_type (pchar4_type_node),
2230                                      gfc_charlen_type_node, pchar1_type_node);
2231
2232   gfor_fndecl_convert_char4_to_char1 =
2233     gfc_build_library_function_decl (get_identifier
2234                                         (PREFIX("convert_char4_to_char1")),
2235                                      void_type_node, 3,
2236                                      build_pointer_type (pchar1_type_node),
2237                                      gfc_charlen_type_node, pchar4_type_node);
2238
2239   /* Misc. functions.  */
2240
2241   gfor_fndecl_ttynam =
2242     gfc_build_library_function_decl (get_identifier (PREFIX("ttynam")),
2243                                      void_type_node,
2244                                      3,
2245                                      pchar_type_node,
2246                                      gfc_charlen_type_node,
2247                                      integer_type_node);
2248
2249   gfor_fndecl_fdate =
2250     gfc_build_library_function_decl (get_identifier (PREFIX("fdate")),
2251                                      void_type_node,
2252                                      2,
2253                                      pchar_type_node,
2254                                      gfc_charlen_type_node);
2255
2256   gfor_fndecl_ctime =
2257     gfc_build_library_function_decl (get_identifier (PREFIX("ctime")),
2258                                      void_type_node,
2259                                      3,
2260                                      pchar_type_node,
2261                                      gfc_charlen_type_node,
2262                                      gfc_int8_type_node);
2263
2264   gfor_fndecl_sc_kind =
2265     gfc_build_library_function_decl (get_identifier
2266                                         (PREFIX("selected_char_kind")),
2267                                      gfc_int4_type_node, 2,
2268                                      gfc_charlen_type_node, pchar_type_node);
2269
2270   gfor_fndecl_si_kind =
2271     gfc_build_library_function_decl (get_identifier
2272                                         (PREFIX("selected_int_kind")),
2273                                      gfc_int4_type_node, 1, pvoid_type_node);
2274
2275   gfor_fndecl_sr_kind =
2276     gfc_build_library_function_decl (get_identifier
2277                                         (PREFIX("selected_real_kind")),
2278                                      gfc_int4_type_node, 2,
2279                                      pvoid_type_node, pvoid_type_node);
2280
2281   /* Power functions.  */
2282   {
2283     tree ctype, rtype, itype, jtype;
2284     int rkind, ikind, jkind;
2285 #define NIKINDS 3
2286 #define NRKINDS 4
2287     static int ikinds[NIKINDS] = {4, 8, 16};
2288     static int rkinds[NRKINDS] = {4, 8, 10, 16};
2289     char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */
2290
2291     for (ikind=0; ikind < NIKINDS; ikind++)
2292       {
2293         itype = gfc_get_int_type (ikinds[ikind]);
2294
2295         for (jkind=0; jkind < NIKINDS; jkind++)
2296           {
2297             jtype = gfc_get_int_type (ikinds[jkind]);
2298             if (itype && jtype)
2299               {
2300                 sprintf(name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
2301                         ikinds[jkind]);
2302                 gfor_fndecl_math_powi[jkind][ikind].integer =
2303                   gfc_build_library_function_decl (get_identifier (name),
2304                     jtype, 2, jtype, itype);
2305                 TREE_READONLY (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
2306               }
2307           }
2308
2309         for (rkind = 0; rkind < NRKINDS; rkind ++)
2310           {
2311             rtype = gfc_get_real_type (rkinds[rkind]);
2312             if (rtype && itype)
2313               {
2314                 sprintf(name, PREFIX("pow_r%d_i%d"), rkinds[rkind],
2315                         ikinds[ikind]);
2316                 gfor_fndecl_math_powi[rkind][ikind].real =
2317                   gfc_build_library_function_decl (get_identifier (name),
2318                     rtype, 2, rtype, itype);
2319                 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
2320               }
2321
2322             ctype = gfc_get_complex_type (rkinds[rkind]);
2323             if (ctype && itype)
2324               {
2325                 sprintf(name, PREFIX("pow_c%d_i%d"), rkinds[rkind],
2326                         ikinds[ikind]);
2327                 gfor_fndecl_math_powi[rkind][ikind].cmplx =
2328                   gfc_build_library_function_decl (get_identifier (name),
2329                     ctype, 2,ctype, itype);
2330                 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
2331               }
2332           }
2333       }
2334 #undef NIKINDS
2335 #undef NRKINDS
2336   }
2337
2338   gfor_fndecl_math_ishftc4 =
2339     gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")),
2340                                      gfc_int4_type_node,
2341                                      3, gfc_int4_type_node,
2342                                      gfc_int4_type_node, gfc_int4_type_node);
2343   gfor_fndecl_math_ishftc8 =
2344     gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")),
2345                                      gfc_int8_type_node,
2346                                      3, gfc_int8_type_node,
2347                                      gfc_int4_type_node, gfc_int4_type_node);
2348   if (gfc_int16_type_node)
2349     gfor_fndecl_math_ishftc16 =
2350       gfc_build_library_function_decl (get_identifier (PREFIX("ishftc16")),
2351                                        gfc_int16_type_node, 3,
2352                                        gfc_int16_type_node,
2353                                        gfc_int4_type_node,
2354                                        gfc_int4_type_node);
2355
2356   /* BLAS functions.  */
2357   {
2358     tree pint = build_pointer_type (integer_type_node);
2359     tree ps = build_pointer_type (gfc_get_real_type (gfc_default_real_kind));
2360     tree pd = build_pointer_type (gfc_get_real_type (gfc_default_double_kind));
2361     tree pc = build_pointer_type (gfc_get_complex_type (gfc_default_real_kind));
2362     tree pz = build_pointer_type
2363                 (gfc_get_complex_type (gfc_default_double_kind));
2364
2365     gfor_fndecl_sgemm = gfc_build_library_function_decl
2366                           (get_identifier
2367                              (gfc_option.flag_underscoring ? "sgemm_"
2368                                                            : "sgemm"),
2369                            void_type_node, 15, pchar_type_node,
2370                            pchar_type_node, pint, pint, pint, ps, ps, pint,
2371                            ps, pint, ps, ps, pint, integer_type_node,
2372                            integer_type_node);
2373     gfor_fndecl_dgemm = gfc_build_library_function_decl
2374                           (get_identifier
2375                              (gfc_option.flag_underscoring ? "dgemm_"
2376                                                            : "dgemm"),
2377                            void_type_node, 15, pchar_type_node,
2378                            pchar_type_node, pint, pint, pint, pd, pd, pint,
2379                            pd, pint, pd, pd, pint, integer_type_node,
2380                            integer_type_node);
2381     gfor_fndecl_cgemm = gfc_build_library_function_decl
2382                           (get_identifier
2383                              (gfc_option.flag_underscoring ? "cgemm_"
2384                                                            : "cgemm"),
2385                            void_type_node, 15, pchar_type_node,
2386                            pchar_type_node, pint, pint, pint, pc, pc, pint,
2387                            pc, pint, pc, pc, pint, integer_type_node,
2388                            integer_type_node);
2389     gfor_fndecl_zgemm = gfc_build_library_function_decl
2390                           (get_identifier
2391                              (gfc_option.flag_underscoring ? "zgemm_"
2392                                                            : "zgemm"),
2393                            void_type_node, 15, pchar_type_node,
2394                            pchar_type_node, pint, pint, pint, pz, pz, pint,
2395                            pz, pint, pz, pz, pint, integer_type_node,
2396                            integer_type_node);
2397   }
2398
2399   /* Other functions.  */
2400   gfor_fndecl_size0 =
2401     gfc_build_library_function_decl (get_identifier (PREFIX("size0")),
2402                                      gfc_array_index_type,
2403                                      1, pvoid_type_node);
2404   gfor_fndecl_size1 =
2405     gfc_build_library_function_decl (get_identifier (PREFIX("size1")),
2406                                      gfc_array_index_type,
2407                                      2, pvoid_type_node,
2408                                      gfc_array_index_type);
2409
2410   gfor_fndecl_iargc =
2411     gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),
2412                                      gfc_int4_type_node,
2413                                      0);
2414 }
2415
2416
2417 /* Make prototypes for runtime library functions.  */
2418
2419 void
2420 gfc_build_builtin_function_decls (void)
2421 {
2422   tree gfc_int4_type_node = gfc_get_int_type (4);
2423
2424   gfor_fndecl_stop_numeric =
2425     gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
2426                                      void_type_node, 1, gfc_int4_type_node);
2427   /* Stop doesn't return.  */
2428   TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
2429
2430   gfor_fndecl_stop_string =
2431     gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),
2432                                      void_type_node, 2, pchar_type_node,
2433                                      gfc_int4_type_node);
2434   /* Stop doesn't return.  */
2435   TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
2436
2437   gfor_fndecl_pause_numeric =
2438     gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
2439                                      void_type_node, 1, gfc_int4_type_node);
2440
2441   gfor_fndecl_pause_string =
2442     gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")),
2443                                      void_type_node, 2, pchar_type_node,
2444                                      gfc_int4_type_node);
2445
2446   gfor_fndecl_runtime_error =
2447     gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
2448                                      void_type_node, -1, pchar_type_node);
2449   /* The runtime_error function does not return.  */
2450   TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
2451
2452   gfor_fndecl_runtime_error_at =
2453     gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error_at")),
2454                                      void_type_node, -2, pchar_type_node,
2455                                      pchar_type_node);
2456   /* The runtime_error_at function does not return.  */
2457   TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1;
2458
2459   gfor_fndecl_runtime_warning_at =
2460     gfc_build_library_function_decl (get_identifier (PREFIX("runtime_warning_at")),
2461                                      void_type_node, -2, pchar_type_node,
2462                                      pchar_type_node);
2463   gfor_fndecl_generate_error =
2464     gfc_build_library_function_decl (get_identifier (PREFIX("generate_error")),
2465                                      void_type_node, 3, pvoid_type_node,
2466                                      integer_type_node, pchar_type_node);
2467
2468   gfor_fndecl_os_error =
2469     gfc_build_library_function_decl (get_identifier (PREFIX("os_error")),
2470                                      void_type_node, 1, pchar_type_node);
2471   /* The runtime_error function does not return.  */
2472   TREE_THIS_VOLATILE (gfor_fndecl_os_error) = 1;
2473
2474   gfor_fndecl_set_fpe =
2475     gfc_build_library_function_decl (get_identifier (PREFIX("set_fpe")),
2476                                     void_type_node, 1, integer_type_node);
2477
2478   /* Keep the array dimension in sync with the call, later in this file.  */
2479   gfor_fndecl_set_options =
2480     gfc_build_library_function_decl (get_identifier (PREFIX("set_options")),
2481                                     void_type_node, 2, integer_type_node,
2482                                     pvoid_type_node);
2483
2484   gfor_fndecl_set_convert =
2485     gfc_build_library_function_decl (get_identifier (PREFIX("set_convert")),
2486                                      void_type_node, 1, integer_type_node);
2487
2488   gfor_fndecl_set_record_marker =
2489     gfc_build_library_function_decl (get_identifier (PREFIX("set_record_marker")),
2490                                      void_type_node, 1, integer_type_node);
2491
2492   gfor_fndecl_set_max_subrecord_length =
2493     gfc_build_library_function_decl (get_identifier (PREFIX("set_max_subrecord_length")),
2494                                      void_type_node, 1, integer_type_node);
2495
2496   gfor_fndecl_in_pack = gfc_build_library_function_decl (
2497         get_identifier (PREFIX("internal_pack")),
2498         pvoid_type_node, 1, pvoid_type_node);
2499
2500   gfor_fndecl_in_unpack = gfc_build_library_function_decl (
2501         get_identifier (PREFIX("internal_unpack")),
2502         void_type_node, 2, pvoid_type_node, pvoid_type_node);
2503
2504   gfor_fndecl_associated =
2505     gfc_build_library_function_decl (
2506                                      get_identifier (PREFIX("associated")),
2507                                      integer_type_node, 2, ppvoid_type_node,
2508                                      ppvoid_type_node);
2509
2510   gfc_build_intrinsic_function_decls ();
2511   gfc_build_intrinsic_lib_fndecls ();
2512   gfc_build_io_library_fndecls ();
2513 }
2514
2515
2516 /* Evaluate the length of dummy character variables.  */
2517
2518 static tree
2519 gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl, tree fnbody)
2520 {
2521   stmtblock_t body;
2522
2523   gfc_finish_decl (cl->backend_decl);
2524
2525   gfc_start_block (&body);
2526
2527   /* Evaluate the string length expression.  */
2528   gfc_conv_string_length (cl, &body);
2529
2530   gfc_trans_vla_type_sizes (sym, &body);
2531
2532   gfc_add_expr_to_block (&body, fnbody);
2533   return gfc_finish_block (&body);
2534 }
2535
2536
2537 /* Allocate and cleanup an automatic character variable.  */
2538
2539 static tree
2540 gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
2541 {
2542   stmtblock_t body;
2543   tree decl;
2544   tree tmp;
2545
2546   gcc_assert (sym->backend_decl);
2547   gcc_assert (sym->ts.cl && sym->ts.cl->length);
2548
2549   gfc_start_block (&body);
2550
2551   /* Evaluate the string length expression.  */
2552   gfc_conv_string_length (sym->ts.cl, &body);
2553
2554   gfc_trans_vla_type_sizes (sym, &body);
2555
2556   decl = sym->backend_decl;
2557
2558   /* Emit a DECL_EXPR for this variable, which will cause the
2559      gimplifier to allocate storage, and all that good stuff.  */
2560   tmp = fold_build1 (DECL_EXPR, TREE_TYPE (decl), decl);
2561   gfc_add_expr_to_block (&body, tmp);
2562
2563   gfc_add_expr_to_block (&body, fnbody);
2564   return gfc_finish_block (&body);
2565 }
2566
2567 /* Set the initial value of ASSIGN statement auxiliary variable explicitly.  */
2568
2569 static tree
2570 gfc_trans_assign_aux_var (gfc_symbol * sym, tree fnbody)
2571 {
2572   stmtblock_t body;
2573
2574   gcc_assert (sym->backend_decl);
2575   gfc_start_block (&body);
2576
2577   /* Set the initial value to length. See the comments in
2578      function gfc_add_assign_aux_vars in this file.  */
2579   gfc_add_modify (&body, GFC_DECL_STRING_LEN (sym->backend_decl),
2580                        build_int_cst (NULL_TREE, -2));
2581
2582   gfc_add_expr_to_block (&body, fnbody);
2583   return gfc_finish_block (&body);
2584 }
2585
2586 static void
2587 gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body)
2588 {
2589   tree t = *tp, var, val;
2590
2591   if (t == NULL || t == error_mark_node)
2592     return;
2593   if (TREE_CONSTANT (t) || DECL_P (t))
2594     return;
2595
2596   if (TREE_CODE (t) == SAVE_EXPR)
2597     {
2598       if (SAVE_EXPR_RESOLVED_P (t))
2599         {
2600           *tp = TREE_OPERAND (t, 0);
2601           return;
2602         }
2603       val = TREE_OPERAND (t, 0);
2604     }
2605   else
2606     val = t;
2607
2608   var = gfc_create_var_np (TREE_TYPE (t), NULL);
2609   gfc_add_decl_to_function (var);
2610   gfc_add_modify (body, var, val);
2611   if (TREE_CODE (t) == SAVE_EXPR)
2612     TREE_OPERAND (t, 0) = var;
2613   *tp = var;
2614 }
2615
2616 static void
2617 gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
2618 {
2619   tree t;
2620
2621   if (type == NULL || type == error_mark_node)
2622     return;
2623
2624   type = TYPE_MAIN_VARIANT (type);
2625
2626   if (TREE_CODE (type) == INTEGER_TYPE)
2627     {
2628       gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body);
2629       gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body);
2630
2631       for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
2632         {
2633           TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type);
2634           TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type);
2635         }
2636     }
2637   else if (TREE_CODE (type) == ARRAY_TYPE)
2638     {
2639       gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);
2640       gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);
2641       gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body);
2642       gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body);
2643
2644       for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
2645         {
2646           TYPE_SIZE (t) = TYPE_SIZE (type);
2647           TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type);
2648         }
2649     }
2650 }
2651
2652 /* Make sure all type sizes and array domains are either constant,
2653    or variable or parameter decls.  This is a simplified variant
2654    of gimplify_type_sizes, but we can't use it here, as none of the
2655    variables in the expressions have been gimplified yet.
2656    As type sizes and domains for various variable length arrays
2657    contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
2658    time, without this routine gimplify_type_sizes in the middle-end
2659    could result in the type sizes being gimplified earlier than where
2660    those variables are initialized.  */
2661
2662 void
2663 gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
2664 {
2665   tree type = TREE_TYPE (sym->backend_decl);
2666
2667   if (TREE_CODE (type) == FUNCTION_TYPE
2668       && (sym->attr.function || sym->attr.result || sym->attr.entry))
2669     {
2670       if (! current_fake_result_decl)
2671         return;
2672
2673       type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));
2674     }
2675
2676   while (POINTER_TYPE_P (type))
2677     type = TREE_TYPE (type);
2678
2679   if (GFC_DESCRIPTOR_TYPE_P (type))
2680     {
2681       tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
2682
2683       while (POINTER_TYPE_P (etype))
2684         etype = TREE_TYPE (etype);
2685
2686       gfc_trans_vla_type_sizes_1 (etype, body);
2687     }
2688
2689   gfc_trans_vla_type_sizes_1 (type, body);
2690 }
2691
2692
2693 /* Initialize a derived type by building an lvalue from the symbol
2694    and using trans_assignment to do the work.  */
2695 tree
2696 gfc_init_default_dt (gfc_symbol * sym, tree body)
2697 {
2698   stmtblock_t fnblock;
2699   gfc_expr *e;
2700   tree tmp;
2701   tree present;
2702
2703   gfc_init_block (&fnblock);
2704   gcc_assert (!sym->attr.allocatable);
2705   gfc_set_sym_referenced (sym);
2706   e = gfc_lval_expr_from_sym (sym);
2707   tmp = gfc_trans_assignment (e, sym->value, false);
2708   if (sym->attr.dummy)
2709     {
2710       present = gfc_conv_expr_present (sym);
2711       tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
2712                     tmp, build_empty_stmt ());
2713     }
2714   gfc_add_expr_to_block (&fnblock, tmp);
2715   gfc_free_expr (e);
2716   if (body)
2717     gfc_add_expr_to_block (&fnblock, body);
2718   return gfc_finish_block (&fnblock);
2719 }
2720
2721
2722 /* Initialize INTENT(OUT) derived type dummies.  */
2723 static tree
2724 init_intent_out_dt (gfc_symbol * proc_sym, tree body)
2725 {
2726   stmtblock_t fnblock;
2727   gfc_formal_arglist *f;
2728
2729   gfc_init_block (&fnblock);
2730   for (f = proc_sym->formal; f; f = f->next)
2731     if (f->sym && f->sym->attr.intent == INTENT_OUT
2732           && f->sym->ts.type == BT_DERIVED
2733           && !f->sym->ts.derived->attr.alloc_comp
2734           && f->sym->value)
2735       body = gfc_init_default_dt (f->sym, body);
2736
2737   gfc_add_expr_to_block (&fnblock, body);
2738   return gfc_finish_block (&fnblock);
2739 }
2740
2741
2742 /* Generate function entry and exit code, and add it to the function body.
2743    This includes:
2744     Allocation and initialization of array variables.
2745     Allocation of character string variables.
2746     Initialization and possibly repacking of dummy arrays.
2747     Initialization of ASSIGN statement auxiliary variable.  */
2748
2749 static tree
2750 gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
2751 {
2752   locus loc;
2753   gfc_symbol *sym;
2754   gfc_formal_arglist *f;
2755   stmtblock_t body;
2756   bool seen_trans_deferred_array = false;
2757
2758   /* Deal with implicit return variables.  Explicit return variables will
2759      already have been added.  */
2760   if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
2761     {
2762       if (!current_fake_result_decl)
2763         {
2764           gfc_entry_list *el = NULL;
2765           if (proc_sym->attr.entry_master)
2766             {
2767               for (el = proc_sym->ns->entries; el; el = el->next)
2768                 if (el->sym != el->sym->result)
2769                   break;
2770             }
2771           /* TODO: move to the appropriate place in resolve.c.  */
2772           if (warn_return_type && el == NULL)
2773             gfc_warning ("Return value of function '%s' at %L not set",
2774                          proc_sym->name, &proc_sym->declared_at);
2775         }
2776       else if (proc_sym->as)
2777         {
2778           tree result = TREE_VALUE (current_fake_result_decl);
2779           fnbody = gfc_trans_dummy_array_bias (proc_sym, result, fnbody);
2780
2781           /* An automatic character length, pointer array result.  */
2782           if (proc_sym->ts.type == BT_CHARACTER
2783                 && TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
2784             fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,
2785                                                 fnbody);
2786         }
2787       else if (proc_sym->ts.type == BT_CHARACTER)
2788         {
2789           if (TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
2790             fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,
2791                                                 fnbody);
2792         }
2793       else
2794         gcc_assert (gfc_option.flag_f2c
2795                     && proc_sym->ts.type == BT_COMPLEX);
2796     }
2797
2798   /* Initialize the INTENT(OUT) derived type dummy arguments.  This
2799      should be done here so that the offsets and lbounds of arrays
2800      are available.  */
2801   fnbody = init_intent_out_dt (proc_sym, fnbody);
2802
2803   for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
2804     {
2805       bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
2806                                    && sym->ts.derived->attr.alloc_comp;
2807       if (sym->attr.dimension)
2808         {
2809           switch (sym->as->type)
2810             {
2811             case AS_EXPLICIT:
2812               if (sym->attr.dummy || sym->attr.result)
2813                 fnbody =
2814                   gfc_trans_dummy_array_bias (sym, sym->backend_decl, fnbody);
2815               else if (sym->attr.pointer || sym->attr.allocatable)
2816                 {
2817                   if (TREE_STATIC (sym->backend_decl))
2818                     gfc_trans_static_array_pointer (sym);
2819                   else
2820                     {
2821                       seen_trans_deferred_array = true;
2822                       fnbody = gfc_trans_deferred_array (sym, fnbody);
2823                     }
2824                 }
2825               else
2826                 {
2827                   if (sym_has_alloc_comp)
2828                     {
2829                       seen_trans_deferred_array = true;
2830                       fnbody = gfc_trans_deferred_array (sym, fnbody);
2831                     }
2832                   else if (sym->ts.type == BT_DERIVED
2833                              && sym->value
2834                              && !sym->attr.data
2835                              && sym->attr.save == SAVE_NONE)
2836                     fnbody = gfc_init_default_dt (sym, fnbody);
2837
2838                   gfc_get_backend_locus (&loc);
2839                   gfc_set_backend_locus (&sym->declared_at);
2840                   fnbody = gfc_trans_auto_array_allocation (sym->backend_decl,
2841                       sym, fnbody);
2842                   gfc_set_backend_locus (&loc);
2843                 }
2844               break;
2845
2846             case AS_ASSUMED_SIZE:
2847               /* Must be a dummy parameter.  */
2848               gcc_assert (sym->attr.dummy);
2849
2850               /* We should always pass assumed size arrays the g77 way.  */
2851               fnbody = gfc_trans_g77_array (sym, fnbody);
2852               break;
2853
2854             case AS_ASSUMED_SHAPE:
2855               /* Must be a dummy parameter.  */
2856               gcc_assert (sym->attr.dummy);
2857
2858               fnbody = gfc_trans_dummy_array_bias (sym, sym->backend_decl,
2859                                                    fnbody);
2860               break;
2861
2862             case AS_DEFERRED:
2863               seen_trans_deferred_array = true;
2864               fnbody = gfc_trans_deferred_array (sym, fnbody);
2865               break;
2866
2867             default:
2868               gcc_unreachable ();
2869             }
2870           if (sym_has_alloc_comp && !seen_trans_deferred_array)
2871             fnbody = gfc_trans_deferred_array (sym, fnbody);
2872         }
2873       else if (sym_has_alloc_comp)
2874         fnbody = gfc_trans_deferred_array (sym, fnbody);
2875       else if (sym->ts.type == BT_CHARACTER)
2876         {
2877           gfc_get_backend_locus (&loc);
2878           gfc_set_backend_locus (&sym->declared_at);
2879           if (sym->attr.dummy || sym->attr.result)
2880             fnbody = gfc_trans_dummy_character (sym, sym->ts.cl, fnbody);
2881           else
2882             fnbody = gfc_trans_auto_character_variable (sym, fnbody);
2883           gfc_set_backend_locus (&loc);
2884         }
2885       else if (sym->attr.assign)
2886         {
2887           gfc_get_backend_locus (&loc);
2888           gfc_set_backend_locus (&sym->declared_at);
2889           fnbody = gfc_trans_assign_aux_var (sym, fnbody);
2890           gfc_set_backend_locus (&loc);
2891         }
2892       else if (sym->ts.type == BT_DERIVED
2893                  && sym->value
2894                  && !sym->attr.data
2895                  && sym->attr.save == SAVE_NONE)
2896         fnbody = gfc_init_default_dt (sym, fnbody);
2897       else
2898         gcc_unreachable ();
2899     }
2900
2901   gfc_init_block (&body);
2902
2903   for (f = proc_sym->formal; f; f = f->next)
2904     {
2905       if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
2906         {
2907           gcc_assert (f->sym->ts.cl->backend_decl != NULL);
2908           if (TREE_CODE (f->sym->ts.cl->backend_decl) == PARM_DECL)
2909             gfc_trans_vla_type_sizes (f->sym, &body);
2910         }
2911     }
2912
2913   if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
2914       && current_fake_result_decl != NULL)
2915     {
2916       gcc_assert (proc_sym->ts.cl->backend_decl != NULL);
2917       if (TREE_CODE (proc_sym->ts.cl->backend_decl) == PARM_DECL)
2918         gfc_trans_vla_type_sizes (proc_sym, &body);
2919     }
2920
2921   gfc_add_expr_to_block (&body, fnbody);
2922   return gfc_finish_block (&body);
2923 }
2924
2925
2926 /* Output an initialized decl for a module variable.  */
2927
2928 static void
2929 gfc_create_module_variable (gfc_symbol * sym)
2930 {
2931   tree decl;
2932
2933   /* Module functions with alternate entries are dealt with later and
2934      would get caught by the next condition.  */
2935   if (sym->attr.entry)
2936     return;
2937
2938   /* Make sure we convert the types of the derived types from iso_c_binding
2939      into (void *).  */
2940   if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
2941       && sym->ts.type == BT_DERIVED)
2942     sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
2943
2944   /* Only output variables and array valued, or derived type,
2945      parameters.  */
2946   if (sym->attr.flavor != FL_VARIABLE
2947         && !(sym->attr.flavor == FL_PARAMETER
2948                && (sym->attr.dimension || sym->ts.type == BT_DERIVED)))
2949     return;
2950
2951   /* Don't generate variables from other modules. Variables from
2952      COMMONs will already have been generated.  */
2953   if (sym->attr.use_assoc || sym->attr.in_common)
2954     return;
2955
2956   /* Equivalenced variables arrive here after creation.  */
2957   if (sym->backend_decl
2958         && (sym->equiv_built || sym->attr.in_equivalence))
2959       return;
2960
2961   if (sym->backend_decl)
2962     internal_error ("backend decl for module variable %s already exists",
2963                     sym->name);
2964
2965   /* We always want module variables to be created.  */
2966   sym->attr.referenced = 1;
2967   /* Create the decl.  */
2968   decl = gfc_get_symbol_decl (sym);
2969
2970   /* Create the variable.  */
2971   pushdecl (decl);
2972   rest_of_decl_compilation (decl, 1, 0);
2973
2974   /* Also add length of strings.  */
2975   if (sym->ts.type == BT_CHARACTER)
2976     {
2977       tree length;
2978
2979       length = sym->ts.cl->backend_decl;
2980       if (!INTEGER_CST_P (length))
2981         {
2982           pushdecl (length);
2983           rest_of_decl_compilation (length, 1, 0);
2984         }
2985     }
2986 }
2987
2988
2989 /* Generate all the required code for module variables.  */
2990
2991 void
2992 gfc_generate_module_vars (gfc_namespace * ns)
2993 {
2994   module_namespace = ns;
2995
2996   /* Check if the frontend left the namespace in a reasonable state.  */
2997   gcc_assert (ns->proc_name && !ns->proc_name->tlink);
2998
2999   /* Generate COMMON blocks.  */
3000   gfc_trans_common (ns);
3001
3002   /* Create decls for all the module variables.  */
3003   gfc_traverse_ns (ns, gfc_create_module_variable);
3004 }
3005
3006 static void
3007 gfc_generate_contained_functions (gfc_namespace * parent)
3008 {
3009   gfc_namespace *ns;
3010
3011   /* We create all the prototypes before generating any code.  */
3012   for (ns = parent->contained; ns; ns = ns->sibling)
3013     {
3014       /* Skip namespaces from used modules.  */
3015       if (ns->parent != parent)
3016         continue;
3017
3018       gfc_create_function_decl (ns);
3019     }
3020
3021   for (ns = parent->contained; ns; ns = ns->sibling)
3022     {
3023       /* Skip namespaces from used modules.  */
3024       if (ns->parent != parent)
3025         continue;
3026
3027       gfc_generate_function_code (ns);
3028     }
3029 }
3030
3031
3032 /* Drill down through expressions for the array specification bounds and
3033    character length calling generate_local_decl for all those variables
3034    that have not already been declared.  */
3035
3036 static void
3037 generate_local_decl (gfc_symbol *);
3038
3039 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced.  */
3040
3041 static bool
3042 expr_decls (gfc_expr *e, gfc_symbol *sym,
3043             int *f ATTRIBUTE_UNUSED)
3044 {
3045   if (e->expr_type != EXPR_VARIABLE
3046             || sym == e->symtree->n.sym
3047             || e->symtree->n.sym->mark
3048             || e->symtree->n.sym->ns != sym->ns)
3049         return false;
3050
3051   generate_local_decl (e->symtree->n.sym);
3052   return false;
3053 }
3054
3055 static void
3056 generate_expr_decls (gfc_symbol *sym, gfc_expr *e)
3057 {
3058   gfc_traverse_expr (e, sym, expr_decls, 0);
3059 }
3060
3061
3062 /* Check for dependencies in the character length and array spec.  */
3063
3064 static void
3065 generate_dependency_declarations (gfc_symbol *sym)
3066 {
3067   int i;
3068
3069   if (sym->ts.type == BT_CHARACTER
3070       && sym->ts.cl
3071       && sym->ts.cl->length
3072       && sym->ts.cl->length->expr_type != EXPR_CONSTANT)
3073     generate_expr_decls (sym, sym->ts.cl->length);
3074
3075   if (sym->as && sym->as->rank)
3076     {
3077       for (i = 0; i < sym->as->rank; i++)
3078         {
3079           generate_expr_decls (sym, sym->as->lower[i]);
3080           generate_expr_decls (sym, sym->as->upper[i]);
3081         }
3082     }
3083 }
3084
3085
3086 /* Generate decls for all local variables.  We do this to ensure correct
3087    handling of expressions which only appear in the specification of
3088    other functions.  */
3089
3090 static void
3091 generate_local_decl (gfc_symbol * sym)
3092 {
3093   if (sym->attr.flavor == FL_VARIABLE)
3094     {
3095       /* Check for dependencies in the array specification and string
3096         length, adding the necessary declarations to the function.  We
3097         mark the symbol now, as well as in traverse_ns, to prevent
3098         getting stuck in a circular dependency.  */
3099       sym->mark = 1;
3100       if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
3101         generate_dependency_declarations (sym);
3102
3103       if (sym->attr.referenced)
3104         gfc_get_symbol_decl (sym);
3105       /* INTENT(out) dummy arguments are likely meant to be set.  */
3106       else if (warn_unused_variable
3107                && sym->attr.dummy
3108                && sym->attr.intent == INTENT_OUT)
3109         gfc_warning ("Dummy argument '%s' at %L was declared INTENT(OUT) but was not set",
3110                      sym->name, &sym->declared_at);
3111       /* Specific warning for unused dummy arguments. */
3112       else if (warn_unused_variable && sym->attr.dummy)
3113         gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
3114                      &sym->declared_at);
3115       /* Warn for unused variables, but not if they're inside a common
3116          block or are use-associated.  */
3117       else if (warn_unused_variable
3118                && !(sym->attr.in_common || sym->attr.use_assoc || sym->mark))
3119         gfc_warning ("Unused variable '%s' declared at %L", sym->name,
3120                      &sym->declared_at);
3121       /* For variable length CHARACTER parameters, the PARM_DECL already
3122          references the length variable, so force gfc_get_symbol_decl
3123          even when not referenced.  If optimize > 0, it will be optimized
3124          away anyway.  But do this only after emitting -Wunused-parameter
3125          warning if requested.  */
3126       if (sym->attr.dummy && ! sym->attr.referenced
3127           && sym->ts.type == BT_CHARACTER
3128           && sym->ts.cl->backend_decl != NULL
3129           && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
3130         {
3131           sym->attr.referenced = 1;
3132           gfc_get_symbol_decl (sym);
3133         }
3134
3135       /* We do not want the middle-end to warn about unused parameters
3136          as this was already done above.  */
3137       if (sym->attr.dummy && sym->backend_decl != NULL_TREE)
3138           TREE_NO_WARNING(sym->backend_decl) = 1;
3139     }
3140   else if (sym->attr.flavor == FL_PARAMETER)
3141     {
3142       if (warn_unused_parameter
3143            && !sym->attr.referenced
3144            && !sym->attr.use_assoc)
3145         gfc_warning ("Unused parameter '%s' declared at %L", sym->name,
3146                      &sym->declared_at);
3147     }
3148   else if (sym->attr.flavor == FL_PROCEDURE)
3149     {
3150       /* TODO: move to the appropriate place in resolve.c.  */
3151       if (warn_return_type
3152           && sym->attr.function
3153           && sym->result
3154           && sym != sym->result
3155           && !sym->result->attr.referenced
3156           && !sym->attr.use_assoc
3157           && sym->attr.if_source != IFSRC_IFBODY)
3158         {
3159           gfc_warning ("Return value '%s' of function '%s' declared at "
3160                        "%L not set", sym->result->name, sym->name,
3161                         &sym->result->declared_at);
3162
3163           /* Prevents "Unused variable" warning for RESULT variables.  */
3164           sym->mark = sym->result->mark = 1;
3165         }
3166     }
3167
3168   if (sym->attr.dummy == 1)
3169     {
3170       /* Modify the tree type for scalar character dummy arguments of bind(c)
3171          procedures if they are passed by value.  The tree type for them will
3172          be promoted to INTEGER_TYPE for the middle end, which appears to be
3173          what C would do with characters passed by-value.  The value attribute
3174          implies the dummy is a scalar.  */
3175       if (sym->attr.value == 1 && sym->backend_decl != NULL
3176           && sym->ts.type == BT_CHARACTER && sym->ts.is_c_interop
3177           && sym->ns->proc_name != NULL && sym->ns->proc_name->attr.is_bind_c)
3178         gfc_conv_scalar_char_value (sym, NULL, NULL);
3179     }
3180
3181   /* Make sure we convert the types of the derived types from iso_c_binding
3182      into (void *).  */
3183   if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
3184       && sym->ts.type == BT_DERIVED)
3185     sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
3186 }
3187
3188 static void
3189 generate_local_vars (gfc_namespace * ns)
3190 {
3191   gfc_traverse_ns (ns, generate_local_decl);
3192 }
3193
3194
3195 /* Generate a switch statement to jump to the correct entry point.  Also
3196    creates the label decls for the entry points.  */
3197
3198 static tree
3199 gfc_trans_entry_master_switch (gfc_entry_list * el)
3200 {
3201   stmtblock_t block;
3202   tree label;
3203   tree tmp;
3204   tree val;
3205
3206   gfc_init_block (&block);
3207   for (; el; el = el->next)
3208     {
3209       /* Add the case label.  */
3210       label = gfc_build_label_decl (NULL_TREE);
3211       val = build_int_cst (gfc_array_index_type, el->id);
3212       tmp = build3_v (CASE_LABEL_EXPR, val, NULL_TREE, label);
3213       gfc_add_expr_to_block (&block, tmp);
3214
3215       /* And jump to the actual entry point.  */
3216       label = gfc_build_label_decl (NULL_TREE);
3217       tmp = build1_v (GOTO_EXPR, label);
3218       gfc_add_expr_to_block (&block, tmp);
3219
3220       /* Save the label decl.  */
3221       el->label = label;
3222     }
3223   tmp = gfc_finish_block (&block);
3224   /* The first argument selects the entry point.  */
3225   val = DECL_ARGUMENTS (current_function_decl);
3226   tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);
3227   return tmp;
3228 }
3229
3230
3231 /* Generate code for a function.  */
3232
3233 void
3234 gfc_generate_function_code (gfc_namespace * ns)
3235 {
3236   tree fndecl;
3237   tree old_context;
3238   tree decl;
3239   tree tmp;
3240   tree tmp2;
3241   stmtblock_t block;
3242   stmtblock_t body;
3243   tree result;
3244   gfc_symbol *sym;
3245   int rank;
3246
3247   sym = ns->proc_name;
3248
3249   /* Check that the frontend isn't still using this.  */
3250   gcc_assert (sym->tlink == NULL);
3251   sym->tlink = sym;
3252
3253   /* Create the declaration for functions with global scope.  */
3254   if (!sym->backend_decl)
3255     gfc_create_function_decl (ns);
3256
3257   fndecl = sym->backend_decl;
3258   old_context = current_function_decl;
3259
3260   if (old_context)
3261     {
3262       push_function_context ();
3263       saved_parent_function_decls = saved_function_decls;
3264       saved_function_decls = NULL_TREE;
3265     }
3266
3267   trans_function_start (sym);
3268
3269   gfc_start_block (&block);
3270
3271   if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
3272     {
3273       /* Copy length backend_decls to all entry point result
3274          symbols.  */
3275       gfc_entry_list *el;
3276       tree backend_decl;
3277
3278       gfc_conv_const_charlen (ns->proc_name->ts.cl);
3279       backend_decl = ns->proc_name->result->ts.cl->backend_decl;
3280       for (el = ns->entries; el; el = el->next)
3281         el->sym->result->ts.cl->backend_decl = backend_decl;
3282     }
3283
3284   /* Translate COMMON blocks.  */
3285   gfc_trans_common (ns);
3286
3287   /* Null the parent fake result declaration if this namespace is
3288      a module function or an external procedures.  */
3289   if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
3290         || ns->parent == NULL)
3291     parent_fake_result_decl = NULL_TREE;
3292
3293   gfc_generate_contained_functions (ns);
3294
3295   generate_local_vars (ns);
3296
3297   /* Keep the parent fake result declaration in module functions
3298      or external procedures.  */
3299   if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
3300         || ns->parent == NULL)
3301     current_fake_result_decl = parent_fake_result_decl;
3302   else
3303     current_fake_result_decl = NULL_TREE;
3304
3305   current_function_return_label = NULL;
3306
3307   /* Now generate the code for the body of this function.  */
3308   gfc_init_block (&body);
3309
3310   /* If this is the main program, add a call to set_options to set up the
3311      runtime library Fortran language standard parameters.  */
3312   if (sym->attr.is_main_program)
3313     {
3314       tree array_type, array, var;
3315
3316       /* Passing a new option to the library requires four modifications:
3317            + add it to the tree_cons list below
3318            + change the array size in the call to build_array_type
3319            + change the first argument to the library call
3320              gfor_fndecl_set_options
3321            + modify the library (runtime/compile_options.c)!  */
3322       array = tree_cons (NULL_TREE,
3323                          build_int_cst (integer_type_node,
3324                                         gfc_option.warn_std), NULL_TREE);
3325       array = tree_cons (NULL_TREE,
3326                          build_int_cst (integer_type_node,
3327                                         gfc_option.allow_std), array);
3328       array = tree_cons (NULL_TREE,
3329                          build_int_cst (integer_type_node, pedantic), array);
3330       array = tree_cons (NULL_TREE,
3331                          build_int_cst (integer_type_node,
3332                                         gfc_option.flag_dump_core), array);
3333       array = tree_cons (NULL_TREE,
3334                          build_int_cst (integer_type_node,
3335                                         gfc_option.flag_backtrace), array);
3336       array = tree_cons (NULL_TREE,
3337                          build_int_cst (integer_type_node,
3338                                         gfc_option.flag_sign_zero), array);
3339
3340       array = tree_cons (NULL_TREE,
3341                          build_int_cst (integer_type_node,
3342                                         flag_bounds_check), array);
3343
3344       array = tree_cons (NULL_TREE,
3345                          build_int_cst (integer_type_node,
3346                                         gfc_option.flag_range_check), array);
3347
3348       array_type = build_array_type (integer_type_node,
3349                                      build_index_type (build_int_cst (NULL_TREE,
3350                                                                       7)));
3351       array = build_constructor_from_list (array_type, nreverse (array));
3352       TREE_CONSTANT (array) = 1;
3353       TREE_STATIC (array) = 1;
3354
3355       /* Create a static variable to hold the jump table.  */
3356       var = gfc_create_var (array_type, "options");
3357       TREE_CONSTANT (var) = 1;
3358       TREE_STATIC (var) = 1;
3359       TREE_READONLY (var) = 1;
3360       DECL_INITIAL (var) = array;
3361       var = gfc_build_addr_expr (pvoid_type_node, var);
3362
3363       tmp = build_call_expr (gfor_fndecl_set_options, 2,
3364                              build_int_cst (integer_type_node, 8), var);
3365       gfc_add_expr_to_block (&body, tmp);
3366     }
3367
3368   /* If this is the main program and a -ffpe-trap option was provided,
3369      add a call to set_fpe so that the library will raise a FPE when
3370      needed.  */
3371   if (sym->attr.is_main_program && gfc_option.fpe != 0)
3372     {
3373       tmp = build_call_expr (gfor_fndecl_set_fpe, 1,
3374                              build_int_cst (integer_type_node,
3375                                             gfc_option.fpe));
3376       gfc_add_expr_to_block (&body, tmp);
3377     }
3378
3379   /* If this is the main program and an -fconvert option was provided,
3380      add a call to set_convert.  */
3381
3382   if (sym->attr.is_main_program && gfc_option.convert != GFC_CONVERT_NATIVE)
3383     {
3384       tmp = build_call_expr (gfor_fndecl_set_convert, 1,
3385                              build_int_cst (integer_type_node,
3386                                             gfc_option.convert));
3387       gfc_add_expr_to_block (&body, tmp);
3388     }
3389
3390   /* If this is the main program and an -frecord-marker option was provided,
3391      add a call to set_record_marker.  */
3392
3393   if (sym->attr.is_main_program && gfc_option.record_marker != 0)
3394     {
3395       tmp = build_call_expr (gfor_fndecl_set_record_marker, 1,
3396                              build_int_cst (integer_type_node,
3397                                             gfc_option.record_marker));
3398       gfc_add_expr_to_block (&body, tmp);
3399     }
3400
3401   if (sym->attr.is_main_program && gfc_option.max_subrecord_length != 0)
3402     {
3403       tmp = build_call_expr (gfor_fndecl_set_max_subrecord_length,
3404                              1,
3405                              build_int_cst (integer_type_node,
3406                                             gfc_option.max_subrecord_length));
3407       gfc_add_expr_to_block (&body, tmp);
3408     }
3409
3410   if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
3411       && sym->attr.subroutine)
3412     {
3413       tree alternate_return;
3414       alternate_return = gfc_get_fake_result_decl (sym, 0);
3415       gfc_add_modify (&body, alternate_return, integer_zero_node);
3416     }
3417
3418   if (ns->entries)
3419     {
3420       /* Jump to the correct entry point.  */
3421       tmp = gfc_trans_entry_master_switch (ns->entries);
3422       gfc_add_expr_to_block (&body, tmp);
3423     }
3424
3425   tmp = gfc_trans_code (ns->code);
3426   gfc_add_expr_to_block (&body, tmp);
3427
3428   /* Add a return label if needed.  */
3429   if (current_function_return_label)
3430     {
3431       tmp = build1_v (LABEL_EXPR, current_function_return_label);
3432       gfc_add_expr_to_block (&body, tmp);
3433     }
3434
3435   tmp = gfc_finish_block (&body);
3436   /* Add code to create and cleanup arrays.  */
3437   tmp = gfc_trans_deferred_vars (sym, tmp);
3438
3439   if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
3440     {
3441       if (sym->attr.subroutine || sym == sym->result)
3442         {
3443           if (current_fake_result_decl != NULL)
3444             result = TREE_VALUE (current_fake_result_decl);
3445           else
3446             result = NULL_TREE;
3447           current_fake_result_decl = NULL_TREE;
3448         }
3449       else
3450         result = sym->result->backend_decl;
3451
3452       if (result != NULL_TREE && sym->attr.function
3453             && sym->ts.type == BT_DERIVED
3454             && sym->ts.derived->attr.alloc_comp
3455             && !sym->attr.pointer)
3456         {
3457           rank = sym->as ? sym->as->rank : 0;
3458           tmp2 = gfc_nullify_alloc_comp (sym->ts.derived, result, rank);
3459           gfc_add_expr_to_block (&block, tmp2);
3460         }
3461
3462       gfc_add_expr_to_block (&block, tmp);
3463
3464       if (result == NULL_TREE)
3465         {
3466           /* TODO: move to the appropriate place in resolve.c.  */
3467           if (warn_return_type && !sym->attr.referenced && sym == sym->result)
3468             gfc_warning ("Return value of function '%s' at %L not set",
3469                          sym->name, &sym->declared_at);
3470
3471           TREE_NO_WARNING(sym->backend_decl) = 1;
3472         }
3473       else
3474         {
3475           /* Set the return value to the dummy result variable.  The
3476              types may be different for scalar default REAL functions
3477              with -ff2c, therefore we have to convert.  */
3478           tmp = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
3479           tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (tmp),
3480                              DECL_RESULT (fndecl), tmp);
3481           tmp = build1_v (RETURN_EXPR, tmp);
3482           gfc_add_expr_to_block (&block, tmp);
3483         }
3484     }
3485   else
3486     gfc_add_expr_to_block (&block, tmp);
3487
3488
3489   /* Add all the decls we created during processing.  */
3490   decl = saved_function_decls;
3491   while (decl)
3492     {
3493       tree next;
3494
3495       next = TREE_CHAIN (decl);
3496       TREE_CHAIN (decl) = NULL_TREE;
3497       pushdecl (decl);
3498       decl = next;
3499     }
3500   saved_function_decls = NULL_TREE;
3501
3502   DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);
3503
3504   /* Finish off this function and send it for code generation.  */
3505   poplevel (1, 0, 1);
3506   BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
3507
3508   /* Output the GENERIC tree.  */
3509   dump_function (TDI_original, fndecl);
3510
3511   /* Store the end of the function, so that we get good line number
3512      info for the epilogue.  */
3513   cfun->function_end_locus = input_location;
3514
3515   /* We're leaving the context of this function, so zap cfun.
3516      It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
3517      tree_rest_of_compilation.  */
3518   set_cfun (NULL);
3519
3520   if (old_context)
3521     {
3522       pop_function_context ();
3523       saved_function_decls = saved_parent_function_decls;
3524     }
3525   current_function_decl = old_context;
3526
3527   if (decl_function_context (fndecl))
3528     /* Register this function with cgraph just far enough to get it
3529        added to our parent's nested function list.  */
3530     (void) cgraph_node (fndecl);
3531   else
3532     {
3533       gfc_gimplify_function (fndecl);
3534       cgraph_finalize_function (fndecl, false);
3535     }
3536 }
3537
3538 void
3539 gfc_generate_constructors (void)
3540 {
3541   gcc_assert (gfc_static_ctors == NULL_TREE);
3542 #if 0
3543   tree fnname;
3544   tree type;
3545   tree fndecl;
3546   tree decl;
3547   tree tmp;
3548
3549   if (gfc_static_ctors == NULL_TREE)
3550     return;
3551
3552   fnname = get_file_function_name ("I");
3553   type = build_function_type (void_type_node,
3554                               gfc_chainon_list (NULL_TREE, void_type_node));
3555
3556   fndecl = build_decl (FUNCTION_DECL, fnname, type);
3557   TREE_PUBLIC (fndecl) = 1;
3558
3559   decl = build_decl (RESULT_DECL, NULL_TREE, void_type_node);
3560   DECL_ARTIFICIAL (decl) = 1;
3561   DECL_IGNORED_P (decl) = 1;
3562   DECL_CONTEXT (decl) = fndecl;
3563   DECL_RESULT (fndecl) = decl;
3564
3565   pushdecl (fndecl);
3566
3567   current_function_decl = fndecl;
3568
3569   rest_of_decl_compilation (fndecl, 1, 0);
3570
3571   make_decl_rtl (fndecl);
3572
3573   init_function_start (fndecl);
3574
3575   pushlevel (0);
3576
3577   for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
3578     {
3579       tmp = build_call_expr (TREE_VALUE (gfc_static_ctors), 0);
3580       DECL_SAVED_TREE (fndecl) = build_stmt (EXPR_STMT, tmp);
3581     }
3582
3583   poplevel (1, 0, 1);
3584
3585   BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
3586
3587   free_after_parsing (cfun);
3588   free_after_compilation (cfun);
3589
3590   tree_rest_of_compilation (fndecl);
3591
3592   current_function_decl = NULL_TREE;
3593 #endif
3594 }
3595
3596 /* Translates a BLOCK DATA program unit. This means emitting the
3597    commons contained therein plus their initializations. We also emit
3598    a globally visible symbol to make sure that each BLOCK DATA program
3599    unit remains unique.  */
3600
3601 void
3602 gfc_generate_block_data (gfc_namespace * ns)
3603 {
3604   tree decl;
3605   tree id;
3606
3607   /* Tell the backend the source location of the block data.  */
3608   if (ns->proc_name)
3609     gfc_set_backend_locus (&ns->proc_name->declared_at);
3610   else
3611     gfc_set_backend_locus (&gfc_current_locus);
3612
3613   /* Process the DATA statements.  */
3614   gfc_trans_common (ns);
3615
3616   /* Create a global symbol with the mane of the block data.  This is to
3617      generate linker errors if the same name is used twice.  It is never
3618      really used.  */
3619   if (ns->proc_name)
3620     id = gfc_sym_mangled_function_id (ns->proc_name);
3621   else
3622     id = get_identifier ("__BLOCK_DATA__");
3623
3624   decl = build_decl (VAR_DECL, id, gfc_array_index_type);
3625   TREE_PUBLIC (decl) = 1;
3626   TREE_STATIC (decl) = 1;
3627
3628   pushdecl (decl);
3629   rest_of_decl_compilation (decl, 1, 0);
3630 }
3631
3632
3633 #include "gt-fortran-trans-decl.h"