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