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