gcc/fortran/trans-decl.c

   1 /* Backend function setup
   2    Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
   3    Free Software Foundation, Inc.
   4    Contributed by Paul Brook
   5
   6 This file is part of GCC.
   7
   8 GCC is free software; you can redistribute it and/or modify it under
   9 the terms of the GNU General Public License as published by the Free
  10 Software Foundation; either version 3, or (at your option) any later
  11 version.
  12
  13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  16 for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GCC; see the file COPYING3.  If not see
  20 <http://www.gnu.org/licenses/>.  */
  21
  22 /* trans-decl.c -- Handling of backend function and variable decls, etc */
  23
  24 #include "config.h"
  25 #include "system.h"
  26 #include "coretypes.h"
  27 #include "tree.h"
  28 #include "tree-dump.h"
  29 #include "gimple.h"
  30 #include "ggc.h"
  31 #include "toplev.h"
  32 #include "tm.h"
  33 #include "rtl.h"
  34 #include "target.h"
  35 #include "function.h"
  36 #include "flags.h"
  37 #include "cgraph.h"
  38 #include "debug.h"
  39 #include "gfortran.h"
  40 #include "pointer-set.h"
  41 #include "constructor.h"
  42 #include "trans.h"
  43 #include "trans-types.h"
  44 #include "trans-array.h"
  45 #include "trans-const.h"
  46 /* Only for gfc_trans_code.  Shouldn't need to include this.  */
  47 #include "trans-stmt.h"
  48
  49 #define MAX_LABEL_VALUE 99999
  50
  51
  52 /* Holds the result of the function if no result variable specified.  */
  53
  54 static GTY(()) tree current_fake_result_decl;
  55 static GTY(()) tree parent_fake_result_decl;
  56
  57 static GTY(()) tree current_function_return_label;
  58
  59
  60 /* Holds the variable DECLs for the current function.  */
  61
  62 static GTY(()) tree saved_function_decls;
  63 static GTY(()) tree saved_parent_function_decls;
  64
  65 static struct pointer_set_t *nonlocal_dummy_decl_pset;
  66 static GTY(()) tree nonlocal_dummy_decls;
  67
  68 /* Holds the variable DECLs that are locals.  */
  69
  70 static GTY(()) tree saved_local_decls;
  71
  72 /* The namespace of the module we're currently generating.  Only used while
  73    outputting decls for module variables.  Do not rely on this being set.  */
  74
  75 static gfc_namespace *module_namespace;
  76
  77
  78 /* List of static constructor functions.  */
  79
  80 tree gfc_static_ctors;
  81
  82
  83 /* Function declarations for builtin library functions.  */
  84
  85 tree gfor_fndecl_pause_numeric;
  86 tree gfor_fndecl_pause_string;
  87 tree gfor_fndecl_stop_numeric;
  88 tree gfor_fndecl_stop_string;
  89 tree gfor_fndecl_error_stop_string;
  90 tree gfor_fndecl_runtime_error;
  91 tree gfor_fndecl_runtime_error_at;
  92 tree gfor_fndecl_runtime_warning_at;
  93 tree gfor_fndecl_os_error;
  94 tree gfor_fndecl_generate_error;
  95 tree gfor_fndecl_set_args;
  96 tree gfor_fndecl_set_fpe;
  97 tree gfor_fndecl_set_options;
  98 tree gfor_fndecl_set_convert;
  99 tree gfor_fndecl_set_record_marker;
 100 tree gfor_fndecl_set_max_subrecord_length;
 101 tree gfor_fndecl_ctime;
 102 tree gfor_fndecl_fdate;
 103 tree gfor_fndecl_ttynam;
 104 tree gfor_fndecl_in_pack;
 105 tree gfor_fndecl_in_unpack;
 106 tree gfor_fndecl_associated;
 107
 108
 109 /* Math functions.  Many other math functions are handled in
 110    trans-intrinsic.c.  */
 111
 112 gfc_powdecl_list gfor_fndecl_math_powi[4][3];
 113 tree gfor_fndecl_math_ishftc4;
 114 tree gfor_fndecl_math_ishftc8;
 115 tree gfor_fndecl_math_ishftc16;
 116
 117
 118 /* String functions.  */
 119
 120 tree gfor_fndecl_compare_string;
 121 tree gfor_fndecl_concat_string;
 122 tree gfor_fndecl_string_len_trim;
 123 tree gfor_fndecl_string_index;
 124 tree gfor_fndecl_string_scan;
 125 tree gfor_fndecl_string_verify;
 126 tree gfor_fndecl_string_trim;
 127 tree gfor_fndecl_string_minmax;
 128 tree gfor_fndecl_adjustl;
 129 tree gfor_fndecl_adjustr;
 130 tree gfor_fndecl_select_string;
 131 tree gfor_fndecl_compare_string_char4;
 132 tree gfor_fndecl_concat_string_char4;
 133 tree gfor_fndecl_string_len_trim_char4;
 134 tree gfor_fndecl_string_index_char4;
 135 tree gfor_fndecl_string_scan_char4;
 136 tree gfor_fndecl_string_verify_char4;
 137 tree gfor_fndecl_string_trim_char4;
 138 tree gfor_fndecl_string_minmax_char4;
 139 tree gfor_fndecl_adjustl_char4;
 140 tree gfor_fndecl_adjustr_char4;
 141 tree gfor_fndecl_select_string_char4;
 142
 143
 144 /* Conversion between character kinds.  */
 145 tree gfor_fndecl_convert_char1_to_char4;
 146 tree gfor_fndecl_convert_char4_to_char1;
 147
 148
 149 /* Other misc. runtime library functions.  */
 150
 151 tree gfor_fndecl_size0;
 152 tree gfor_fndecl_size1;
 153 tree gfor_fndecl_iargc;
 154 tree gfor_fndecl_clz128;
 155 tree gfor_fndecl_ctz128;
 156
 157 /* Intrinsic functions implemented in Fortran.  */
 158 tree gfor_fndecl_sc_kind;
 159 tree gfor_fndecl_si_kind;
 160 tree gfor_fndecl_sr_kind;
 161
 162 /* BLAS gemm functions.  */
 163 tree gfor_fndecl_sgemm;
 164 tree gfor_fndecl_dgemm;
 165 tree gfor_fndecl_cgemm;
 166 tree gfor_fndecl_zgemm;
 167
 168
 169 static void
 170 gfc_add_decl_to_parent_function (tree decl)
 171 {
 172   gcc_assert (decl);
 173   DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl);
 174   DECL_NONLOCAL (decl) = 1;
 175   TREE_CHAIN (decl) = saved_parent_function_decls;
 176   saved_parent_function_decls = decl;
 177 }
 178
 179 void
 180 gfc_add_decl_to_function (tree decl)
 181 {
 182   gcc_assert (decl);
 183   TREE_USED (decl) = 1;
 184   DECL_CONTEXT (decl) = current_function_decl;
 185   TREE_CHAIN (decl) = saved_function_decls;
 186   saved_function_decls = decl;
 187 }
 188
 189 static void
 190 add_decl_as_local (tree decl)
 191 {
 192   gcc_assert (decl);
 193   TREE_USED (decl) = 1;
 194   DECL_CONTEXT (decl) = current_function_decl;
 195   TREE_CHAIN (decl) = saved_local_decls;
 196   saved_local_decls = decl;
 197 }
 198
 199
 200 /* Build a  backend label declaration.  Set TREE_USED for named labels.
 201    The context of the label is always the current_function_decl.  All
 202    labels are marked artificial.  */
 203
 204 tree
 205 gfc_build_label_decl (tree label_id)
 206 {
 207   /* 2^32 temporaries should be enough.  */
 208   static unsigned int tmp_num = 1;
 209   tree label_decl;
 210   char *label_name;
 211
 212   if (label_id == NULL_TREE)
 213     {
 214       /* Build an internal label name.  */
 215       ASM_FORMAT_PRIVATE_NAME (label_name, "L", tmp_num++);
 216       label_id = get_identifier (label_name);
 217     }
 218   else
 219     label_name = NULL;
 220
 221   /* Build the LABEL_DECL node. Labels have no type.  */
 222   label_decl = build_decl (input_location,
 223                            LABEL_DECL, label_id, void_type_node);
 224   DECL_CONTEXT (label_decl) = current_function_decl;
 225   DECL_MODE (label_decl) = VOIDmode;
 226
 227   /* We always define the label as used, even if the original source
 228      file never references the label.  We don't want all kinds of
 229      spurious warnings for old-style Fortran code with too many
 230      labels.  */
 231   TREE_USED (label_decl) = 1;
 232
 233   DECL_ARTIFICIAL (label_decl) = 1;
 234   return label_decl;
 235 }
 236
 237
 238 /* Returns the return label for the current function.  */
 239
 240 tree
 241 gfc_get_return_label (void)
 242 {
 243   char name[GFC_MAX_SYMBOL_LEN + 10];
 244
 245   if (current_function_return_label)
 246     return current_function_return_label;
 247
 248   sprintf (name, "__return_%s",
 249            IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
 250
 251   current_function_return_label =
 252     gfc_build_label_decl (get_identifier (name));
 253
 254   DECL_ARTIFICIAL (current_function_return_label) = 1;
 255
 256   return current_function_return_label;
 257 }
 258
 259
 260 /* Set the backend source location of a decl.  */
 261
 262 void
 263 gfc_set_decl_location (tree decl, locus * loc)
 264 {
 265   DECL_SOURCE_LOCATION (decl) = loc->lb->location;
 266 }
 267
 268
 269 /* Return the backend label declaration for a given label structure,
 270    or create it if it doesn't exist yet.  */
 271
 272 tree
 273 gfc_get_label_decl (gfc_st_label * lp)
 274 {
 275   if (lp->backend_decl)
 276     return lp->backend_decl;
 277   else
 278     {
 279       char label_name[GFC_MAX_SYMBOL_LEN + 1];
 280       tree label_decl;
 281
 282       /* Validate the label declaration from the front end.  */
 283       gcc_assert (lp != NULL && lp->value <= MAX_LABEL_VALUE);
 284
 285       /* Build a mangled name for the label.  */
 286       sprintf (label_name, "__label_%.6d", lp->value);
 287
 288       /* Build the LABEL_DECL node.  */
 289       label_decl = gfc_build_label_decl (get_identifier (label_name));
 290
 291       /* Tell the debugger where the label came from.  */
 292       if (lp->value <= MAX_LABEL_VALUE) /* An internal label.  */
 293         gfc_set_decl_location (label_decl, &lp->where);
 294       else
 295         DECL_ARTIFICIAL (label_decl) = 1;
 296
 297       /* Store the label in the label list and return the LABEL_DECL.  */
 298       lp->backend_decl = label_decl;
 299       return label_decl;
 300     }
 301 }
 302
 303
 304 /* Convert a gfc_symbol to an identifier of the same name.  */
 305
 306 static tree
 307 gfc_sym_identifier (gfc_symbol * sym)
 308 {
 309   if (sym->attr.is_main_program && strcmp (sym->name, "main") == 0)
 310     return (get_identifier ("MAIN__"));
 311   else
 312     return (get_identifier (sym->name));
 313 }
 314
 315
 316 /* Construct mangled name from symbol name.  */
 317
 318 static tree
 319 gfc_sym_mangled_identifier (gfc_symbol * sym)
 320 {
 321   char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
 322
 323   /* Prevent the mangling of identifiers that have an assigned
 324      binding label (mainly those that are bind(c)).  */
 325   if (sym->attr.is_bind_c == 1
 326       && sym->binding_label[0] != '\0')
 327     return get_identifier(sym->binding_label);
 328
 329   if (sym->module == NULL)
 330     return gfc_sym_identifier (sym);
 331   else
 332     {
 333       snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
 334       return get_identifier (name);
 335     }
 336 }
 337
 338
 339 /* Construct mangled function name from symbol name.  */
 340
 341 static tree
 342 gfc_sym_mangled_function_id (gfc_symbol * sym)
 343 {
 344   int has_underscore;
 345   char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
 346
 347   /* It may be possible to simply use the binding label if it's
 348      provided, and remove the other checks.  Then we could use it
 349      for other things if we wished.  */
 350   if ((sym->attr.is_bind_c == 1 || sym->attr.is_iso_c == 1) &&
 351       sym->binding_label[0] != '\0')
 352     /* use the binding label rather than the mangled name */
 353     return get_identifier (sym->binding_label);
 354
 355   if (sym->module == NULL || sym->attr.proc == PROC_EXTERNAL
 356       || (sym->module != NULL && (sym->attr.external
 357             || sym->attr.if_source == IFSRC_IFBODY)))
 358     {
 359       /* Main program is mangled into MAIN__.  */
 360       if (sym->attr.is_main_program)
 361         return get_identifier ("MAIN__");
 362
 363       /* Intrinsic procedures are never mangled.  */
 364       if (sym->attr.proc == PROC_INTRINSIC)
 365         return get_identifier (sym->name);
 366
 367       if (gfc_option.flag_underscoring)
 368         {
 369           has_underscore = strchr (sym->name, '_') != 0;
 370           if (gfc_option.flag_second_underscore && has_underscore)
 371             snprintf (name, sizeof name, "%s__", sym->name);
 372           else
 373             snprintf (name, sizeof name, "%s_", sym->name);
 374           return get_identifier (name);
 375         }
 376       else
 377         return get_identifier (sym->name);
 378     }
 379   else
 380     {
 381       snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
 382       return get_identifier (name);
 383     }
 384 }
 385
 386
 387 void
 388 gfc_set_decl_assembler_name (tree decl, tree name)
 389 {
 390   tree target_mangled = targetm.mangle_decl_assembler_name (decl, name);
 391   SET_DECL_ASSEMBLER_NAME (decl, target_mangled);
 392 }
 393
 394
 395 /* Returns true if a variable of specified size should go on the stack.  */
 396
 397 int
 398 gfc_can_put_var_on_stack (tree size)
 399 {
 400   unsigned HOST_WIDE_INT low;
 401
 402   if (!INTEGER_CST_P (size))
 403     return 0;
 404
 405   if (gfc_option.flag_max_stack_var_size < 0)
 406     return 1;
 407
 408   if (TREE_INT_CST_HIGH (size) != 0)
 409     return 0;
 410
 411   low = TREE_INT_CST_LOW (size);
 412   if (low > (unsigned HOST_WIDE_INT) gfc_option.flag_max_stack_var_size)
 413     return 0;
 414
 415 /* TODO: Set a per-function stack size limit.  */
 416
 417   return 1;
 418 }
 419
 420
 421 /* gfc_finish_cray_pointee sets DECL_VALUE_EXPR for a Cray pointee to
 422    an expression involving its corresponding pointer.  There are
 423    2 cases; one for variable size arrays, and one for everything else,
 424    because variable-sized arrays require one fewer level of
 425    indirection.  */
 426
 427 static void
 428 gfc_finish_cray_pointee (tree decl, gfc_symbol *sym)
 429 {
 430   tree ptr_decl = gfc_get_symbol_decl (sym->cp_pointer);
 431   tree value;
 432
 433   /* Parameters need to be dereferenced.  */
 434   if (sym->cp_pointer->attr.dummy)
 435     ptr_decl = build_fold_indirect_ref_loc (input_location,
 436                                         ptr_decl);
 437
 438   /* Check to see if we're dealing with a variable-sized array.  */
 439   if (sym->attr.dimension
 440       && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE)
 441     {
 442       /* These decls will be dereferenced later, so we don't dereference
 443          them here.  */
 444       value = convert (TREE_TYPE (decl), ptr_decl);
 445     }
 446   else
 447     {
 448       ptr_decl = convert (build_pointer_type (TREE_TYPE (decl)),
 449                           ptr_decl);
 450       value = build_fold_indirect_ref_loc (input_location,
 451                                        ptr_decl);
 452     }
 453
 454   SET_DECL_VALUE_EXPR (decl, value);
 455   DECL_HAS_VALUE_EXPR_P (decl) = 1;
 456   GFC_DECL_CRAY_POINTEE (decl) = 1;
 457   /* This is a fake variable just for debugging purposes.  */
 458   TREE_ASM_WRITTEN (decl) = 1;
 459 }
 460
 461
 462 /* Finish processing of a declaration without an initial value.  */
 463
 464 static void
 465 gfc_finish_decl (tree decl)
 466 {
 467   gcc_assert (TREE_CODE (decl) == PARM_DECL
 468               || DECL_INITIAL (decl) == NULL_TREE);
 469
 470   if (TREE_CODE (decl) != VAR_DECL)
 471     return;
 472
 473   if (DECL_SIZE (decl) == NULL_TREE
 474       && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
 475     layout_decl (decl, 0);
 476
 477   /* A few consistency checks.  */
 478   /* A static variable with an incomplete type is an error if it is
 479      initialized. Also if it is not file scope. Otherwise, let it
 480      through, but if it is not `extern' then it may cause an error
 481      message later.  */
 482   /* An automatic variable with an incomplete type is an error.  */
 483
 484   /* We should know the storage size.  */
 485   gcc_assert (DECL_SIZE (decl) != NULL_TREE
 486               || (TREE_STATIC (decl)
 487                   ? (!DECL_INITIAL (decl) || !DECL_CONTEXT (decl))
 488                   : DECL_EXTERNAL (decl)));
 489
 490   /* The storage size should be constant.  */
 491   gcc_assert ((!DECL_EXTERNAL (decl) && !TREE_STATIC (decl))
 492               || !DECL_SIZE (decl)
 493               || TREE_CODE (DECL_SIZE (decl)) == INTEGER_CST);
 494 }
 495
 496
 497 /* Apply symbol attributes to a variable, and add it to the function scope.  */
 498
 499 static void
 500 gfc_finish_var_decl (tree decl, gfc_symbol * sym)
 501 {
 502   tree new_type;
 503   /* TREE_ADDRESSABLE means the address of this variable is actually needed.
 504      This is the equivalent of the TARGET variables.
 505      We also need to set this if the variable is passed by reference in a
 506      CALL statement.  */
 507
 508   /* Set DECL_VALUE_EXPR for Cray Pointees.  */
 509   if (sym->attr.cray_pointee)
 510     gfc_finish_cray_pointee (decl, sym);
 511
 512   if (sym->attr.target)
 513     TREE_ADDRESSABLE (decl) = 1;
 514   /* If it wasn't used we wouldn't be getting it.  */
 515   TREE_USED (decl) = 1;
 516
 517   /* Chain this decl to the pending declarations.  Don't do pushdecl()
 518      because this would add them to the current scope rather than the
 519      function scope.  */
 520   if (current_function_decl != NULL_TREE)
 521     {
 522       if (sym->ns->proc_name->backend_decl == current_function_decl
 523           || sym->result == sym)
 524         gfc_add_decl_to_function (decl);
 525       else if (sym->ns->proc_name->attr.flavor == FL_LABEL)
 526         /* This is a BLOCK construct.  */
 527         add_decl_as_local (decl);
 528       else
 529         gfc_add_decl_to_parent_function (decl);
 530     }
 531
 532   if (sym->attr.cray_pointee)
 533     return;
 534
 535   if(sym->attr.is_bind_c == 1)
 536     {
 537       /* We need to put variables that are bind(c) into the common
 538          segment of the object file, because this is what C would do.
 539          gfortran would typically put them in either the BSS or
 540          initialized data segments, and only mark them as common if
 541          they were part of common blocks.  However, if they are not put
 542          into common space, then C cannot initialize global Fortran
 543          variables that it interoperates with and the draft says that
 544          either Fortran or C should be able to initialize it (but not
 545          both, of course.) (J3/04-007, section 15.3).  */
 546       TREE_PUBLIC(decl) = 1;
 547       DECL_COMMON(decl) = 1;
 548     }
 549
 550   /* If a variable is USE associated, it's always external.  */
 551   if (sym->attr.use_assoc)
 552     {
 553       DECL_EXTERNAL (decl) = 1;
 554       TREE_PUBLIC (decl) = 1;
 555     }
 556   else if (sym->module && !sym->attr.result && !sym->attr.dummy)
 557     {
 558       /* TODO: Don't set sym->module for result or dummy variables.  */
 559       gcc_assert (current_function_decl == NULL_TREE || sym->result == sym);
 560       /* This is the declaration of a module variable.  */
 561       TREE_PUBLIC (decl) = 1;
 562       TREE_STATIC (decl) = 1;
 563     }
 564
 565   /* Derived types are a bit peculiar because of the possibility of
 566      a default initializer; this must be applied each time the variable
 567      comes into scope it therefore need not be static.  These variables
 568      are SAVE_NONE but have an initializer.  Otherwise explicitly
 569      initialized variables are SAVE_IMPLICIT and explicitly saved are
 570      SAVE_EXPLICIT.  */
 571   if (!sym->attr.use_assoc
 572         && (sym->attr.save != SAVE_NONE || sym->attr.data
 573               || (sym->value && sym->ns->proc_name->attr.is_main_program)))
 574     TREE_STATIC (decl) = 1;
 575
 576   if (sym->attr.volatile_)
 577     {
 578       TREE_THIS_VOLATILE (decl) = 1;
 579       new_type = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE);
 580       TREE_TYPE (decl) = new_type;
 581     }
 582
 583   /* Keep variables larger than max-stack-var-size off stack.  */
 584   if (!sym->ns->proc_name->attr.recursive
 585       && INTEGER_CST_P (DECL_SIZE_UNIT (decl))
 586       && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
 587          /* Put variable length auto array pointers always into stack.  */
 588       && (TREE_CODE (TREE_TYPE (decl)) != POINTER_TYPE
 589           || sym->attr.dimension == 0
 590           || sym->as->type != AS_EXPLICIT
 591           || sym->attr.pointer
 592           || sym->attr.allocatable)
 593       && !DECL_ARTIFICIAL (decl))
 594     TREE_STATIC (decl) = 1;
 595
 596   /* Handle threadprivate variables.  */
 597   if (sym->attr.threadprivate
 598       && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
 599     DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
 600
 601   if (!sym->attr.target
 602       && !sym->attr.pointer
 603       && !sym->attr.cray_pointee
 604       && !sym->attr.proc_pointer)
 605     DECL_RESTRICTED_P (decl) = 1;
 606 }
 607
 608
 609 /* Allocate the lang-specific part of a decl.  */
 610
 611 void
 612 gfc_allocate_lang_decl (tree decl)
 613 {
 614   DECL_LANG_SPECIFIC (decl) = (struct lang_decl *)
 615     ggc_alloc_cleared (sizeof (struct lang_decl));
 616 }
 617
 618 /* Remember a symbol to generate initialization/cleanup code at function
 619    entry/exit.  */
 620
 621 static void
 622 gfc_defer_symbol_init (gfc_symbol * sym)
 623 {
 624   gfc_symbol *p;
 625   gfc_symbol *last;
 626   gfc_symbol *head;
 627
 628   /* Don't add a symbol twice.  */
 629   if (sym->tlink)
 630     return;
 631
 632   last = head = sym->ns->proc_name;
 633   p = last->tlink;
 634
 635   /* Make sure that setup code for dummy variables which are used in the
 636      setup of other variables is generated first.  */
 637   if (sym->attr.dummy)
 638     {
 639       /* Find the first dummy arg seen after us, or the first non-dummy arg.
 640          This is a circular list, so don't go past the head.  */
 641       while (p != head
 642              && (!p->attr.dummy || p->dummy_order > sym->dummy_order))
 643         {
 644           last = p;
 645           p = p->tlink;
 646         }
 647     }
 648   /* Insert in between last and p.  */
 649   last->tlink = sym;
 650   sym->tlink = p;
 651 }
 652
 653
 654 /* Create an array index type variable with function scope.  */
 655
 656 static tree
 657 create_index_var (const char * pfx, int nest)
 658 {
 659   tree decl;
 660
 661   decl = gfc_create_var_np (gfc_array_index_type, pfx);
 662   if (nest)
 663     gfc_add_decl_to_parent_function (decl);
 664   else
 665     gfc_add_decl_to_function (decl);
 666   return decl;
 667 }
 668
 669
 670 /* Create variables to hold all the non-constant bits of info for a
 671    descriptorless array.  Remember these in the lang-specific part of the
 672    type.  */
 673
 674 static void
 675 gfc_build_qualified_array (tree decl, gfc_symbol * sym)
 676 {
 677   tree type;
 678   int dim;
 679   int nest;
 680
 681   type = TREE_TYPE (decl);
 682
 683   /* We just use the descriptor, if there is one.  */
 684   if (GFC_DESCRIPTOR_TYPE_P (type))
 685     return;
 686
 687   gcc_assert (GFC_ARRAY_TYPE_P (type));
 688   nest = (sym->ns->proc_name->backend_decl != current_function_decl)
 689          && !sym->attr.contained;
 690
 691   for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)
 692     {
 693       if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
 694         {
 695           GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
 696           TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 1;
 697         }
 698       /* Don't try to use the unknown bound for assumed shape arrays.  */
 699       if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
 700           && (sym->as->type != AS_ASSUMED_SIZE
 701               || dim < GFC_TYPE_ARRAY_RANK (type) - 1))
 702         {
 703           GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
 704           TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 1;
 705         }
 706
 707       if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE)
 708         {
 709           GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest);
 710           TREE_NO_WARNING (GFC_TYPE_ARRAY_STRIDE (type, dim)) = 1;
 711         }
 712     }
 713   if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)
 714     {
 715       GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,
 716                                                         "offset");
 717       TREE_NO_WARNING (GFC_TYPE_ARRAY_OFFSET (type)) = 1;
 718
 719       if (nest)
 720         gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type));
 721       else
 722         gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));
 723     }
 724
 725   if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE
 726       && sym->as->type != AS_ASSUMED_SIZE)
 727     {
 728       GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest);
 729       TREE_NO_WARNING (GFC_TYPE_ARRAY_SIZE (type)) = 1;
 730     }
 731
 732   if (POINTER_TYPE_P (type))
 733     {
 734       gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (type)));
 735       gcc_assert (TYPE_LANG_SPECIFIC (type)
 736                   == TYPE_LANG_SPECIFIC (TREE_TYPE (type)));
 737       type = TREE_TYPE (type);
 738     }
 739
 740   if (! COMPLETE_TYPE_P (type) && GFC_TYPE_ARRAY_SIZE (type))
 741     {
 742       tree size, range;
 743
 744       size = fold_build2 (MINUS_EXPR, gfc_array_index_type,
 745                           GFC_TYPE_ARRAY_SIZE (type), gfc_index_one_node);
 746       range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
 747                                 size);
 748       TYPE_DOMAIN (type) = range;
 749       layout_type (type);
 750     }
 751
 752   if (TYPE_NAME (type) != NULL_TREE
 753       && GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1) != NULL_TREE
 754       && TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1)) == VAR_DECL)
 755     {
 756       tree gtype = DECL_ORIGINAL_TYPE (TYPE_NAME (type));
 757
 758       for (dim = 0; dim < sym->as->rank - 1; dim++)
 759         {
 760           gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
 761           gtype = TREE_TYPE (gtype);
 762         }
 763       gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
 764       if (TYPE_MAX_VALUE (TYPE_DOMAIN (gtype)) == NULL)
 765         TYPE_NAME (type) = NULL_TREE;
 766     }
 767
 768   if (TYPE_NAME (type) == NULL_TREE)
 769     {
 770       tree gtype = TREE_TYPE (type), rtype, type_decl;
 771
 772       for (dim = sym->as->rank - 1; dim >= 0; dim--)
 773         {
 774           tree lbound, ubound;
 775           lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
 776           ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
 777           rtype = build_range_type (gfc_array_index_type, lbound, ubound);
 778           gtype = build_array_type (gtype, rtype);
 779           /* Ensure the bound variables aren't optimized out at -O0.
 780              For -O1 and above they often will be optimized out, but
 781              can be tracked by VTA.  Also clear the artificial
 782              lbound.N or ubound.N DECL_NAME, so that it doesn't end up
 783              in debug info.  */
 784           if (lbound && TREE_CODE (lbound) == VAR_DECL
 785               && DECL_ARTIFICIAL (lbound) && DECL_IGNORED_P (lbound))
 786             {
 787               if (DECL_NAME (lbound)
 788                   && strstr (IDENTIFIER_POINTER (DECL_NAME (lbound)),
 789                              "lbound") != 0)
 790                 DECL_NAME (lbound) = NULL_TREE;
 791               DECL_IGNORED_P (lbound) = 0;
 792             }
 793           if (ubound && TREE_CODE (ubound) == VAR_DECL
 794               && DECL_ARTIFICIAL (ubound) && DECL_IGNORED_P (ubound))
 795             {
 796               if (DECL_NAME (ubound)
 797                   && strstr (IDENTIFIER_POINTER (DECL_NAME (ubound)),
 798                              "ubound") != 0)
 799                 DECL_NAME (ubound) = NULL_TREE;
 800               DECL_IGNORED_P (ubound) = 0;
 801             }
 802         }
 803       TYPE_NAME (type) = type_decl = build_decl (input_location,
 804                                                  TYPE_DECL, NULL, gtype);
 805       DECL_ORIGINAL_TYPE (type_decl) = gtype;
 806     }
 807 }
 808
 809
 810 /* For some dummy arguments we don't use the actual argument directly.
 811    Instead we create a local decl and use that.  This allows us to perform
 812    initialization, and construct full type information.  */
 813
 814 static tree
 815 gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
 816 {
 817   tree decl;
 818   tree type;
 819   gfc_array_spec *as;
 820   char *name;
 821   gfc_packed packed;
 822   int n;
 823   bool known_size;
 824
 825   if (sym->attr.pointer || sym->attr.allocatable)
 826     return dummy;
 827
 828   /* Add to list of variables if not a fake result variable.  */
 829   if (sym->attr.result || sym->attr.dummy)
 830     gfc_defer_symbol_init (sym);
 831
 832   type = TREE_TYPE (dummy);
 833   gcc_assert (TREE_CODE (dummy) == PARM_DECL
 834           && POINTER_TYPE_P (type));
 835
 836   /* Do we know the element size?  */
 837   known_size = sym->ts.type != BT_CHARACTER
 838           || INTEGER_CST_P (sym->ts.u.cl->backend_decl);
 839
 840   if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
 841     {
 842       /* For descriptorless arrays with known element size the actual
 843          argument is sufficient.  */
 844       gcc_assert (GFC_ARRAY_TYPE_P (type));
 845       gfc_build_qualified_array (dummy, sym);
 846       return dummy;
 847     }
 848
 849   type = TREE_TYPE (type);
 850   if (GFC_DESCRIPTOR_TYPE_P (type))
 851     {
 852       /* Create a descriptorless array pointer.  */
 853       as = sym->as;
 854       packed = PACKED_NO;
 855
 856       /* Even when -frepack-arrays is used, symbols with TARGET attribute
 857          are not repacked.  */
 858       if (!gfc_option.flag_repack_arrays || sym->attr.target)
 859         {
 860           if (as->type == AS_ASSUMED_SIZE)
 861             packed = PACKED_FULL;
 862         }
 863       else
 864         {
 865           if (as->type == AS_EXPLICIT)
 866             {
 867               packed = PACKED_FULL;
 868               for (n = 0; n < as->rank; n++)
 869                 {
 870                   if (!(as->upper[n]
 871                         && as->lower[n]
 872                         && as->upper[n]->expr_type == EXPR_CONSTANT
 873                         && as->lower[n]->expr_type == EXPR_CONSTANT))
 874                     packed = PACKED_PARTIAL;
 875                 }
 876             }
 877           else
 878             packed = PACKED_PARTIAL;
 879         }
 880
 881       type = gfc_typenode_for_spec (&sym->ts);
 882       type = gfc_get_nodesc_array_type (type, sym->as, packed,
 883                                         !sym->attr.target);
 884     }
 885   else
 886     {
 887       /* We now have an expression for the element size, so create a fully
 888          qualified type.  Reset sym->backend decl or this will just return the
 889          old type.  */
 890       DECL_ARTIFICIAL (sym->backend_decl) = 1;
 891       sym->backend_decl = NULL_TREE;
 892       type = gfc_sym_type (sym);
 893       packed = PACKED_FULL;
 894     }
 895
 896   ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);
 897   decl = build_decl (input_location,
 898                      VAR_DECL, get_identifier (name), type);
 899
 900   DECL_ARTIFICIAL (decl) = 1;
 901   TREE_PUBLIC (decl) = 0;
 902   TREE_STATIC (decl) = 0;
 903   DECL_EXTERNAL (decl) = 0;
 904
 905   /* We should never get deferred shape arrays here.  We used to because of
 906      frontend bugs.  */
 907   gcc_assert (sym->as->type != AS_DEFERRED);
 908
 909   if (packed == PACKED_PARTIAL)
 910     GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;
 911   else if (packed == PACKED_FULL)
 912     GFC_DECL_PACKED_ARRAY (decl) = 1;
 913
 914   gfc_build_qualified_array (decl, sym);
 915
 916   if (DECL_LANG_SPECIFIC (dummy))
 917     DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (dummy);
 918   else
 919     gfc_allocate_lang_decl (decl);
 920
 921   GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy;
 922
 923   if (sym->ns->proc_name->backend_decl == current_function_decl
 924       || sym->attr.contained)
 925     gfc_add_decl_to_function (decl);
 926   else
 927     gfc_add_decl_to_parent_function (decl);
 928
 929   return decl;
 930 }
 931
 932 /* For symbol SYM with GFC_DECL_SAVED_DESCRIPTOR used in contained
 933    function add a VAR_DECL to the current function with DECL_VALUE_EXPR
 934    pointing to the artificial variable for debug info purposes.  */
 935
 936 static void
 937 gfc_nonlocal_dummy_array_decl (gfc_symbol *sym)
 938 {
 939   tree decl, dummy;
 940
 941   if (! nonlocal_dummy_decl_pset)
 942     nonlocal_dummy_decl_pset = pointer_set_create ();
 943
 944   if (pointer_set_insert (nonlocal_dummy_decl_pset, sym->backend_decl))
 945     return;
 946
 947   dummy = GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl);
 948   decl = build_decl (input_location, VAR_DECL, DECL_NAME (dummy),
 949                      TREE_TYPE (sym->backend_decl));
 950   DECL_ARTIFICIAL (decl) = 0;
 951   TREE_USED (decl) = 1;
 952   TREE_PUBLIC (decl) = 0;
 953   TREE_STATIC (decl) = 0;
 954   DECL_EXTERNAL (decl) = 0;
 955   if (DECL_BY_REFERENCE (dummy))
 956     DECL_BY_REFERENCE (decl) = 1;
 957   DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (sym->backend_decl);
 958   SET_DECL_VALUE_EXPR (decl, sym->backend_decl);
 959   DECL_HAS_VALUE_EXPR_P (decl) = 1;
 960   DECL_CONTEXT (decl) = DECL_CONTEXT (sym->backend_decl);
 961   TREE_CHAIN (decl) = nonlocal_dummy_decls;
 962   nonlocal_dummy_decls = decl;
 963 }
 964
 965 /* Return a constant or a variable to use as a string length.  Does not
 966    add the decl to the current scope.  */
 967
 968 static tree
 969 gfc_create_string_length (gfc_symbol * sym)
 970 {
 971   gcc_assert (sym->ts.u.cl);
 972   gfc_conv_const_charlen (sym->ts.u.cl);
 973
 974   if (sym->ts.u.cl->backend_decl == NULL_TREE)
 975     {
 976       tree length;
 977       char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
 978
 979       /* Also prefix the mangled name.  */
 980       strcpy (&name[1], sym->name);
 981       name[0] = '.';
 982       length = build_decl (input_location,
 983                            VAR_DECL, get_identifier (name),
 984                            gfc_charlen_type_node);
 985       DECL_ARTIFICIAL (length) = 1;
 986       TREE_USED (length) = 1;
 987       if (sym->ns->proc_name->tlink != NULL)
 988         gfc_defer_symbol_init (sym);
 989
 990       sym->ts.u.cl->backend_decl = length;
 991     }
 992
 993   gcc_assert (sym->ts.u.cl->backend_decl != NULL_TREE);
 994   return sym->ts.u.cl->backend_decl;
 995 }
 996
 997 /* If a variable is assigned a label, we add another two auxiliary
 998    variables.  */
 999
1000 static void
1001 gfc_add_assign_aux_vars (gfc_symbol * sym)
1002 {
1003   tree addr;
1004   tree length;
1005   tree decl;
1006
1007   gcc_assert (sym->backend_decl);
1008
1009   decl = sym->backend_decl;
1010   gfc_allocate_lang_decl (decl);
1011   GFC_DECL_ASSIGN (decl) = 1;
1012   length = build_decl (input_location,
1013                        VAR_DECL, create_tmp_var_name (sym->name),
1014                        gfc_charlen_type_node);
1015   addr = build_decl (input_location,
1016                      VAR_DECL, create_tmp_var_name (sym->name),
1017                      pvoid_type_node);
1018   gfc_finish_var_decl (length, sym);
1019   gfc_finish_var_decl (addr, sym);
1020   /*  STRING_LENGTH is also used as flag. Less than -1 means that
1021       ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
1022       target label's address. Otherwise, value is the length of a format string
1023       and ASSIGN_ADDR is its address.  */
1024   if (TREE_STATIC (length))
1025     DECL_INITIAL (length) = build_int_cst (NULL_TREE, -2);
1026   else
1027     gfc_defer_symbol_init (sym);
1028
1029   GFC_DECL_STRING_LEN (decl) = length;
1030   GFC_DECL_ASSIGN_ADDR (decl) = addr;
1031 }
1032
1033
1034 static tree
1035 add_attributes_to_decl (symbol_attribute sym_attr, tree list)
1036 {
1037   unsigned id;
1038   tree attr;
1039
1040   for (id = 0; id < EXT_ATTR_NUM; id++)
1041     if (sym_attr.ext_attr & (1 << id))
1042       {
1043         attr = build_tree_list (
1044                  get_identifier (ext_attr_list[id].middle_end_name),
1045                                  NULL_TREE);
1046         list = chainon (list, attr);
1047       }
1048
1049   return list;
1050 }
1051
1052
1053 /* Return the decl for a gfc_symbol, create it if it doesn't already
1054    exist.  */
1055
1056 tree
1057 gfc_get_symbol_decl (gfc_symbol * sym)
1058 {
1059   tree decl;
1060   tree length = NULL_TREE;
1061   tree attributes;
1062   int byref;
1063
1064   gcc_assert (sym->attr.referenced
1065                 || sym->attr.use_assoc
1066                 || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY);
1067
1068   if (sym->ns && sym->ns->proc_name && sym->ns->proc_name->attr.function)
1069     byref = gfc_return_by_reference (sym->ns->proc_name);
1070   else
1071     byref = 0;
1072
1073   /* Make sure that the vtab for the declared type is completed.  */
1074   if (sym->ts.type == BT_CLASS)
1075     {
1076       gfc_component *c = gfc_find_component (sym->ts.u.derived,
1077                                              "$data", true, true);
1078       if (!c->ts.u.derived->backend_decl)
1079         gfc_find_derived_vtab (c->ts.u.derived, true);
1080     }
1081
1082   if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
1083     {
1084       /* Return via extra parameter.  */
1085       if (sym->attr.result && byref
1086           && !sym->backend_decl)
1087         {
1088           sym->backend_decl =
1089             DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);
1090           /* For entry master function skip over the __entry
1091              argument.  */
1092           if (sym->ns->proc_name->attr.entry_master)
1093             sym->backend_decl = TREE_CHAIN (sym->backend_decl);
1094         }
1095
1096       /* Dummy variables should already have been created.  */
1097       gcc_assert (sym->backend_decl);
1098
1099       /* Create a character length variable.  */
1100       if (sym->ts.type == BT_CHARACTER)
1101         {
1102           if (sym->ts.u.cl->backend_decl == NULL_TREE)
1103             length = gfc_create_string_length (sym);
1104           else
1105             length = sym->ts.u.cl->backend_decl;
1106           if (TREE_CODE (length) == VAR_DECL
1107               && DECL_CONTEXT (length) == NULL_TREE)
1108             {
1109               /* Add the string length to the same context as the symbol.  */
1110               if (DECL_CONTEXT (sym->backend_decl) == current_function_decl)
1111                 gfc_add_decl_to_function (length);
1112               else
1113                 gfc_add_decl_to_parent_function (length);
1114
1115               gcc_assert (DECL_CONTEXT (sym->backend_decl) ==
1116                             DECL_CONTEXT (length));
1117
1118               gfc_defer_symbol_init (sym);
1119             }
1120         }
1121
1122       /* Use a copy of the descriptor for dummy arrays.  */
1123       if (sym->attr.dimension && !TREE_USED (sym->backend_decl))
1124         {
1125           decl = gfc_build_dummy_array_decl (sym, sym->backend_decl);
1126           /* Prevent the dummy from being detected as unused if it is copied.  */
1127           if (sym->backend_decl != NULL && decl != sym->backend_decl)
1128             DECL_ARTIFICIAL (sym->backend_decl) = 1;
1129           sym->backend_decl = decl;
1130         }
1131
1132       TREE_USED (sym->backend_decl) = 1;
1133       if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0)
1134         {
1135           gfc_add_assign_aux_vars (sym);
1136         }
1137
1138       if (sym->attr.dimension
1139           && DECL_LANG_SPECIFIC (sym->backend_decl)
1140           && GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl)
1141           && DECL_CONTEXT (sym->backend_decl) != current_function_decl)
1142         gfc_nonlocal_dummy_array_decl (sym);
1143
1144       return sym->backend_decl;
1145     }
1146
1147   if (sym->backend_decl)
1148     return sym->backend_decl;
1149
1150   /* If use associated and whole file compilation, use the module
1151      declaration.  This is only needed for intrinsic types because
1152      they are substituted for one another during optimization.  */
1153   if (gfc_option.flag_whole_file
1154         && sym->attr.flavor == FL_VARIABLE
1155         && sym->ts.type != BT_DERIVED
1156         && sym->attr.use_assoc
1157         && sym->module)
1158     {
1159       gfc_gsymbol *gsym;
1160
1161       gsym =  gfc_find_gsymbol (gfc_gsym_root, sym->module);
1162       if (gsym && gsym->ns && gsym->type == GSYM_MODULE)
1163         {
1164           gfc_symbol *s;
1165           s = NULL;
1166           gfc_find_symbol (sym->name, gsym->ns, 0, &s);
1167           if (s && s->backend_decl)
1168             {
1169               if (sym->ts.type == BT_CHARACTER)
1170                 sym->ts.u.cl->backend_decl = s->ts.u.cl->backend_decl;
1171               return s->backend_decl;
1172             }
1173         }
1174     }
1175
1176   /* Catch function declarations.  Only used for actual parameters and
1177      procedure pointers.  */
1178   if (sym->attr.flavor == FL_PROCEDURE)
1179     {
1180       decl = gfc_get_extern_function_decl (sym);
1181       gfc_set_decl_location (decl, &sym->declared_at);
1182       return decl;
1183     }
1184
1185   if (sym->attr.intrinsic)
1186     internal_error ("intrinsic variable which isn't a procedure");
1187
1188   /* Create string length decl first so that they can be used in the
1189      type declaration.  */
1190   if (sym->ts.type == BT_CHARACTER)
1191     length = gfc_create_string_length (sym);
1192
1193   /* Create the decl for the variable.  */
1194   decl = build_decl (sym->declared_at.lb->location,
1195                      VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
1196
1197   /* Add attributes to variables.  Functions are handled elsewhere.  */
1198   attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1199   decl_attributes (&decl, attributes, 0);
1200
1201   /* Symbols from modules should have their assembler names mangled.
1202      This is done here rather than in gfc_finish_var_decl because it
1203      is different for string length variables.  */
1204   if (sym->module)
1205     {
1206       gfc_set_decl_assembler_name (decl, gfc_sym_mangled_identifier (sym));
1207       if (sym->attr.use_assoc)
1208         DECL_IGNORED_P (decl) = 1;
1209     }
1210
1211   if (sym->attr.dimension)
1212     {
1213       /* Create variables to hold the non-constant bits of array info.  */
1214       gfc_build_qualified_array (decl, sym);
1215
1216       if ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer)
1217         GFC_DECL_PACKED_ARRAY (decl) = 1;
1218     }
1219
1220   /* Remember this variable for allocation/cleanup.  */
1221   if (sym->attr.dimension || sym->attr.allocatable
1222       || (sym->ts.type == BT_CLASS &&
1223           (sym->ts.u.derived->components->attr.dimension
1224            || sym->ts.u.derived->components->attr.allocatable))
1225       || (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
1226       /* This applies a derived type default initializer.  */
1227       || (sym->ts.type == BT_DERIVED
1228           && sym->attr.save == SAVE_NONE
1229           && !sym->attr.data
1230           && !sym->attr.allocatable
1231           && (sym->value && !sym->ns->proc_name->attr.is_main_program)
1232           && !sym->attr.use_assoc))
1233     gfc_defer_symbol_init (sym);
1234
1235   gfc_finish_var_decl (decl, sym);
1236
1237   if (sym->ts.type == BT_CHARACTER)
1238     {
1239       /* Character variables need special handling.  */
1240       gfc_allocate_lang_decl (decl);
1241
1242       if (TREE_CODE (length) != INTEGER_CST)
1243         {
1244           char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
1245
1246           if (sym->module)
1247             {
1248               /* Also prefix the mangled name for symbols from modules.  */
1249               strcpy (&name[1], sym->name);
1250               name[0] = '.';
1251               strcpy (&name[1],
1252                       IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length)));
1253               gfc_set_decl_assembler_name (decl, get_identifier (name));
1254             }
1255           gfc_finish_var_decl (length, sym);
1256           gcc_assert (!sym->value);
1257         }
1258     }
1259   else if (sym->attr.subref_array_pointer)
1260     {
1261       /* We need the span for these beasts.  */
1262       gfc_allocate_lang_decl (decl);
1263     }
1264
1265   if (sym->attr.subref_array_pointer)
1266     {
1267       tree span;
1268       GFC_DECL_SUBREF_ARRAY_P (decl) = 1;
1269       span = build_decl (input_location,
1270                          VAR_DECL, create_tmp_var_name ("span"),
1271                          gfc_array_index_type);
1272       gfc_finish_var_decl (span, sym);
1273       TREE_STATIC (span) = TREE_STATIC (decl);
1274       DECL_ARTIFICIAL (span) = 1;
1275       DECL_INITIAL (span) = build_int_cst (gfc_array_index_type, 0);
1276
1277       GFC_DECL_SPAN (decl) = span;
1278       GFC_TYPE_ARRAY_SPAN (TREE_TYPE (decl)) = span;
1279     }
1280
1281   sym->backend_decl = decl;
1282
1283   if (sym->attr.assign)
1284     gfc_add_assign_aux_vars (sym);
1285
1286   if (TREE_STATIC (decl) && !sym->attr.use_assoc
1287       && (sym->attr.save || sym->ns->proc_name->attr.is_main_program
1288           || gfc_option.flag_max_stack_var_size == 0
1289           || sym->attr.data || sym->ns->proc_name->attr.flavor == FL_MODULE))
1290     {
1291       /* Add static initializer. For procedures, it is only needed if
1292          SAVE is specified otherwise they need to be reinitialized
1293          every time the procedure is entered. The TREE_STATIC is
1294          in this case due to -fmax-stack-var-size=.  */
1295       DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1296           TREE_TYPE (decl), sym->attr.dimension,
1297           sym->attr.pointer || sym->attr.allocatable);
1298     }
1299
1300   if (!TREE_STATIC (decl)
1301       && POINTER_TYPE_P (TREE_TYPE (decl))
1302       && !sym->attr.pointer
1303       && !sym->attr.allocatable
1304       && !sym->attr.proc_pointer)
1305     DECL_BY_REFERENCE (decl) = 1;
1306
1307   return decl;
1308 }
1309
1310
1311 /* Substitute a temporary variable in place of the real one.  */
1312
1313 void
1314 gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
1315 {
1316   save->attr = sym->attr;
1317   save->decl = sym->backend_decl;
1318
1319   gfc_clear_attr (&sym->attr);
1320   sym->attr.referenced = 1;
1321   sym->attr.flavor = FL_VARIABLE;
1322
1323   sym->backend_decl = decl;
1324 }
1325
1326
1327 /* Restore the original variable.  */
1328
1329 void
1330 gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
1331 {
1332   sym->attr = save->attr;
1333   sym->backend_decl = save->decl;
1334 }
1335
1336
1337 /* Declare a procedure pointer.  */
1338
1339 static tree
1340 get_proc_pointer_decl (gfc_symbol *sym)
1341 {
1342   tree decl;
1343   tree attributes;
1344
1345   decl = sym->backend_decl;
1346   if (decl)
1347     return decl;
1348
1349   decl = build_decl (input_location,
1350                      VAR_DECL, get_identifier (sym->name),
1351                      build_pointer_type (gfc_get_function_type (sym)));
1352
1353   if ((sym->ns->proc_name
1354       && sym->ns->proc_name->backend_decl == current_function_decl)
1355       || sym->attr.contained)
1356     gfc_add_decl_to_function (decl);
1357   else if (sym->ns->proc_name->attr.flavor != FL_MODULE)
1358     gfc_add_decl_to_parent_function (decl);
1359
1360   sym->backend_decl = decl;
1361
1362   /* If a variable is USE associated, it's always external.  */
1363   if (sym->attr.use_assoc)
1364     {
1365       DECL_EXTERNAL (decl) = 1;
1366       TREE_PUBLIC (decl) = 1;
1367     }
1368   else if (sym->module && sym->ns->proc_name->attr.flavor == FL_MODULE)
1369     {
1370       /* This is the declaration of a module variable.  */
1371       TREE_PUBLIC (decl) = 1;
1372       TREE_STATIC (decl) = 1;
1373     }
1374
1375   if (!sym->attr.use_assoc
1376         && (sym->attr.save != SAVE_NONE || sym->attr.data
1377               || (sym->value && sym->ns->proc_name->attr.is_main_program)))
1378     TREE_STATIC (decl) = 1;
1379
1380   if (TREE_STATIC (decl) && sym->value)
1381     {
1382       /* Add static initializer.  */
1383       DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1384           TREE_TYPE (decl),
1385           sym->attr.proc_pointer ? false : sym->attr.dimension,
1386           sym->attr.proc_pointer);
1387     }
1388
1389   attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1390   decl_attributes (&decl, attributes, 0);
1391
1392   return decl;
1393 }
1394
1395
1396 /* Get a basic decl for an external function.  */
1397
1398 tree
1399 gfc_get_extern_function_decl (gfc_symbol * sym)
1400 {
1401   tree type;
1402   tree fndecl;
1403   tree attributes;
1404   gfc_expr e;
1405   gfc_intrinsic_sym *isym;
1406   gfc_expr argexpr;
1407   char s[GFC_MAX_SYMBOL_LEN + 23]; /* "_gfortran_f2c_specific" and '\0'.  */
1408   tree name;
1409   tree mangled_name;
1410   gfc_gsymbol *gsym;
1411
1412   if (sym->backend_decl)
1413     return sym->backend_decl;
1414
1415   /* We should never be creating external decls for alternate entry points.
1416      The procedure may be an alternate entry point, but we don't want/need
1417      to know that.  */
1418   gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
1419
1420   if (sym->attr.proc_pointer)
1421     return get_proc_pointer_decl (sym);
1422
1423   /* See if this is an external procedure from the same file.  If so,
1424      return the backend_decl.  */
1425   gsym =  gfc_find_gsymbol (gfc_gsym_root, sym->name);
1426
1427   if (gfc_option.flag_whole_file
1428         && !sym->attr.use_assoc
1429         && !sym->backend_decl
1430         && gsym && gsym->ns
1431         && ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION))
1432         && gsym->ns->proc_name->backend_decl)
1433     {
1434       /* If the namespace has entries, the proc_name is the
1435          entry master.  Find the entry and use its backend_decl.
1436          otherwise, use the proc_name backend_decl.  */
1437       if (gsym->ns->entries)
1438         {
1439           gfc_entry_list *entry = gsym->ns->entries;
1440
1441           for (; entry; entry = entry->next)
1442             {
1443               if (strcmp (gsym->name, entry->sym->name) == 0)
1444                 {
1445                   sym->backend_decl = entry->sym->backend_decl;
1446                   break;
1447                 }
1448             }
1449         }
1450       else
1451         {
1452           sym->backend_decl = gsym->ns->proc_name->backend_decl;
1453         }
1454
1455       if (sym->backend_decl)
1456         return sym->backend_decl;
1457     }
1458
1459   /* See if this is a module procedure from the same file.  If so,
1460      return the backend_decl.  */
1461   if (sym->module)
1462     gsym =  gfc_find_gsymbol (gfc_gsym_root, sym->module);
1463
1464   if (gfc_option.flag_whole_file
1465         && gsym && gsym->ns
1466         && gsym->type == GSYM_MODULE)
1467     {
1468       gfc_symbol *s;
1469
1470       s = NULL;
1471       gfc_find_symbol (sym->name, gsym->ns, 0, &s);
1472       if (s && s->backend_decl)
1473         {
1474           sym->backend_decl = s->backend_decl;
1475           return sym->backend_decl;
1476         }
1477     }
1478
1479   if (sym->attr.intrinsic)
1480     {
1481       /* Call the resolution function to get the actual name.  This is
1482          a nasty hack which relies on the resolution functions only looking
1483          at the first argument.  We pass NULL for the second argument
1484          otherwise things like AINT get confused.  */
1485       isym = gfc_find_function (sym->name);
1486       gcc_assert (isym->resolve.f0 != NULL);
1487
1488       memset (&e, 0, sizeof (e));
1489       e.expr_type = EXPR_FUNCTION;
1490
1491       memset (&argexpr, 0, sizeof (argexpr));
1492       gcc_assert (isym->formal);
1493       argexpr.ts = isym->formal->ts;
1494
1495       if (isym->formal->next == NULL)
1496         isym->resolve.f1 (&e, &argexpr);
1497       else
1498         {
1499           if (isym->formal->next->next == NULL)
1500             isym->resolve.f2 (&e, &argexpr, NULL);
1501           else
1502             {
1503               if (isym->formal->next->next->next == NULL)
1504                 isym->resolve.f3 (&e, &argexpr, NULL, NULL);
1505               else
1506                 {
1507                   /* All specific intrinsics take less than 5 arguments.  */
1508                   gcc_assert (isym->formal->next->next->next->next == NULL);
1509                   isym->resolve.f4 (&e, &argexpr, NULL, NULL, NULL);
1510                 }
1511             }
1512         }
1513
1514       if (gfc_option.flag_f2c
1515           && ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)
1516               || e.ts.type == BT_COMPLEX))
1517         {
1518           /* Specific which needs a different implementation if f2c
1519              calling conventions are used.  */
1520           sprintf (s, "_gfortran_f2c_specific%s", e.value.function.name);
1521         }
1522       else
1523         sprintf (s, "_gfortran_specific%s", e.value.function.name);
1524
1525       name = get_identifier (s);
1526       mangled_name = name;
1527     }
1528   else
1529     {
1530       name = gfc_sym_identifier (sym);
1531       mangled_name = gfc_sym_mangled_function_id (sym);
1532     }
1533
1534   type = gfc_get_function_type (sym);
1535   fndecl = build_decl (input_location,
1536                        FUNCTION_DECL, name, type);
1537
1538   attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1539   decl_attributes (&fndecl, attributes, 0);
1540
1541   gfc_set_decl_assembler_name (fndecl, mangled_name);
1542
1543   /* Set the context of this decl.  */
1544   if (0 && sym->ns && sym->ns->proc_name)
1545     {
1546       /* TODO: Add external decls to the appropriate scope.  */
1547       DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
1548     }
1549   else
1550     {
1551       /* Global declaration, e.g. intrinsic subroutine.  */
1552       DECL_CONTEXT (fndecl) = NULL_TREE;
1553     }
1554
1555   DECL_EXTERNAL (fndecl) = 1;
1556
1557   /* This specifies if a function is globally addressable, i.e. it is
1558      the opposite of declaring static in C.  */
1559   TREE_PUBLIC (fndecl) = 1;
1560
1561   /* Set attributes for PURE functions. A call to PURE function in the
1562      Fortran 95 sense is both pure and without side effects in the C
1563      sense.  */
1564   if (sym->attr.pure || sym->attr.elemental)
1565     {
1566       if (sym->attr.function && !gfc_return_by_reference (sym))
1567         DECL_PURE_P (fndecl) = 1;
1568       /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
1569          parameters and don't use alternate returns (is this
1570          allowed?). In that case, calls to them are meaningless, and
1571          can be optimized away. See also in build_function_decl().  */
1572       TREE_SIDE_EFFECTS (fndecl) = 0;
1573     }
1574
1575   /* Mark non-returning functions.  */
1576   if (sym->attr.noreturn)
1577       TREE_THIS_VOLATILE(fndecl) = 1;
1578
1579   sym->backend_decl = fndecl;
1580
1581   if (DECL_CONTEXT (fndecl) == NULL_TREE)
1582     pushdecl_top_level (fndecl);
1583
1584   return fndecl;
1585 }
1586
1587
1588 /* Create a declaration for a procedure.  For external functions (in the C
1589    sense) use gfc_get_extern_function_decl.  HAS_ENTRIES is true if this is
1590    a master function with alternate entry points.  */
1591
1592 static void
1593 build_function_decl (gfc_symbol * sym)
1594 {
1595   tree fndecl, type, attributes;
1596   symbol_attribute attr;
1597   tree result_decl;
1598   gfc_formal_arglist *f;
1599
1600   gcc_assert (!sym->backend_decl);
1601   gcc_assert (!sym->attr.external);
1602
1603   /* Set the line and filename.  sym->declared_at seems to point to the
1604      last statement for subroutines, but it'll do for now.  */
1605   gfc_set_backend_locus (&sym->declared_at);
1606
1607   /* Allow only one nesting level.  Allow public declarations.  */
1608   gcc_assert (current_function_decl == NULL_TREE
1609               || DECL_CONTEXT (current_function_decl) == NULL_TREE
1610               || TREE_CODE (DECL_CONTEXT (current_function_decl))
1611                  == NAMESPACE_DECL);
1612
1613   type = gfc_get_function_type (sym);
1614   fndecl = build_decl (input_location,
1615                        FUNCTION_DECL, gfc_sym_identifier (sym), type);
1616
1617   attr = sym->attr;
1618
1619   attributes = add_attributes_to_decl (attr, NULL_TREE);
1620   decl_attributes (&fndecl, attributes, 0);
1621
1622   /* Perform name mangling if this is a top level or module procedure.  */
1623   if (current_function_decl == NULL_TREE)
1624     gfc_set_decl_assembler_name (fndecl, gfc_sym_mangled_function_id (sym));
1625
1626   /* Figure out the return type of the declared function, and build a
1627      RESULT_DECL for it.  If this is a subroutine with alternate
1628      returns, build a RESULT_DECL for it.  */
1629   result_decl = NULL_TREE;
1630   /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)).  */
1631   if (attr.function)
1632     {
1633       if (gfc_return_by_reference (sym))
1634         type = void_type_node;
1635       else
1636         {
1637           if (sym->result != sym)
1638             result_decl = gfc_sym_identifier (sym->result);
1639
1640           type = TREE_TYPE (TREE_TYPE (fndecl));
1641         }
1642     }
1643   else
1644     {
1645       /* Look for alternate return placeholders.  */
1646       int has_alternate_returns = 0;
1647       for (f = sym->formal; f; f = f->next)
1648         {
1649           if (f->sym == NULL)
1650             {
1651               has_alternate_returns = 1;
1652               break;
1653             }
1654         }
1655
1656       if (has_alternate_returns)
1657         type = integer_type_node;
1658       else
1659         type = void_type_node;
1660     }
1661
1662   result_decl = build_decl (input_location,
1663                             RESULT_DECL, result_decl, type);
1664   DECL_ARTIFICIAL (result_decl) = 1;
1665   DECL_IGNORED_P (result_decl) = 1;
1666   DECL_CONTEXT (result_decl) = fndecl;
1667   DECL_RESULT (fndecl) = result_decl;
1668
1669   /* Don't call layout_decl for a RESULT_DECL.
1670      layout_decl (result_decl, 0);  */
1671
1672   /* Set up all attributes for the function.  */
1673   DECL_CONTEXT (fndecl) = current_function_decl;
1674   DECL_EXTERNAL (fndecl) = 0;
1675
1676   /* This specifies if a function is globally visible, i.e. it is
1677      the opposite of declaring static in C.  */
1678   if (DECL_CONTEXT (fndecl) == NULL_TREE
1679       && !sym->attr.entry_master && !sym->attr.is_main_program)
1680     TREE_PUBLIC (fndecl) = 1;
1681
1682   /* TREE_STATIC means the function body is defined here.  */
1683   TREE_STATIC (fndecl) = 1;
1684
1685   /* Set attributes for PURE functions. A call to a PURE function in the
1686      Fortran 95 sense is both pure and without side effects in the C
1687      sense.  */
1688   if (attr.pure || attr.elemental)
1689     {
1690       /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
1691          including an alternate return. In that case it can also be
1692          marked as PURE. See also in gfc_get_extern_function_decl().  */
1693       if (attr.function && !gfc_return_by_reference (sym))
1694         DECL_PURE_P (fndecl) = 1;
1695       TREE_SIDE_EFFECTS (fndecl) = 0;
1696     }
1697
1698
1699   /* Layout the function declaration and put it in the binding level
1700      of the current function.  */
1701   pushdecl (fndecl);
1702
1703   sym->backend_decl = fndecl;
1704 }
1705
1706
1707 /* Create the DECL_ARGUMENTS for a procedure.  */
1708
1709 static void
1710 create_function_arglist (gfc_symbol * sym)
1711 {
1712   tree fndecl;
1713   gfc_formal_arglist *f;
1714   tree typelist, hidden_typelist;
1715   tree arglist, hidden_arglist;
1716   tree type;
1717   tree parm;
1718
1719   fndecl = sym->backend_decl;
1720
1721   /* Build formal argument list. Make sure that their TREE_CONTEXT is
1722      the new FUNCTION_DECL node.  */
1723   arglist = NULL_TREE;
1724   hidden_arglist = NULL_TREE;
1725   typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
1726
1727   if (sym->attr.entry_master)
1728     {
1729       type = TREE_VALUE (typelist);
1730       parm = build_decl (input_location,
1731                          PARM_DECL, get_identifier ("__entry"), type);
1732
1733       DECL_CONTEXT (parm) = fndecl;
1734       DECL_ARG_TYPE (parm) = type;
1735       TREE_READONLY (parm) = 1;
1736       gfc_finish_decl (parm);
1737       DECL_ARTIFICIAL (parm) = 1;
1738
1739       arglist = chainon (arglist, parm);
1740       typelist = TREE_CHAIN (typelist);
1741     }
1742
1743   if (gfc_return_by_reference (sym))
1744     {
1745       tree type = TREE_VALUE (typelist), length = NULL;
1746
1747       if (sym->ts.type == BT_CHARACTER)
1748         {
1749           /* Length of character result.  */
1750           tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
1751           gcc_assert (len_type == gfc_charlen_type_node);
1752
1753           length = build_decl (input_location,
1754                                PARM_DECL,
1755                                get_identifier (".__result"),
1756                                len_type);
1757           if (!sym->ts.u.cl->length)
1758             {
1759               sym->ts.u.cl->backend_decl = length;
1760               TREE_USED (length) = 1;
1761             }
1762           gcc_assert (TREE_CODE (length) == PARM_DECL);
1763           DECL_CONTEXT (length) = fndecl;
1764           DECL_ARG_TYPE (length) = len_type;
1765           TREE_READONLY (length) = 1;
1766           DECL_ARTIFICIAL (length) = 1;
1767           gfc_finish_decl (length);
1768           if (sym->ts.u.cl->backend_decl == NULL
1769               || sym->ts.u.cl->backend_decl == length)
1770             {
1771               gfc_symbol *arg;
1772               tree backend_decl;
1773
1774               if (sym->ts.u.cl->backend_decl == NULL)
1775                 {
1776                   tree len = build_decl (input_location,
1777                                          VAR_DECL,
1778                                          get_identifier ("..__result"),
1779                                          gfc_charlen_type_node);
1780                   DECL_ARTIFICIAL (len) = 1;
1781                   TREE_USED (len) = 1;
1782                   sym->ts.u.cl->backend_decl = len;
1783                 }
1784
1785               /* Make sure PARM_DECL type doesn't point to incomplete type.  */
1786               arg = sym->result ? sym->result : sym;
1787               backend_decl = arg->backend_decl;
1788               /* Temporary clear it, so that gfc_sym_type creates complete
1789                  type.  */
1790               arg->backend_decl = NULL;
1791               type = gfc_sym_type (arg);
1792               arg->backend_decl = backend_decl;
1793               type = build_reference_type (type);
1794             }
1795         }
1796
1797       parm = build_decl (input_location,
1798                          PARM_DECL, get_identifier ("__result"), type);
1799
1800       DECL_CONTEXT (parm) = fndecl;
1801       DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1802       TREE_READONLY (parm) = 1;
1803       DECL_ARTIFICIAL (parm) = 1;
1804       gfc_finish_decl (parm);
1805
1806       arglist = chainon (arglist, parm);
1807       typelist = TREE_CHAIN (typelist);
1808
1809       if (sym->ts.type == BT_CHARACTER)
1810         {
1811           gfc_allocate_lang_decl (parm);
1812           arglist = chainon (arglist, length);
1813           typelist = TREE_CHAIN (typelist);
1814         }
1815     }
1816
1817   hidden_typelist = typelist;
1818   for (f = sym->formal; f; f = f->next)
1819     if (f->sym != NULL) /* Ignore alternate returns.  */
1820       hidden_typelist = TREE_CHAIN (hidden_typelist);
1821
1822   for (f = sym->formal; f; f = f->next)
1823     {
1824       char name[GFC_MAX_SYMBOL_LEN + 2];
1825
1826       /* Ignore alternate returns.  */
1827       if (f->sym == NULL)
1828         continue;
1829
1830       type = TREE_VALUE (typelist);
1831
1832       if (f->sym->ts.type == BT_CHARACTER
1833           && (!sym->attr.is_bind_c || sym->attr.entry_master))
1834         {
1835           tree len_type = TREE_VALUE (hidden_typelist);
1836           tree length = NULL_TREE;
1837           gcc_assert (len_type == gfc_charlen_type_node);
1838
1839           strcpy (&name[1], f->sym->name);
1840           name[0] = '_';
1841           length = build_decl (input_location,
1842                                PARM_DECL, get_identifier (name), len_type);
1843
1844           hidden_arglist = chainon (hidden_arglist, length);
1845           DECL_CONTEXT (length) = fndecl;
1846           DECL_ARTIFICIAL (length) = 1;
1847           DECL_ARG_TYPE (length) = len_type;
1848           TREE_READONLY (length) = 1;
1849           gfc_finish_decl (length);
1850
1851           /* Remember the passed value.  */
1852           if (f->sym->ts.u.cl->passed_length != NULL)
1853             {
1854               /* This can happen if the same type is used for multiple
1855                  arguments. We need to copy cl as otherwise
1856                  cl->passed_length gets overwritten.  */
1857               f->sym->ts.u.cl = gfc_new_charlen (f->sym->ns, f->sym->ts.u.cl);
1858             }
1859           f->sym->ts.u.cl->passed_length = length;
1860
1861           /* Use the passed value for assumed length variables.  */
1862           if (!f->sym->ts.u.cl->length)
1863             {
1864               TREE_USED (length) = 1;
1865               gcc_assert (!f->sym->ts.u.cl->backend_decl);
1866               f->sym->ts.u.cl->backend_decl = length;
1867             }
1868
1869           hidden_typelist = TREE_CHAIN (hidden_typelist);
1870
1871           if (f->sym->ts.u.cl->backend_decl == NULL
1872               || f->sym->ts.u.cl->backend_decl == length)
1873             {
1874               if (f->sym->ts.u.cl->backend_decl == NULL)
1875                 gfc_create_string_length (f->sym);
1876
1877               /* Make sure PARM_DECL type doesn't point to incomplete type.  */
1878               if (f->sym->attr.flavor == FL_PROCEDURE)
1879                 type = build_pointer_type (gfc_get_function_type (f->sym));
1880               else
1881                 type = gfc_sym_type (f->sym);
1882             }
1883         }
1884
1885       /* For non-constant length array arguments, make sure they use
1886          a different type node from TYPE_ARG_TYPES type.  */
1887       if (f->sym->attr.dimension
1888           && type == TREE_VALUE (typelist)
1889           && TREE_CODE (type) == POINTER_TYPE
1890           && GFC_ARRAY_TYPE_P (type)
1891           && f->sym->as->type != AS_ASSUMED_SIZE
1892           && ! COMPLETE_TYPE_P (TREE_TYPE (type)))
1893         {
1894           if (f->sym->attr.flavor == FL_PROCEDURE)
1895             type = build_pointer_type (gfc_get_function_type (f->sym));
1896           else
1897             type = gfc_sym_type (f->sym);
1898         }
1899
1900       if (f->sym->attr.proc_pointer)
1901         type = build_pointer_type (type);
1902
1903       /* Build the argument declaration.  */
1904       parm = build_decl (input_location,
1905                          PARM_DECL, gfc_sym_identifier (f->sym), type);
1906
1907       /* Fill in arg stuff.  */
1908       DECL_CONTEXT (parm) = fndecl;
1909       DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1910       /* All implementation args are read-only.  */
1911       TREE_READONLY (parm) = 1;
1912       if (POINTER_TYPE_P (type)
1913           && (!f->sym->attr.proc_pointer
1914               && f->sym->attr.flavor != FL_PROCEDURE))
1915         DECL_BY_REFERENCE (parm) = 1;
1916
1917       gfc_finish_decl (parm);
1918
1919       f->sym->backend_decl = parm;
1920
1921       arglist = chainon (arglist, parm);
1922       typelist = TREE_CHAIN (typelist);
1923     }
1924
1925   /* Add the hidden string length parameters, unless the procedure
1926      is bind(C).  */
1927   if (!sym->attr.is_bind_c)
1928     arglist = chainon (arglist, hidden_arglist);
1929
1930   gcc_assert (hidden_typelist == NULL_TREE
1931               || TREE_VALUE (hidden_typelist) == void_type_node);
1932   DECL_ARGUMENTS (fndecl) = arglist;
1933 }
1934
1935 /* Do the setup necessary before generating the body of a function.  */
1936
1937 static void
1938 trans_function_start (gfc_symbol * sym)
1939 {
1940   tree fndecl;
1941
1942   fndecl = sym->backend_decl;
1943
1944   /* Let GCC know the current scope is this function.  */
1945   current_function_decl = fndecl;
1946
1947   /* Let the world know what we're about to do.  */
1948   announce_function (fndecl);
1949
1950   if (DECL_CONTEXT (fndecl) == NULL_TREE)
1951     {
1952       /* Create RTL for function declaration.  */
1953       rest_of_decl_compilation (fndecl, 1, 0);
1954     }
1955
1956   /* Create RTL for function definition.  */
1957   make_decl_rtl (fndecl);
1958
1959   init_function_start (fndecl);
1960
1961   /* Even though we're inside a function body, we still don't want to
1962      call expand_expr to calculate the size of a variable-sized array.
1963      We haven't necessarily assigned RTL to all variables yet, so it's
1964      not safe to try to expand expressions involving them.  */
1965   cfun->dont_save_pending_sizes_p = 1;
1966
1967   /* function.c requires a push at the start of the function.  */
1968   pushlevel (0);
1969 }
1970
1971 /* Create thunks for alternate entry points.  */
1972
1973 static void
1974 build_entry_thunks (gfc_namespace * ns)
1975 {
1976   gfc_formal_arglist *formal;
1977   gfc_formal_arglist *thunk_formal;
1978   gfc_entry_list *el;
1979   gfc_symbol *thunk_sym;
1980   stmtblock_t body;
1981   tree thunk_fndecl;
1982   tree args;
1983   tree string_args;
1984   tree tmp;
1985   locus old_loc;
1986
1987   /* This should always be a toplevel function.  */
1988   gcc_assert (current_function_decl == NULL_TREE);
1989
1990   gfc_get_backend_locus (&old_loc);
1991   for (el = ns->entries; el; el = el->next)
1992     {
1993       thunk_sym = el->sym;
1994
1995       build_function_decl (thunk_sym);
1996       create_function_arglist (thunk_sym);
1997
1998       trans_function_start (thunk_sym);
1999
2000       thunk_fndecl = thunk_sym->backend_decl;
2001
2002       gfc_init_block (&body);
2003
2004       /* Pass extra parameter identifying this entry point.  */
2005       tmp = build_int_cst (gfc_array_index_type, el->id);
2006       args = tree_cons (NULL_TREE, tmp, NULL_TREE);
2007       string_args = NULL_TREE;
2008
2009       if (thunk_sym->attr.function)
2010         {
2011           if (gfc_return_by_reference (ns->proc_name))
2012             {
2013               tree ref = DECL_ARGUMENTS (current_function_decl);
2014               args = tree_cons (NULL_TREE, ref, args);
2015               if (ns->proc_name->ts.type == BT_CHARACTER)
2016                 args = tree_cons (NULL_TREE, TREE_CHAIN (ref),
2017                                   args);
2018             }
2019         }
2020
2021       for (formal = ns->proc_name->formal; formal; formal = formal->next)
2022         {
2023           /* Ignore alternate returns.  */
2024           if (formal->sym == NULL)
2025             continue;
2026
2027           /* We don't have a clever way of identifying arguments, so resort to
2028              a brute-force search.  */
2029           for (thunk_formal = thunk_sym->formal;
2030                thunk_formal;
2031                thunk_formal = thunk_formal->next)
2032             {
2033               if (thunk_formal->sym == formal->sym)
2034                 break;
2035             }
2036
2037           if (thunk_formal)
2038             {
2039               /* Pass the argument.  */
2040               DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1;
2041               args = tree_cons (NULL_TREE, thunk_formal->sym->backend_decl,
2042                                 args);
2043               if (formal->sym->ts.type == BT_CHARACTER)
2044                 {
2045                   tmp = thunk_formal->sym->ts.u.cl->backend_decl;
2046                   string_args = tree_cons (NULL_TREE, tmp, string_args);
2047                 }
2048             }
2049           else
2050             {
2051               /* Pass NULL for a missing argument.  */
2052               args = tree_cons (NULL_TREE, null_pointer_node, args);
2053               if (formal->sym->ts.type == BT_CHARACTER)
2054                 {
2055                   tmp = build_int_cst (gfc_charlen_type_node, 0);
2056                   string_args = tree_cons (NULL_TREE, tmp, string_args);
2057                 }
2058             }
2059         }
2060
2061       /* Call the master function.  */
2062       args = nreverse (args);
2063       args = chainon (args, nreverse (string_args));
2064       tmp = ns->proc_name->backend_decl;
2065       tmp = build_function_call_expr (input_location, tmp, args);
2066       if (ns->proc_name->attr.mixed_entry_master)
2067         {
2068           tree union_decl, field;
2069           tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
2070
2071           union_decl = build_decl (input_location,
2072                                    VAR_DECL, get_identifier ("__result"),
2073                                    TREE_TYPE (master_type));
2074           DECL_ARTIFICIAL (union_decl) = 1;
2075           DECL_EXTERNAL (union_decl) = 0;
2076           TREE_PUBLIC (union_decl) = 0;
2077           TREE_USED (union_decl) = 1;
2078           layout_decl (union_decl, 0);
2079           pushdecl (union_decl);
2080
2081           DECL_CONTEXT (union_decl) = current_function_decl;
2082           tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (union_decl),
2083                              union_decl, tmp);
2084           gfc_add_expr_to_block (&body, tmp);
2085
2086           for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
2087                field; field = TREE_CHAIN (field))
2088             if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
2089                 thunk_sym->result->name) == 0)
2090               break;
2091           gcc_assert (field != NULL_TREE);
2092           tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
2093                              union_decl, field, NULL_TREE);
2094           tmp = fold_build2 (MODIFY_EXPR,
2095                              TREE_TYPE (DECL_RESULT (current_function_decl)),
2096                              DECL_RESULT (current_function_decl), tmp);
2097           tmp = build1_v (RETURN_EXPR, tmp);
2098         }
2099       else if (TREE_TYPE (DECL_RESULT (current_function_decl))
2100                != void_type_node)
2101         {
2102           tmp = fold_build2 (MODIFY_EXPR,
2103                              TREE_TYPE (DECL_RESULT (current_function_decl)),
2104                              DECL_RESULT (current_function_decl), tmp);
2105           tmp = build1_v (RETURN_EXPR, tmp);
2106         }
2107       gfc_add_expr_to_block (&body, tmp);
2108
2109       /* Finish off this function and send it for code generation.  */
2110       DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
2111       tmp = getdecls ();
2112       poplevel (1, 0, 1);
2113       BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
2114       DECL_SAVED_TREE (thunk_fndecl)
2115         = build3_v (BIND_EXPR, tmp, DECL_SAVED_TREE (thunk_fndecl),
2116                     DECL_INITIAL (thunk_fndecl));
2117
2118       /* Output the GENERIC tree.  */
2119       dump_function (TDI_original, thunk_fndecl);
2120
2121       /* Store the end of the function, so that we get good line number
2122          info for the epilogue.  */
2123       cfun->function_end_locus = input_location;
2124
2125       /* We're leaving the context of this function, so zap cfun.
2126          It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
2127          tree_rest_of_compilation.  */
2128       set_cfun (NULL);
2129
2130       current_function_decl = NULL_TREE;
2131
2132       cgraph_finalize_function (thunk_fndecl, true);
2133
2134       /* We share the symbols in the formal argument list with other entry
2135          points and the master function.  Clear them so that they are
2136          recreated for each function.  */
2137       for (formal = thunk_sym->formal; formal; formal = formal->next)
2138         if (formal->sym != NULL)  /* Ignore alternate returns.  */
2139           {
2140             formal->sym->backend_decl = NULL_TREE;
2141             if (formal->sym->ts.type == BT_CHARACTER)
2142               formal->sym->ts.u.cl->backend_decl = NULL_TREE;
2143           }
2144
2145       if (thunk_sym->attr.function)
2146         {
2147           if (thunk_sym->ts.type == BT_CHARACTER)
2148             thunk_sym->ts.u.cl->backend_decl = NULL_TREE;
2149           if (thunk_sym->result->ts.type == BT_CHARACTER)
2150             thunk_sym->result->ts.u.cl->backend_decl = NULL_TREE;
2151         }
2152     }
2153
2154   gfc_set_backend_locus (&old_loc);
2155 }
2156
2157
2158 /* Create a decl for a function, and create any thunks for alternate entry
2159    points.  */
2160
2161 void
2162 gfc_create_function_decl (gfc_namespace * ns)
2163 {
2164   /* Create a declaration for the master function.  */
2165   build_function_decl (ns->proc_name);
2166
2167   /* Compile the entry thunks.  */
2168   if (ns->entries)
2169     build_entry_thunks (ns);
2170
2171   /* Now create the read argument list.  */
2172   create_function_arglist (ns->proc_name);
2173 }
2174
2175 /* Return the decl used to hold the function return value.  If
2176    parent_flag is set, the context is the parent_scope.  */
2177
2178 tree
2179 gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
2180 {
2181   tree decl;
2182   tree length;
2183   tree this_fake_result_decl;
2184   tree this_function_decl;
2185
2186   char name[GFC_MAX_SYMBOL_LEN + 10];
2187
2188   if (parent_flag)
2189     {
2190       this_fake_result_decl = parent_fake_result_decl;
2191       this_function_decl = DECL_CONTEXT (current_function_decl);
2192     }
2193   else
2194     {
2195       this_fake_result_decl = current_fake_result_decl;
2196       this_function_decl = current_function_decl;
2197     }
2198
2199   if (sym
2200       && sym->ns->proc_name->backend_decl == this_function_decl
2201       && sym->ns->proc_name->attr.entry_master
2202       && sym != sym->ns->proc_name)
2203     {
2204       tree t = NULL, var;
2205       if (this_fake_result_decl != NULL)
2206         for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t))
2207           if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
2208             break;
2209       if (t)
2210         return TREE_VALUE (t);
2211       decl = gfc_get_fake_result_decl (sym->ns->proc_name, parent_flag);
2212
2213       if (parent_flag)
2214         this_fake_result_decl = parent_fake_result_decl;
2215       else
2216         this_fake_result_decl = current_fake_result_decl;
2217
2218       if (decl && sym->ns->proc_name->attr.mixed_entry_master)
2219         {
2220           tree field;
2221
2222           for (field = TYPE_FIELDS (TREE_TYPE (decl));
2223                field; field = TREE_CHAIN (field))
2224             if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
2225                 sym->name) == 0)
2226               break;
2227
2228           gcc_assert (field != NULL_TREE);
2229           decl = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
2230                               decl, field, NULL_TREE);
2231         }
2232
2233       var = create_tmp_var_raw (TREE_TYPE (decl), sym->name);
2234       if (parent_flag)
2235         gfc_add_decl_to_parent_function (var);
2236       else
2237         gfc_add_decl_to_function (var);
2238
2239       SET_DECL_VALUE_EXPR (var, decl);
2240       DECL_HAS_VALUE_EXPR_P (var) = 1;
2241       GFC_DECL_RESULT (var) = 1;
2242
2243       TREE_CHAIN (this_fake_result_decl)
2244           = tree_cons (get_identifier (sym->name), var,
2245                        TREE_CHAIN (this_fake_result_decl));
2246       return var;
2247     }
2248
2249   if (this_fake_result_decl != NULL_TREE)
2250     return TREE_VALUE (this_fake_result_decl);
2251
2252   /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
2253      sym is NULL.  */
2254   if (!sym)
2255     return NULL_TREE;
2256
2257   if (sym->ts.type == BT_CHARACTER)
2258     {
2259       if (sym->ts.u.cl->backend_decl == NULL_TREE)
2260         length = gfc_create_string_length (sym);
2261       else
2262         length = sym->ts.u.cl->backend_decl;
2263       if (TREE_CODE (length) == VAR_DECL
2264           && DECL_CONTEXT (length) == NULL_TREE)
2265         gfc_add_decl_to_function (length);
2266     }
2267
2268   if (gfc_return_by_reference (sym))
2269     {
2270       decl = DECL_ARGUMENTS (this_function_decl);
2271
2272       if (sym->ns->proc_name->backend_decl == this_function_decl
2273           && sym->ns->proc_name->attr.entry_master)
2274         decl = TREE_CHAIN (decl);
2275
2276       TREE_USED (decl) = 1;
2277       if (sym->as)
2278         decl = gfc_build_dummy_array_decl (sym, decl);
2279     }
2280   else
2281     {
2282       sprintf (name, "__result_%.20s",
2283                IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
2284
2285       if (!sym->attr.mixed_entry_master && sym->attr.function)
2286         decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl),
2287                            VAR_DECL, get_identifier (name),
2288                            gfc_sym_type (sym));
2289       else
2290         decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl),
2291                            VAR_DECL, get_identifier (name),
2292                            TREE_TYPE (TREE_TYPE (this_function_decl)));
2293       DECL_ARTIFICIAL (decl) = 1;
2294       DECL_EXTERNAL (decl) = 0;
2295       TREE_PUBLIC (decl) = 0;
2296       TREE_USED (decl) = 1;
2297       GFC_DECL_RESULT (decl) = 1;
2298       TREE_ADDRESSABLE (decl) = 1;
2299
2300       layout_decl (decl, 0);
2301
2302       if (parent_flag)
2303         gfc_add_decl_to_parent_function (decl);
2304       else
2305         gfc_add_decl_to_function (decl);
2306     }
2307
2308   if (parent_flag)
2309     parent_fake_result_decl = build_tree_list (NULL, decl);
2310   else
2311     current_fake_result_decl = build_tree_list (NULL, decl);
2312
2313   return decl;
2314 }
2315
2316
2317 /* Builds a function decl.  The remaining parameters are the types of the
2318    function arguments.  Negative nargs indicates a varargs function.  */
2319
2320 static tree
2321 build_library_function_decl_1 (tree name, const char *spec,
2322                                tree rettype, int nargs, va_list p)
2323 {
2324   tree arglist;
2325   tree argtype;
2326   tree fntype;
2327   tree fndecl;
2328   int n;
2329
2330   /* Library functions must be declared with global scope.  */
2331   gcc_assert (current_function_decl == NULL_TREE);
2332
2333   /* Create a list of the argument types.  */
2334   for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
2335     {
2336       argtype = va_arg (p, tree);
2337       arglist = gfc_chainon_list (arglist, argtype);
2338     }
2339
2340   if (nargs >= 0)
2341     {
2342       /* Terminate the list.  */
2343       arglist = gfc_chainon_list (arglist, void_type_node);
2344     }
2345
2346   /* Build the function type and decl.  */
2347   fntype = build_function_type (rettype, arglist);
2348   if (spec)
2349     {
2350       tree attr_args = build_tree_list (NULL_TREE,
2351                                         build_string (strlen (spec), spec));
2352       tree attrs = tree_cons (get_identifier ("fn spec"),
2353                               attr_args, TYPE_ATTRIBUTES (fntype));
2354       fntype = build_type_attribute_variant (fntype, attrs);
2355     }
2356   fndecl = build_decl (input_location,
2357                        FUNCTION_DECL, name, fntype);
2358
2359   /* Mark this decl as external.  */
2360   DECL_EXTERNAL (fndecl) = 1;
2361   TREE_PUBLIC (fndecl) = 1;
2362
2363   pushdecl (fndecl);
2364
2365   rest_of_decl_compilation (fndecl, 1, 0);
2366
2367   return fndecl;
2368 }
2369
2370 /* Builds a function decl.  The remaining parameters are the types of the
2371    function arguments.  Negative nargs indicates a varargs function.  */
2372
2373 tree
2374 gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
2375 {
2376   tree ret;
2377   va_list args;
2378   va_start (args, nargs);
2379   ret = build_library_function_decl_1 (name, NULL, rettype, nargs, args);
2380   va_end (args);
2381   return ret;
2382 }
2383
2384 /* Builds a function decl.  The remaining parameters are the types of the
2385    function arguments.  Negative nargs indicates a varargs function.
2386    The SPEC parameter specifies the function argument and return type
2387    specification according to the fnspec function type attribute.  */
2388
2389 static tree
2390 gfc_build_library_function_decl_with_spec (tree name, const char *spec,
2391                                            tree rettype, int nargs, ...)
2392 {
2393   tree ret;
2394   va_list args;
2395   va_start (args, nargs);
2396   ret = build_library_function_decl_1 (name, spec, rettype, nargs, args);
2397   va_end (args);
2398   return ret;
2399 }
2400
2401 static void
2402 gfc_build_intrinsic_function_decls (void)
2403 {
2404   tree gfc_int4_type_node = gfc_get_int_type (4);
2405   tree gfc_int8_type_node = gfc_get_int_type (8);
2406   tree gfc_int16_type_node = gfc_get_int_type (16);
2407   tree gfc_logical4_type_node = gfc_get_logical_type (4);
2408   tree pchar1_type_node = gfc_get_pchar_type (1);
2409   tree pchar4_type_node = gfc_get_pchar_type (4);
2410
2411   /* String functions.  */
2412   gfor_fndecl_compare_string =
2413     gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),
2414                                      integer_type_node, 4,
2415                                      gfc_charlen_type_node, pchar1_type_node,
2416                                      gfc_charlen_type_node, pchar1_type_node);
2417
2418   gfor_fndecl_concat_string =
2419     gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),
2420                                      void_type_node, 6,
2421                                      gfc_charlen_type_node, pchar1_type_node,
2422                                      gfc_charlen_type_node, pchar1_type_node,
2423                                      gfc_charlen_type_node, pchar1_type_node);
2424
2425   gfor_fndecl_string_len_trim =
2426     gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")),
2427                                      gfc_int4_type_node, 2,
2428                                      gfc_charlen_type_node, pchar1_type_node);
2429
2430   gfor_fndecl_string_index =
2431     gfc_build_library_function_decl (get_identifier (PREFIX("string_index")),
2432                                      gfc_int4_type_node, 5,
2433                                      gfc_charlen_type_node, pchar1_type_node,
2434                                      gfc_charlen_type_node, pchar1_type_node,
2435                                      gfc_logical4_type_node);
2436
2437   gfor_fndecl_string_scan =
2438     gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")),
2439                                      gfc_int4_type_node, 5,
2440                                      gfc_charlen_type_node, pchar1_type_node,
2441                                      gfc_charlen_type_node, pchar1_type_node,
2442                                      gfc_logical4_type_node);
2443
2444   gfor_fndecl_string_verify =
2445     gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")),
2446                                      gfc_int4_type_node, 5,
2447                                      gfc_charlen_type_node, pchar1_type_node,
2448                                      gfc_charlen_type_node, pchar1_type_node,
2449                                      gfc_logical4_type_node);
2450
2451   gfor_fndecl_string_trim =
2452     gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),
2453                                      void_type_node, 4,
2454                                      build_pointer_type (gfc_charlen_type_node),
2455                                      build_pointer_type (pchar1_type_node),
2456                                      gfc_charlen_type_node, pchar1_type_node);
2457
2458   gfor_fndecl_string_minmax =
2459     gfc_build_library_function_decl (get_identifier (PREFIX("string_minmax")),
2460                                      void_type_node, -4,
2461                                      build_pointer_type (gfc_charlen_type_node),
2462                                      build_pointer_type (pchar1_type_node),
2463                                      integer_type_node, integer_type_node);
2464
2465   gfor_fndecl_adjustl =
2466     gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),
2467                                      void_type_node, 3, pchar1_type_node,
2468                                      gfc_charlen_type_node, pchar1_type_node);
2469
2470   gfor_fndecl_adjustr =
2471     gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")),
2472                                      void_type_node, 3, pchar1_type_node,
2473                                      gfc_charlen_type_node, pchar1_type_node);
2474
2475   gfor_fndecl_select_string =
2476     gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
2477                                      integer_type_node, 4, pvoid_type_node,
2478                                      integer_type_node, pchar1_type_node,
2479                                      gfc_charlen_type_node);
2480
2481   gfor_fndecl_compare_string_char4 =
2482     gfc_build_library_function_decl (get_identifier
2483                                         (PREFIX("compare_string_char4")),
2484                                      integer_type_node, 4,
2485                                      gfc_charlen_type_node, pchar4_type_node,
2486                                      gfc_charlen_type_node, pchar4_type_node);
2487
2488   gfor_fndecl_concat_string_char4 =
2489     gfc_build_library_function_decl (get_identifier
2490                                         (PREFIX("concat_string_char4")),
2491                                      void_type_node, 6,
2492                                      gfc_charlen_type_node, pchar4_type_node,
2493                                      gfc_charlen_type_node, pchar4_type_node,
2494                                      gfc_charlen_type_node, pchar4_type_node);
2495
2496   gfor_fndecl_string_len_trim_char4 =
2497     gfc_build_library_function_decl (get_identifier
2498                                         (PREFIX("string_len_trim_char4")),
2499                                      gfc_charlen_type_node, 2,
2500                                      gfc_charlen_type_node, pchar4_type_node);
2501
2502   gfor_fndecl_string_index_char4 =
2503     gfc_build_library_function_decl (get_identifier
2504                                         (PREFIX("string_index_char4")),
2505                                      gfc_charlen_type_node, 5,
2506                                      gfc_charlen_type_node, pchar4_type_node,
2507                                      gfc_charlen_type_node, pchar4_type_node,
2508                                      gfc_logical4_type_node);
2509
2510   gfor_fndecl_string_scan_char4 =
2511     gfc_build_library_function_decl (get_identifier
2512                                         (PREFIX("string_scan_char4")),
2513                                      gfc_charlen_type_node, 5,
2514                                      gfc_charlen_type_node, pchar4_type_node,
2515                                      gfc_charlen_type_node, pchar4_type_node,
2516                                      gfc_logical4_type_node);
2517
2518   gfor_fndecl_string_verify_char4 =
2519     gfc_build_library_function_decl (get_identifier
2520                                         (PREFIX("string_verify_char4")),
2521                                      gfc_charlen_type_node, 5,
2522                                      gfc_charlen_type_node, pchar4_type_node,
2523                                      gfc_charlen_type_node, pchar4_type_node,
2524                                      gfc_logical4_type_node);
2525
2526   gfor_fndecl_string_trim_char4 =
2527     gfc_build_library_function_decl (get_identifier
2528                                         (PREFIX("string_trim_char4")),
2529                                      void_type_node, 4,
2530                                      build_pointer_type (gfc_charlen_type_node),
2531                                      build_pointer_type (pchar4_type_node),
2532                                      gfc_charlen_type_node, pchar4_type_node);
2533
2534   gfor_fndecl_string_minmax_char4 =
2535     gfc_build_library_function_decl (get_identifier
2536                                         (PREFIX("string_minmax_char4")),
2537                                      void_type_node, -4,
2538                                      build_pointer_type (gfc_charlen_type_node),
2539                                      build_pointer_type (pchar4_type_node),
2540                                      integer_type_node, integer_type_node);
2541
2542   gfor_fndecl_adjustl_char4 =
2543     gfc_build_library_function_decl (get_identifier (PREFIX("adjustl_char4")),
2544                                      void_type_node, 3, pchar4_type_node,
2545                                      gfc_charlen_type_node, pchar4_type_node);
2546
2547   gfor_fndecl_adjustr_char4 =
2548     gfc_build_library_function_decl (get_identifier (PREFIX("adjustr_char4")),
2549                                      void_type_node, 3, pchar4_type_node,
2550                                      gfc_charlen_type_node, pchar4_type_node);
2551
2552   gfor_fndecl_select_string_char4 =
2553     gfc_build_library_function_decl (get_identifier
2554                                         (PREFIX("select_string_char4")),
2555                                      integer_type_node, 4, pvoid_type_node,
2556                                      integer_type_node, pvoid_type_node,
2557                                      gfc_charlen_type_node);
2558
2559
2560   /* Conversion between character kinds.  */
2561
2562   gfor_fndecl_convert_char1_to_char4 =
2563     gfc_build_library_function_decl (get_identifier
2564                                         (PREFIX("convert_char1_to_char4")),
2565                                      void_type_node, 3,
2566                                      build_pointer_type (pchar4_type_node),
2567                                      gfc_charlen_type_node, pchar1_type_node);
2568
2569   gfor_fndecl_convert_char4_to_char1 =
2570     gfc_build_library_function_decl (get_identifier
2571                                         (PREFIX("convert_char4_to_char1")),
2572                                      void_type_node, 3,
2573                                      build_pointer_type (pchar1_type_node),
2574                                      gfc_charlen_type_node, pchar4_type_node);
2575
2576   /* Misc. functions.  */
2577
2578   gfor_fndecl_ttynam =
2579     gfc_build_library_function_decl (get_identifier (PREFIX("ttynam")),
2580                                      void_type_node,
2581                                      3,
2582                                      pchar_type_node,
2583                                      gfc_charlen_type_node,
2584                                      integer_type_node);
2585
2586   gfor_fndecl_fdate =
2587     gfc_build_library_function_decl (get_identifier (PREFIX("fdate")),
2588                                      void_type_node,
2589                                      2,
2590                                      pchar_type_node,
2591                                      gfc_charlen_type_node);
2592
2593   gfor_fndecl_ctime =
2594     gfc_build_library_function_decl (get_identifier (PREFIX("ctime")),
2595                                      void_type_node,
2596                                      3,
2597                                      pchar_type_node,
2598                                      gfc_charlen_type_node,
2599                                      gfc_int8_type_node);
2600
2601   gfor_fndecl_sc_kind =
2602     gfc_build_library_function_decl (get_identifier
2603                                         (PREFIX("selected_char_kind")),
2604                                      gfc_int4_type_node, 2,
2605                                      gfc_charlen_type_node, pchar_type_node);
2606
2607   gfor_fndecl_si_kind =
2608     gfc_build_library_function_decl (get_identifier
2609                                         (PREFIX("selected_int_kind")),
2610                                      gfc_int4_type_node, 1, pvoid_type_node);
2611
2612   gfor_fndecl_sr_kind =
2613     gfc_build_library_function_decl (get_identifier
2614                                         (PREFIX("selected_real_kind")),
2615                                      gfc_int4_type_node, 2,
2616                                      pvoid_type_node, pvoid_type_node);
2617
2618   /* Power functions.  */
2619   {
2620     tree ctype, rtype, itype, jtype;
2621     int rkind, ikind, jkind;
2622 #define NIKINDS 3
2623 #define NRKINDS 4
2624     static int ikinds[NIKINDS] = {4, 8, 16};
2625     static int rkinds[NRKINDS] = {4, 8, 10, 16};
2626     char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */
2627
2628     for (ikind=0; ikind < NIKINDS; ikind++)
2629       {
2630         itype = gfc_get_int_type (ikinds[ikind]);
2631
2632         for (jkind=0; jkind < NIKINDS; jkind++)
2633           {
2634             jtype = gfc_get_int_type (ikinds[jkind]);
2635             if (itype && jtype)
2636               {
2637                 sprintf(name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
2638                         ikinds[jkind]);
2639                 gfor_fndecl_math_powi[jkind][ikind].integer =
2640                   gfc_build_library_function_decl (get_identifier (name),
2641                     jtype, 2, jtype, itype);
2642                 TREE_READONLY (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
2643               }
2644           }
2645
2646         for (rkind = 0; rkind < NRKINDS; rkind ++)
2647           {
2648             rtype = gfc_get_real_type (rkinds[rkind]);
2649             if (rtype && itype)
2650               {
2651                 sprintf(name, PREFIX("pow_r%d_i%d"), rkinds[rkind],
2652                         ikinds[ikind]);
2653                 gfor_fndecl_math_powi[rkind][ikind].real =
2654                   gfc_build_library_function_decl (get_identifier (name),
2655                     rtype, 2, rtype, itype);
2656                 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
2657               }
2658
2659             ctype = gfc_get_complex_type (rkinds[rkind]);
2660             if (ctype && itype)
2661               {
2662                 sprintf(name, PREFIX("pow_c%d_i%d"), rkinds[rkind],
2663                         ikinds[ikind]);
2664                 gfor_fndecl_math_powi[rkind][ikind].cmplx =
2665                   gfc_build_library_function_decl (get_identifier (name),
2666                     ctype, 2,ctype, itype);
2667                 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
2668               }
2669           }
2670       }
2671 #undef NIKINDS
2672 #undef NRKINDS
2673   }
2674
2675   gfor_fndecl_math_ishftc4 =
2676     gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")),
2677                                      gfc_int4_type_node,
2678                                      3, gfc_int4_type_node,
2679                                      gfc_int4_type_node, gfc_int4_type_node);
2680   gfor_fndecl_math_ishftc8 =
2681     gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")),
2682                                      gfc_int8_type_node,
2683                                      3, gfc_int8_type_node,
2684                                      gfc_int4_type_node, gfc_int4_type_node);
2685   if (gfc_int16_type_node)
2686     gfor_fndecl_math_ishftc16 =
2687       gfc_build_library_function_decl (get_identifier (PREFIX("ishftc16")),
2688                                        gfc_int16_type_node, 3,
2689                                        gfc_int16_type_node,
2690                                        gfc_int4_type_node,
2691                                        gfc_int4_type_node);
2692
2693   /* BLAS functions.  */
2694   {
2695     tree pint = build_pointer_type (integer_type_node);
2696     tree ps = build_pointer_type (gfc_get_real_type (gfc_default_real_kind));
2697     tree pd = build_pointer_type (gfc_get_real_type (gfc_default_double_kind));
2698     tree pc = build_pointer_type (gfc_get_complex_type (gfc_default_real_kind));
2699     tree pz = build_pointer_type
2700                 (gfc_get_complex_type (gfc_default_double_kind));
2701
2702     gfor_fndecl_sgemm = gfc_build_library_function_decl
2703                           (get_identifier
2704                              (gfc_option.flag_underscoring ? "sgemm_"
2705                                                            : "sgemm"),
2706                            void_type_node, 15, pchar_type_node,
2707                            pchar_type_node, pint, pint, pint, ps, ps, pint,
2708                            ps, pint, ps, ps, pint, integer_type_node,
2709                            integer_type_node);
2710     gfor_fndecl_dgemm = gfc_build_library_function_decl
2711                           (get_identifier
2712                              (gfc_option.flag_underscoring ? "dgemm_"
2713                                                            : "dgemm"),
2714                            void_type_node, 15, pchar_type_node,
2715                            pchar_type_node, pint, pint, pint, pd, pd, pint,
2716                            pd, pint, pd, pd, pint, integer_type_node,
2717                            integer_type_node);
2718     gfor_fndecl_cgemm = gfc_build_library_function_decl
2719                           (get_identifier
2720                              (gfc_option.flag_underscoring ? "cgemm_"
2721                                                            : "cgemm"),
2722                            void_type_node, 15, pchar_type_node,
2723                            pchar_type_node, pint, pint, pint, pc, pc, pint,
2724                            pc, pint, pc, pc, pint, integer_type_node,
2725                            integer_type_node);
2726     gfor_fndecl_zgemm = gfc_build_library_function_decl
2727                           (get_identifier
2728                              (gfc_option.flag_underscoring ? "zgemm_"
2729                                                            : "zgemm"),
2730                            void_type_node, 15, pchar_type_node,
2731                            pchar_type_node, pint, pint, pint, pz, pz, pint,
2732                            pz, pint, pz, pz, pint, integer_type_node,
2733                            integer_type_node);
2734   }
2735
2736   /* Other functions.  */
2737   gfor_fndecl_size0 =
2738     gfc_build_library_function_decl (get_identifier (PREFIX("size0")),
2739                                      gfc_array_index_type,
2740                                      1, pvoid_type_node);
2741   gfor_fndecl_size1 =
2742     gfc_build_library_function_decl (get_identifier (PREFIX("size1")),
2743                                      gfc_array_index_type,
2744                                      2, pvoid_type_node,
2745                                      gfc_array_index_type);
2746
2747   gfor_fndecl_iargc =
2748     gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),
2749                                      gfc_int4_type_node,
2750                                      0);
2751
2752   if (gfc_type_for_size (128, true))
2753     {
2754       tree uint128 = gfc_type_for_size (128, true);
2755
2756       gfor_fndecl_clz128 =
2757         gfc_build_library_function_decl (get_identifier (PREFIX ("clz128")),
2758                                          integer_type_node, 1, uint128);
2759
2760       gfor_fndecl_ctz128 =
2761         gfc_build_library_function_decl (get_identifier (PREFIX ("ctz128")),
2762                                          integer_type_node, 1, uint128);
2763     }
2764 }
2765
2766
2767 /* Make prototypes for runtime library functions.  */
2768
2769 void
2770 gfc_build_builtin_function_decls (void)
2771 {
2772   tree gfc_int4_type_node = gfc_get_int_type (4);
2773
2774   gfor_fndecl_stop_numeric =
2775     gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
2776                                      void_type_node, 1, gfc_int4_type_node);
2777   /* Stop doesn't return.  */
2778   TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
2779
2780   gfor_fndecl_stop_string =
2781     gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),
2782                                      void_type_node, 2, pchar_type_node,
2783                                      gfc_int4_type_node);
2784   /* Stop doesn't return.  */
2785   TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
2786
2787   gfor_fndecl_error_stop_string =
2788     gfc_build_library_function_decl (get_identifier (PREFIX("error_stop_string")),
2789                                      void_type_node, 2, pchar_type_node,
2790                                      gfc_int4_type_node);
2791   /* ERROR STOP doesn't return.  */
2792   TREE_THIS_VOLATILE (gfor_fndecl_error_stop_string) = 1;
2793
2794   gfor_fndecl_pause_numeric =
2795     gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
2796                                      void_type_node, 1, gfc_int4_type_node);
2797
2798   gfor_fndecl_pause_string =
2799     gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")),
2800                                      void_type_node, 2, pchar_type_node,
2801                                      gfc_int4_type_node);
2802
2803   gfor_fndecl_runtime_error =
2804     gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
2805                                      void_type_node, -1, pchar_type_node);
2806   /* The runtime_error function does not return.  */
2807   TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
2808
2809   gfor_fndecl_runtime_error_at =
2810     gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error_at")),
2811                                      void_type_node, -2, pchar_type_node,
2812                                      pchar_type_node);
2813   /* The runtime_error_at function does not return.  */
2814   TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1;
2815
2816   gfor_fndecl_runtime_warning_at =
2817     gfc_build_library_function_decl (get_identifier (PREFIX("runtime_warning_at")),
2818                                      void_type_node, -2, pchar_type_node,
2819                                      pchar_type_node);
2820   gfor_fndecl_generate_error =
2821     gfc_build_library_function_decl (get_identifier (PREFIX("generate_error")),
2822                                      void_type_node, 3, pvoid_type_node,
2823                                      integer_type_node, pchar_type_node);
2824
2825   gfor_fndecl_os_error =
2826     gfc_build_library_function_decl (get_identifier (PREFIX("os_error")),
2827                                      void_type_node, 1, pchar_type_node);
2828   /* The runtime_error function does not return.  */
2829   TREE_THIS_VOLATILE (gfor_fndecl_os_error) = 1;
2830
2831   gfor_fndecl_set_args =
2832     gfc_build_library_function_decl (get_identifier (PREFIX("set_args")),
2833                                      void_type_node, 2, integer_type_node,
2834                                      build_pointer_type (pchar_type_node));
2835
2836   gfor_fndecl_set_fpe =
2837     gfc_build_library_function_decl (get_identifier (PREFIX("set_fpe")),
2838                                     void_type_node, 1, integer_type_node);
2839
2840   /* Keep the array dimension in sync with the call, later in this file.  */
2841   gfor_fndecl_set_options =
2842     gfc_build_library_function_decl (get_identifier (PREFIX("set_options")),
2843                                     void_type_node, 2, integer_type_node,
2844                                     build_pointer_type (integer_type_node));
2845
2846   gfor_fndecl_set_convert =
2847     gfc_build_library_function_decl (get_identifier (PREFIX("set_convert")),
2848                                      void_type_node, 1, integer_type_node);
2849
2850   gfor_fndecl_set_record_marker =
2851     gfc_build_library_function_decl (get_identifier (PREFIX("set_record_marker")),
2852                                      void_type_node, 1, integer_type_node);
2853
2854   gfor_fndecl_set_max_subrecord_length =
2855     gfc_build_library_function_decl (get_identifier (PREFIX("set_max_subrecord_length")),
2856                                      void_type_node, 1, integer_type_node);
2857
2858   gfor_fndecl_in_pack = gfc_build_library_function_decl_with_spec (
2859         get_identifier (PREFIX("internal_pack")), ".r",
2860         pvoid_type_node, 1, pvoid_type_node);
2861
2862   gfor_fndecl_in_unpack = gfc_build_library_function_decl_with_spec (
2863         get_identifier (PREFIX("internal_unpack")), ".wR",
2864         void_type_node, 2, pvoid_type_node, pvoid_type_node);
2865
2866   gfor_fndecl_associated =
2867     gfc_build_library_function_decl (
2868                                      get_identifier (PREFIX("associated")),
2869                                      integer_type_node, 2, ppvoid_type_node,
2870                                      ppvoid_type_node);
2871
2872   gfc_build_intrinsic_function_decls ();
2873   gfc_build_intrinsic_lib_fndecls ();
2874   gfc_build_io_library_fndecls ();
2875 }
2876
2877
2878 /* Evaluate the length of dummy character variables.  */
2879
2880 static tree
2881 gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl, tree fnbody)
2882 {
2883   stmtblock_t body;
2884
2885   gfc_finish_decl (cl->backend_decl);
2886
2887   gfc_start_block (&body);
2888
2889   /* Evaluate the string length expression.  */
2890   gfc_conv_string_length (cl, NULL, &body);
2891
2892   gfc_trans_vla_type_sizes (sym, &body);
2893
2894   gfc_add_expr_to_block (&body, fnbody);
2895   return gfc_finish_block (&body);
2896 }
2897
2898
2899 /* Allocate and cleanup an automatic character variable.  */
2900
2901 static tree
2902 gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
2903 {
2904   stmtblock_t body;
2905   tree decl;
2906   tree tmp;
2907
2908   gcc_assert (sym->backend_decl);
2909   gcc_assert (sym->ts.u.cl && sym->ts.u.cl->length);
2910
2911   gfc_start_block (&body);
2912
2913   /* Evaluate the string length expression.  */
2914   gfc_conv_string_length (sym->ts.u.cl, NULL, &body);
2915
2916   gfc_trans_vla_type_sizes (sym, &body);
2917
2918   decl = sym->backend_decl;
2919
2920   /* Emit a DECL_EXPR for this variable, which will cause the
2921      gimplifier to allocate storage, and all that good stuff.  */
2922   tmp = fold_build1 (DECL_EXPR, TREE_TYPE (decl), decl);
2923   gfc_add_expr_to_block (&body, tmp);
2924
2925   gfc_add_expr_to_block (&body, fnbody);
2926   return gfc_finish_block (&body);
2927 }
2928
2929 /* Set the initial value of ASSIGN statement auxiliary variable explicitly.  */
2930
2931 static tree
2932 gfc_trans_assign_aux_var (gfc_symbol * sym, tree fnbody)
2933 {
2934   stmtblock_t body;
2935
2936   gcc_assert (sym->backend_decl);
2937   gfc_start_block (&body);
2938
2939   /* Set the initial value to length. See the comments in
2940      function gfc_add_assign_aux_vars in this file.  */
2941   gfc_add_modify (&body, GFC_DECL_STRING_LEN (sym->backend_decl),
2942                        build_int_cst (NULL_TREE, -2));
2943
2944   gfc_add_expr_to_block (&body, fnbody);
2945   return gfc_finish_block (&body);
2946 }
2947
2948 static void
2949 gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body)
2950 {
2951   tree t = *tp, var, val;
2952
2953   if (t == NULL || t == error_mark_node)
2954     return;
2955   if (TREE_CONSTANT (t) || DECL_P (t))
2956     return;
2957
2958   if (TREE_CODE (t) == SAVE_EXPR)
2959     {
2960       if (SAVE_EXPR_RESOLVED_P (t))
2961         {
2962           *tp = TREE_OPERAND (t, 0);
2963           return;
2964         }
2965       val = TREE_OPERAND (t, 0);
2966     }
2967   else
2968     val = t;
2969
2970   var = gfc_create_var_np (TREE_TYPE (t), NULL);
2971   gfc_add_decl_to_function (var);
2972   gfc_add_modify (body, var, val);
2973   if (TREE_CODE (t) == SAVE_EXPR)
2974     TREE_OPERAND (t, 0) = var;
2975   *tp = var;
2976 }
2977
2978 static void
2979 gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
2980 {
2981   tree t;
2982
2983   if (type == NULL || type == error_mark_node)
2984     return;
2985
2986   type = TYPE_MAIN_VARIANT (type);
2987
2988   if (TREE_CODE (type) == INTEGER_TYPE)
2989     {
2990       gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body);
2991       gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body);
2992
2993       for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
2994         {
2995           TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type);
2996           TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type);
2997         }
2998     }
2999   else if (TREE_CODE (type) == ARRAY_TYPE)
3000     {
3001       gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);
3002       gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);
3003       gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body);
3004       gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body);
3005
3006       for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
3007         {
3008           TYPE_SIZE (t) = TYPE_SIZE (type);
3009           TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type);
3010         }
3011     }
3012 }
3013
3014 /* Make sure all type sizes and array domains are either constant,
3015    or variable or parameter decls.  This is a simplified variant
3016    of gimplify_type_sizes, but we can't use it here, as none of the
3017    variables in the expressions have been gimplified yet.
3018    As type sizes and domains for various variable length arrays
3019    contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
3020    time, without this routine gimplify_type_sizes in the middle-end
3021    could result in the type sizes being gimplified earlier than where
3022    those variables are initialized.  */
3023
3024 void
3025 gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
3026 {
3027   tree type = TREE_TYPE (sym->backend_decl);
3028
3029   if (TREE_CODE (type) == FUNCTION_TYPE
3030       && (sym->attr.function || sym->attr.result || sym->attr.entry))
3031     {
3032       if (! current_fake_result_decl)
3033         return;
3034
3035       type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));
3036     }
3037
3038   while (POINTER_TYPE_P (type))
3039     type = TREE_TYPE (type);
3040
3041   if (GFC_DESCRIPTOR_TYPE_P (type))
3042     {
3043       tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
3044
3045       while (POINTER_TYPE_P (etype))
3046         etype = TREE_TYPE (etype);
3047
3048       gfc_trans_vla_type_sizes_1 (etype, body);
3049     }
3050
3051   gfc_trans_vla_type_sizes_1 (type, body);
3052 }
3053
3054
3055 /* Initialize a derived type by building an lvalue from the symbol
3056    and using trans_assignment to do the work. Set dealloc to false
3057    if no deallocation prior the assignment is needed.  */
3058 tree
3059 gfc_init_default_dt (gfc_symbol * sym, tree body, bool dealloc)
3060 {
3061   stmtblock_t fnblock;
3062   gfc_expr *e;
3063   tree tmp;
3064   tree present;
3065
3066   gfc_init_block (&fnblock);
3067   gcc_assert (!sym->attr.allocatable);
3068   gfc_set_sym_referenced (sym);
3069   e = gfc_lval_expr_from_sym (sym);
3070   tmp = gfc_trans_assignment (e, sym->value, false, dealloc);
3071   if (sym->attr.dummy && (sym->attr.optional
3072                           || sym->ns->proc_name->attr.entry_master))
3073     {
3074       present = gfc_conv_expr_present (sym);
3075       tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
3076                     tmp, build_empty_stmt (input_location));
3077     }
3078   gfc_add_expr_to_block (&fnblock, tmp);
3079   gfc_free_expr (e);
3080   if (body)
3081     gfc_add_expr_to_block (&fnblock, body);
3082   return gfc_finish_block (&fnblock);
3083 }
3084
3085
3086 /* Initialize INTENT(OUT) derived type dummies.  As well as giving
3087    them their default initializer, if they do not have allocatable
3088    components, they have their allocatable components deallocated. */
3089
3090 static tree
3091 init_intent_out_dt (gfc_symbol * proc_sym, tree body)
3092 {
3093   stmtblock_t fnblock;
3094   gfc_formal_arglist *f;
3095   tree tmp;
3096   tree present;
3097
3098   gfc_init_block (&fnblock);
3099   for (f = proc_sym->formal; f; f = f->next)
3100     if (f->sym && f->sym->attr.intent == INTENT_OUT
3101         && !f->sym->attr.pointer
3102         && f->sym->ts.type == BT_DERIVED)
3103       {
3104         if (f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value)
3105           {
3106             tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived,
3107                                              f->sym->backend_decl,
3108                                              f->sym->as ? f->sym->as->rank : 0);
3109
3110             if (f->sym->attr.optional
3111                 || f->sym->ns->proc_name->attr.entry_master)
3112               {
3113                 present = gfc_conv_expr_present (f->sym);
3114                 tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
3115                               tmp, build_empty_stmt (input_location));
3116               }
3117
3118             gfc_add_expr_to_block (&fnblock, tmp);
3119           }
3120        else if (f->sym->value)
3121           body = gfc_init_default_dt (f->sym, body, true);
3122       }
3123
3124   gfc_add_expr_to_block (&fnblock, body);
3125   return gfc_finish_block (&fnblock);
3126 }
3127
3128
3129 /* Generate function entry and exit code, and add it to the function body.
3130    This includes:
3131     Allocation and initialization of array variables.
3132     Allocation of character string variables.
3133     Initialization and possibly repacking of dummy arrays.
3134     Initialization of ASSIGN statement auxiliary variable.
3135     Automatic deallocation.  */
3136
3137 tree
3138 gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
3139 {
3140   locus loc;
3141   gfc_symbol *sym;
3142   gfc_formal_arglist *f;
3143   stmtblock_t body;
3144   bool seen_trans_deferred_array = false;
3145
3146   /* Deal with implicit return variables.  Explicit return variables will
3147      already have been added.  */
3148   if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
3149     {
3150       if (!current_fake_result_decl)
3151         {
3152           gfc_entry_list *el = NULL;
3153           if (proc_sym->attr.entry_master)
3154             {
3155               for (el = proc_sym->ns->entries; el; el = el->next)
3156                 if (el->sym != el->sym->result)
3157                   break;
3158             }
3159           /* TODO: move to the appropriate place in resolve.c.  */
3160           if (warn_return_type && el == NULL)
3161             gfc_warning ("Return value of function '%s' at %L not set",
3162                          proc_sym->name, &proc_sym->declared_at);
3163         }
3164       else if (proc_sym->as)
3165         {
3166           tree result = TREE_VALUE (current_fake_result_decl);
3167           fnbody = gfc_trans_dummy_array_bias (proc_sym, result, fnbody);
3168
3169           /* An automatic character length, pointer array result.  */
3170           if (proc_sym->ts.type == BT_CHARACTER
3171                 && TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
3172             fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl,
3173                                                 fnbody);
3174         }
3175       else if (proc_sym->ts.type == BT_CHARACTER)
3176         {
3177           if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
3178             fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl,
3179                                                 fnbody);
3180         }
3181       else
3182         gcc_assert (gfc_option.flag_f2c
3183                     && proc_sym->ts.type == BT_COMPLEX);
3184     }
3185
3186   /* Initialize the INTENT(OUT) derived type dummy arguments.  This
3187      should be done here so that the offsets and lbounds of arrays
3188      are available.  */
3189   fnbody = init_intent_out_dt (proc_sym, fnbody);
3190
3191   for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
3192     {
3193       bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
3194                                    && sym->ts.u.derived->attr.alloc_comp;
3195       if (sym->attr.dimension)
3196         {
3197           switch (sym->as->type)
3198             {
3199             case AS_EXPLICIT:
3200               if (sym->attr.dummy || sym->attr.result)
3201                 fnbody =
3202                   gfc_trans_dummy_array_bias (sym, sym->backend_decl, fnbody);
3203               else if (sym->attr.pointer || sym->attr.allocatable)
3204                 {
3205                   if (TREE_STATIC (sym->backend_decl))
3206                     gfc_trans_static_array_pointer (sym);
3207                   else
3208                     {
3209                       seen_trans_deferred_array = true;
3210                       fnbody = gfc_trans_deferred_array (sym, fnbody);
3211                     }
3212                 }
3213               else
3214                 {
3215                   if (sym_has_alloc_comp)
3216                     {
3217                       seen_trans_deferred_array = true;
3218                       fnbody = gfc_trans_deferred_array (sym, fnbody);
3219                     }
3220                   else if (sym->ts.type == BT_DERIVED
3221                              && sym->value
3222                              && !sym->attr.data
3223                              && sym->attr.save == SAVE_NONE)
3224                     fnbody = gfc_init_default_dt (sym, fnbody, false);
3225
3226                   gfc_get_backend_locus (&loc);
3227                   gfc_set_backend_locus (&sym->declared_at);
3228                   fnbody = gfc_trans_auto_array_allocation (sym->backend_decl,
3229                       sym, fnbody);
3230                   gfc_set_backend_locus (&loc);
3231                 }
3232               break;
3233
3234             case AS_ASSUMED_SIZE:
3235               /* Must be a dummy parameter.  */
3236               gcc_assert (sym->attr.dummy || sym->as->cp_was_assumed);
3237
3238               /* We should always pass assumed size arrays the g77 way.  */
3239               if (sym->attr.dummy)
3240                 fnbody = gfc_trans_g77_array (sym, fnbody);
3241               break;
3242
3243             case AS_ASSUMED_SHAPE:
3244               /* Must be a dummy parameter.  */
3245               gcc_assert (sym->attr.dummy);
3246
3247               fnbody = gfc_trans_dummy_array_bias (sym, sym->backend_decl,
3248                                                    fnbody);
3249               break;
3250
3251             case AS_DEFERRED:
3252               seen_trans_deferred_array = true;
3253               fnbody = gfc_trans_deferred_array (sym, fnbody);
3254               break;
3255
3256             default:
3257               gcc_unreachable ();
3258             }
3259           if (sym_has_alloc_comp && !seen_trans_deferred_array)
3260             fnbody = gfc_trans_deferred_array (sym, fnbody);
3261         }
3262       else if (sym->attr.allocatable
3263                || (sym->ts.type == BT_CLASS
3264                    && sym->ts.u.derived->components->attr.allocatable))
3265         {
3266           if (!sym->attr.save)
3267             {
3268               /* Nullify and automatic deallocation of allocatable
3269                  scalars.  */
3270               tree tmp;
3271               gfc_expr *e;
3272               gfc_se se;
3273               stmtblock_t block;
3274
3275               e = gfc_lval_expr_from_sym (sym);
3276               if (sym->ts.type == BT_CLASS)
3277                 gfc_add_component_ref (e, "$data");
3278
3279               gfc_init_se (&se, NULL);
3280               se.want_pointer = 1;
3281               gfc_conv_expr (&se, e);
3282               gfc_free_expr (e);
3283
3284               /* Nullify when entering the scope.  */
3285               gfc_start_block (&block);
3286               gfc_add_modify (&block, se.expr,
3287                               fold_convert (TREE_TYPE (se.expr),
3288                                             null_pointer_node));
3289               gfc_add_expr_to_block (&block, fnbody);
3290
3291               /* Deallocate when leaving the scope. Nullifying is not
3292                  needed.  */
3293               tmp = gfc_deallocate_with_status (se.expr, NULL_TREE, true,
3294                                                 NULL);
3295               gfc_add_expr_to_block (&block, tmp);
3296               fnbody = gfc_finish_block (&block);
3297             }
3298         }
3299       else if (sym_has_alloc_comp)
3300         fnbody = gfc_trans_deferred_array (sym, fnbody);
3301       else if (sym->ts.type == BT_CHARACTER)
3302         {
3303           gfc_get_backend_locus (&loc);
3304           gfc_set_backend_locus (&sym->declared_at);
3305           if (sym->attr.dummy || sym->attr.result)
3306             fnbody = gfc_trans_dummy_character (sym, sym->ts.u.cl, fnbody);
3307           else
3308             fnbody = gfc_trans_auto_character_variable (sym, fnbody);
3309           gfc_set_backend_locus (&loc);
3310         }
3311       else if (sym->attr.assign)
3312         {
3313           gfc_get_backend_locus (&loc);
3314           gfc_set_backend_locus (&sym->declared_at);
3315           fnbody = gfc_trans_assign_aux_var (sym, fnbody);
3316           gfc_set_backend_locus (&loc);
3317         }
3318       else if (sym->ts.type == BT_DERIVED
3319                  && sym->value
3320                  && !sym->attr.data
3321                  && sym->attr.save == SAVE_NONE)
3322         fnbody = gfc_init_default_dt (sym, fnbody, false);
3323       else
3324         gcc_unreachable ();
3325     }
3326
3327   gfc_init_block (&body);
3328
3329   for (f = proc_sym->formal; f; f = f->next)
3330     {
3331       if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
3332         {
3333           gcc_assert (f->sym->ts.u.cl->backend_decl != NULL);
3334           if (TREE_CODE (f->sym->ts.u.cl->backend_decl) == PARM_DECL)
3335             gfc_trans_vla_type_sizes (f->sym, &body);
3336         }
3337     }
3338
3339   if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
3340       && current_fake_result_decl != NULL)
3341     {
3342       gcc_assert (proc_sym->ts.u.cl->backend_decl != NULL);
3343       if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == PARM_DECL)
3344         gfc_trans_vla_type_sizes (proc_sym, &body);
3345     }
3346
3347   gfc_add_expr_to_block (&body, fnbody);
3348   return gfc_finish_block (&body);
3349 }
3350
3351 static GTY ((param_is (struct module_htab_entry))) htab_t module_htab;
3352
3353 /* Hash and equality functions for module_htab.  */
3354
3355 static hashval_t
3356 module_htab_do_hash (const void *x)
3357 {
3358   return htab_hash_string (((const struct module_htab_entry *)x)->name);
3359 }
3360
3361 static int
3362 module_htab_eq (const void *x1, const void *x2)
3363 {
3364   return strcmp ((((const struct module_htab_entry *)x1)->name),
3365                  (const char *)x2) == 0;
3366 }
3367
3368 /* Hash and equality functions for module_htab's decls.  */
3369
3370 static hashval_t
3371 module_htab_decls_hash (const void *x)
3372 {
3373   const_tree t = (const_tree) x;
3374   const_tree n = DECL_NAME (t);
3375   if (n == NULL_TREE)
3376     n = TYPE_NAME (TREE_TYPE (t));
3377   return htab_hash_string (IDENTIFIER_POINTER (n));
3378 }
3379
3380 static int
3381 module_htab_decls_eq (const void *x1, const void *x2)
3382 {
3383   const_tree t1 = (const_tree) x1;
3384   const_tree n1 = DECL_NAME (t1);
3385   if (n1 == NULL_TREE)
3386     n1 = TYPE_NAME (TREE_TYPE (t1));
3387   return strcmp (IDENTIFIER_POINTER (n1), (const char *) x2) == 0;
3388 }
3389
3390 struct module_htab_entry *
3391 gfc_find_module (const char *name)
3392 {
3393   void **slot;
3394
3395   if (! module_htab)
3396     module_htab = htab_create_ggc (10, module_htab_do_hash,
3397                                    module_htab_eq, NULL);
3398
3399   slot = htab_find_slot_with_hash (module_htab, name,
3400                                    htab_hash_string (name), INSERT);
3401   if (*slot == NULL)
3402     {
3403       struct module_htab_entry *entry = GGC_CNEW (struct module_htab_entry);
3404
3405       entry->name = gfc_get_string (name);
3406       entry->decls = htab_create_ggc (10, module_htab_decls_hash,
3407                                       module_htab_decls_eq, NULL);
3408       *slot = (void *) entry;
3409     }
3410   return (struct module_htab_entry *) *slot;
3411 }
3412
3413 void
3414 gfc_module_add_decl (struct module_htab_entry *entry, tree decl)
3415 {
3416   void **slot;
3417   const char *name;
3418
3419   if (DECL_NAME (decl))
3420     name = IDENTIFIER_POINTER (DECL_NAME (decl));
3421   else
3422     {
3423       gcc_assert (TREE_CODE (decl) == TYPE_DECL);
3424       name = IDENTIFIER_POINTER (TYPE_NAME (TREE_TYPE (decl)));
3425     }
3426   slot = htab_find_slot_with_hash (entry->decls, name,
3427                                    htab_hash_string (name), INSERT);
3428   if (*slot == NULL)
3429     *slot = (void *) decl;
3430 }
3431
3432 static struct module_htab_entry *cur_module;
3433
3434 /* Output an initialized decl for a module variable.  */
3435
3436 static void
3437 gfc_create_module_variable (gfc_symbol * sym)
3438 {
3439   tree decl;
3440
3441   /* Module functions with alternate entries are dealt with later and
3442      would get caught by the next condition.  */
3443   if (sym->attr.entry)
3444     return;
3445
3446   /* Make sure we convert the types of the derived types from iso_c_binding
3447      into (void *).  */
3448   if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
3449       && sym->ts.type == BT_DERIVED)
3450     sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
3451
3452   if (sym->attr.flavor == FL_DERIVED
3453       && sym->backend_decl
3454       && TREE_CODE (sym->backend_decl) == RECORD_TYPE)
3455     {
3456       decl = sym->backend_decl;
3457       gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3458
3459       /* -fwhole-file mixes up the contexts so these asserts are unnecessary.  */
3460       if (!(gfc_option.flag_whole_file && sym->attr.use_assoc))
3461         {
3462           gcc_assert (TYPE_CONTEXT (decl) == NULL_TREE
3463                       || TYPE_CONTEXT (decl) == sym->ns->proc_name->backend_decl);
3464           gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl)) == NULL_TREE
3465                       || DECL_CONTEXT (TYPE_STUB_DECL (decl))
3466                            == sym->ns->proc_name->backend_decl);
3467         }
3468       TYPE_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3469       DECL_CONTEXT (TYPE_STUB_DECL (decl)) = sym->ns->proc_name->backend_decl;
3470       gfc_module_add_decl (cur_module, TYPE_STUB_DECL (decl));
3471     }
3472
3473   /* Only output variables, procedure pointers and array valued,
3474      or derived type, parameters.  */
3475   if (sym->attr.flavor != FL_VARIABLE
3476         && !(sym->attr.flavor == FL_PARAMETER
3477                && (sym->attr.dimension || sym->ts.type == BT_DERIVED))
3478         && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer))
3479     return;
3480
3481   if ((sym->attr.in_common || sym->attr.in_equivalence) && sym->backend_decl)
3482     {
3483       decl = sym->backend_decl;
3484       gcc_assert (DECL_CONTEXT (decl) == NULL_TREE);
3485       gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3486       DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3487       gfc_module_add_decl (cur_module, decl);
3488     }
3489
3490   /* Don't generate variables from other modules. Variables from
3491      COMMONs will already have been generated.  */
3492   if (sym->attr.use_assoc || sym->attr.in_common)
3493     return;
3494
3495   /* Equivalenced variables arrive here after creation.  */
3496   if (sym->backend_decl
3497       && (sym->equiv_built || sym->attr.in_equivalence))
3498     return;
3499
3500   if (sym->backend_decl && !sym->attr.vtab)
3501     internal_error ("backend decl for module variable %s already exists",
3502                     sym->name);
3503
3504   /* We always want module variables to be created.  */
3505   sym->attr.referenced = 1;
3506   /* Create the decl.  */
3507   decl = gfc_get_symbol_decl (sym);
3508
3509   /* Create the variable.  */
3510   pushdecl (decl);
3511   gcc_assert (DECL_CONTEXT (decl) == NULL_TREE);
3512   gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3513   DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3514   rest_of_decl_compilation (decl, 1, 0);
3515   gfc_module_add_decl (cur_module, decl);
3516
3517   /* Also add length of strings.  */
3518   if (sym->ts.type == BT_CHARACTER)
3519     {
3520       tree length;
3521
3522       length = sym->ts.u.cl->backend_decl;
3523       gcc_assert (length || sym->attr.proc_pointer);
3524       if (length && !INTEGER_CST_P (length))
3525         {
3526           pushdecl (length);
3527           rest_of_decl_compilation (length, 1, 0);
3528         }
3529     }
3530 }
3531
3532 /* Emit debug information for USE statements.  */
3533
3534 static void
3535 gfc_trans_use_stmts (gfc_namespace * ns)
3536 {
3537   gfc_use_list *use_stmt;
3538   for (use_stmt = ns->use_stmts; use_stmt; use_stmt = use_stmt->next)
3539     {
3540       struct module_htab_entry *entry
3541         = gfc_find_module (use_stmt->module_name);
3542       gfc_use_rename *rent;
3543
3544       if (entry->namespace_decl == NULL)
3545         {
3546           entry->namespace_decl
3547             = build_decl (input_location,
3548                           NAMESPACE_DECL,
3549                           get_identifier (use_stmt->module_name),
3550                           void_type_node);
3551           DECL_EXTERNAL (entry->namespace_decl) = 1;
3552         }
3553       gfc_set_backend_locus (&use_stmt->where);
3554       if (!use_stmt->only_flag)
3555         (*debug_hooks->imported_module_or_decl) (entry->namespace_decl,
3556                                                  NULL_TREE,
3557                                                  ns->proc_name->backend_decl,
3558                                                  false);
3559       for (rent = use_stmt->rename; rent; rent = rent->next)
3560         {
3561           tree decl, local_name;
3562           void **slot;
3563
3564           if (rent->op != INTRINSIC_NONE)
3565             continue;
3566
3567           slot = htab_find_slot_with_hash (entry->decls, rent->use_name,
3568                                            htab_hash_string (rent->use_name),
3569                                            INSERT);
3570           if (*slot == NULL)
3571             {
3572               gfc_symtree *st;
3573
3574               st = gfc_find_symtree (ns->sym_root,
3575                                      rent->local_name[0]
3576                                      ? rent->local_name : rent->use_name);
3577               gcc_assert (st);
3578
3579               /* Sometimes, generic interfaces wind up being over-ruled by a
3580                  local symbol (see PR41062).  */
3581               if (!st->n.sym->attr.use_assoc)
3582                 continue;
3583
3584               if (st->n.sym->backend_decl
3585                   && DECL_P (st->n.sym->backend_decl)
3586                   && st->n.sym->module
3587                   && strcmp (st->n.sym->module, use_stmt->module_name) == 0)
3588                 {
3589                   gcc_assert (DECL_EXTERNAL (entry->namespace_decl)
3590                               || (TREE_CODE (st->n.sym->backend_decl)
3591                                   != VAR_DECL));
3592                   decl = copy_node (st->n.sym->backend_decl);
3593                   DECL_CONTEXT (decl) = entry->namespace_decl;
3594                   DECL_EXTERNAL (decl) = 1;
3595                   DECL_IGNORED_P (decl) = 0;
3596                   DECL_INITIAL (decl) = NULL_TREE;
3597                 }
3598               else
3599                 {
3600                   *slot = error_mark_node;
3601                   htab_clear_slot (entry->decls, slot);
3602                   continue;
3603                 }
3604               *slot = decl;
3605             }
3606           decl = (tree) *slot;
3607           if (rent->local_name[0])
3608             local_name = get_identifier (rent->local_name);
3609           else
3610             local_name = NULL_TREE;
3611           gfc_set_backend_locus (&rent->where);
3612           (*debug_hooks->imported_module_or_decl) (decl, local_name,
3613                                                    ns->proc_name->backend_decl,
3614                                                    !use_stmt->only_flag);
3615         }
3616     }
3617 }
3618
3619
3620 /* Return true if expr is a constant initializer that gfc_conv_initializer
3621    will handle.  */
3622
3623 static bool
3624 check_constant_initializer (gfc_expr *expr, gfc_typespec *ts, bool array,
3625                             bool pointer)
3626 {
3627   gfc_constructor *c;
3628   gfc_component *cm;
3629
3630   if (pointer)
3631     return true;
3632   else if (array)
3633     {
3634       if (expr->expr_type == EXPR_CONSTANT || expr->expr_type == EXPR_NULL)
3635         return true;
3636       else if (expr->expr_type == EXPR_STRUCTURE)
3637         return check_constant_initializer (expr, ts, false, false);
3638       else if (expr->expr_type != EXPR_ARRAY)
3639         return false;
3640       for (c = gfc_constructor_first (expr->value.constructor);
3641            c; c = gfc_constructor_next (c))
3642         {
3643           if (c->iterator)
3644             return false;
3645           if (c->expr->expr_type == EXPR_STRUCTURE)
3646             {
3647               if (!check_constant_initializer (c->expr, ts, false, false))
3648                 return false;
3649             }
3650           else if (c->expr->expr_type != EXPR_CONSTANT)
3651             return false;
3652         }
3653       return true;
3654     }
3655   else switch (ts->type)
3656     {
3657     case BT_DERIVED:
3658       if (expr->expr_type != EXPR_STRUCTURE)
3659         return false;
3660       cm = expr->ts.u.derived->components;
3661       for (c = gfc_constructor_first (expr->value.constructor);
3662            c; c = gfc_constructor_next (c), cm = cm->next)
3663         {
3664           if (!c->expr || cm->attr.allocatable)
3665             continue;
3666           if (!check_constant_initializer (c->expr, &cm->ts,
3667                                            cm->attr.dimension,
3668                                            cm->attr.pointer))
3669             return false;
3670         }
3671       return true;
3672     default:
3673       return expr->expr_type == EXPR_CONSTANT;
3674     }
3675 }
3676
3677 /* Emit debug info for parameters and unreferenced variables with
3678    initializers.  */
3679
3680 static void
3681 gfc_emit_parameter_debug_info (gfc_symbol *sym)
3682 {
3683   tree decl;
3684
3685   if (sym->attr.flavor != FL_PARAMETER
3686       && (sym->attr.flavor != FL_VARIABLE || sym->attr.referenced))
3687     return;
3688
3689   if (sym->backend_decl != NULL
3690       || sym->value == NULL
3691       || sym->attr.use_assoc
3692       || sym->attr.dummy
3693       || sym->attr.result
3694       || sym->attr.function
3695       || sym->attr.intrinsic
3696       || sym->attr.pointer
3697       || sym->attr.allocatable
3698       || sym->attr.cray_pointee
3699       || sym->attr.threadprivate
3700       || sym->attr.is_bind_c
3701       || sym->attr.subref_array_pointer
3702       || sym->attr.assign)
3703     return;
3704
3705   if (sym->ts.type == BT_CHARACTER)
3706     {
3707       gfc_conv_const_charlen (sym->ts.u.cl);
3708       if (sym->ts.u.cl->backend_decl == NULL
3709           || TREE_CODE (sym->ts.u.cl->backend_decl) != INTEGER_CST)
3710         return;
3711     }
3712   else if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
3713     return;
3714
3715   if (sym->as)
3716     {
3717       int n;
3718
3719       if (sym->as->type != AS_EXPLICIT)
3720         return;
3721       for (n = 0; n < sym->as->rank; n++)
3722         if (sym->as->lower[n]->expr_type != EXPR_CONSTANT
3723             || sym->as->upper[n] == NULL
3724             || sym->as->upper[n]->expr_type != EXPR_CONSTANT)
3725           return;
3726     }
3727
3728   if (!check_constant_initializer (sym->value, &sym->ts,
3729                                    sym->attr.dimension, false))
3730     return;
3731
3732   /* Create the decl for the variable or constant.  */
3733   decl = build_decl (input_location,
3734                      sym->attr.flavor == FL_PARAMETER ? CONST_DECL : VAR_DECL,
3735                      gfc_sym_identifier (sym), gfc_sym_type (sym));
3736   if (sym->attr.flavor == FL_PARAMETER)
3737     TREE_READONLY (decl) = 1;
3738   gfc_set_decl_location (decl, &sym->declared_at);
3739   if (sym->attr.dimension)
3740     GFC_DECL_PACKED_ARRAY (decl) = 1;
3741   DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3742   TREE_STATIC (decl) = 1;
3743   TREE_USED (decl) = 1;
3744   if (DECL_CONTEXT (decl) && TREE_CODE (DECL_CONTEXT (decl)) == NAMESPACE_DECL)
3745     TREE_PUBLIC (decl) = 1;
3746   DECL_INITIAL (decl)
3747     = gfc_conv_initializer (sym->value, &sym->ts, TREE_TYPE (decl),
3748                             sym->attr.dimension, 0);
3749   debug_hooks->global_decl (decl);
3750 }
3751
3752 /* Generate all the required code for module variables.  */
3753
3754 void
3755 gfc_generate_module_vars (gfc_namespace * ns)
3756 {
3757   module_namespace = ns;
3758   cur_module = gfc_find_module (ns->proc_name->name);
3759
3760   /* Check if the frontend left the namespace in a reasonable state.  */
3761   gcc_assert (ns->proc_name && !ns->proc_name->tlink);
3762
3763   /* Generate COMMON blocks.  */
3764   gfc_trans_common (ns);
3765
3766   /* Create decls for all the module variables.  */
3767   gfc_traverse_ns (ns, gfc_create_module_variable);
3768
3769   cur_module = NULL;
3770
3771   gfc_trans_use_stmts (ns);
3772   gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
3773 }
3774
3775
3776 static void
3777 gfc_generate_contained_functions (gfc_namespace * parent)
3778 {
3779   gfc_namespace *ns;
3780
3781   /* We create all the prototypes before generating any code.  */
3782   for (ns = parent->contained; ns; ns = ns->sibling)
3783     {
3784       /* Skip namespaces from used modules.  */
3785       if (ns->parent != parent)
3786         continue;
3787
3788       gfc_create_function_decl (ns);
3789     }
3790
3791   for (ns = parent->contained; ns; ns = ns->sibling)
3792     {
3793       /* Skip namespaces from used modules.  */
3794       if (ns->parent != parent)
3795         continue;
3796
3797       gfc_generate_function_code (ns);
3798     }
3799 }
3800
3801
3802 /* Drill down through expressions for the array specification bounds and
3803    character length calling generate_local_decl for all those variables
3804    that have not already been declared.  */
3805
3806 static void
3807 generate_local_decl (gfc_symbol *);
3808
3809 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced.  */
3810
3811 static bool
3812 expr_decls (gfc_expr *e, gfc_symbol *sym,
3813             int *f ATTRIBUTE_UNUSED)
3814 {
3815   if (e->expr_type != EXPR_VARIABLE
3816             || sym == e->symtree->n.sym
3817             || e->symtree->n.sym->mark
3818             || e->symtree->n.sym->ns != sym->ns)
3819         return false;
3820
3821   generate_local_decl (e->symtree->n.sym);
3822   return false;
3823 }
3824
3825 static void
3826 generate_expr_decls (gfc_symbol *sym, gfc_expr *e)
3827 {
3828   gfc_traverse_expr (e, sym, expr_decls, 0);
3829 }
3830
3831
3832 /* Check for dependencies in the character length and array spec.  */
3833
3834 static void
3835 generate_dependency_declarations (gfc_symbol *sym)
3836 {
3837   int i;
3838
3839   if (sym->ts.type == BT_CHARACTER
3840       && sym->ts.u.cl
3841       && sym->ts.u.cl->length
3842       && sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
3843     generate_expr_decls (sym, sym->ts.u.cl->length);
3844
3845   if (sym->as && sym->as->rank)
3846     {
3847       for (i = 0; i < sym->as->rank; i++)
3848         {
3849           generate_expr_decls (sym, sym->as->lower[i]);
3850           generate_expr_decls (sym, sym->as->upper[i]);
3851         }
3852     }
3853 }
3854
3855
3856 /* Generate decls for all local variables.  We do this to ensure correct
3857    handling of expressions which only appear in the specification of
3858    other functions.  */
3859
3860 static void
3861 generate_local_decl (gfc_symbol * sym)
3862 {
3863   if (sym->attr.flavor == FL_VARIABLE)
3864     {
3865       if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
3866         generate_dependency_declarations (sym);
3867
3868       if (sym->attr.referenced)
3869         gfc_get_symbol_decl (sym);
3870       /* INTENT(out) dummy arguments are likely meant to be set.  */
3871       else if (warn_unused_variable
3872                && sym->attr.dummy
3873                && sym->attr.intent == INTENT_OUT)
3874         {
3875           if (!(sym->ts.type == BT_DERIVED
3876                 && sym->ts.u.derived->components->initializer))
3877             gfc_warning ("Dummy argument '%s' at %L was declared INTENT(OUT) "
3878                          "but was not set",  sym->name, &sym->declared_at);
3879         }
3880       /* Specific warning for unused dummy arguments. */
3881       else if (warn_unused_variable && sym->attr.dummy)
3882         gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
3883                      &sym->declared_at);
3884       /* Warn for unused variables, but not if they're inside a common
3885          block or are use-associated.  */
3886       else if (warn_unused_variable
3887                && !(sym->attr.in_common || sym->attr.use_assoc || sym->mark))
3888         gfc_warning ("Unused variable '%s' declared at %L", sym->name,
3889                      &sym->declared_at);
3890
3891       /* For variable length CHARACTER parameters, the PARM_DECL already
3892          references the length variable, so force gfc_get_symbol_decl
3893          even when not referenced.  If optimize > 0, it will be optimized
3894          away anyway.  But do this only after emitting -Wunused-parameter
3895          warning if requested.  */
3896       if (sym->attr.dummy && !sym->attr.referenced
3897             && sym->ts.type == BT_CHARACTER
3898             && sym->ts.u.cl->backend_decl != NULL
3899             && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
3900         {
3901           sym->attr.referenced = 1;
3902           gfc_get_symbol_decl (sym);
3903         }
3904
3905       /* INTENT(out) dummy arguments and result variables with allocatable
3906          components are reset by default and need to be set referenced to
3907          generate the code for nullification and automatic lengths.  */
3908       if (!sym->attr.referenced
3909             && sym->ts.type == BT_DERIVED
3910             && sym->ts.u.derived->attr.alloc_comp
3911             && !sym->attr.pointer
3912             && ((sym->attr.dummy && sym->attr.intent == INTENT_OUT)
3913                   ||
3914                 (sym->attr.result && sym != sym->result)))
3915         {
3916           sym->attr.referenced = 1;
3917           gfc_get_symbol_decl (sym);
3918         }
3919
3920       /* Check for dependencies in the array specification and string
3921         length, adding the necessary declarations to the function.  We
3922         mark the symbol now, as well as in traverse_ns, to prevent
3923         getting stuck in a circular dependency.  */
3924       sym->mark = 1;
3925
3926       /* We do not want the middle-end to warn about unused parameters
3927          as this was already done above.  */
3928       if (sym->attr.dummy && sym->backend_decl != NULL_TREE)
3929           TREE_NO_WARNING(sym->backend_decl) = 1;
3930     }
3931   else if (sym->attr.flavor == FL_PARAMETER)
3932     {
3933       if (warn_unused_parameter
3934            && !sym->attr.referenced
3935            && !sym->attr.use_assoc)
3936         gfc_warning ("Unused parameter '%s' declared at %L", sym->name,
3937                      &sym->declared_at);
3938     }
3939   else if (sym->attr.flavor == FL_PROCEDURE)
3940     {
3941       /* TODO: move to the appropriate place in resolve.c.  */
3942       if (warn_return_type
3943           && sym->attr.function
3944           && sym->result
3945           && sym != sym->result
3946           && !sym->result->attr.referenced
3947           && !sym->attr.use_assoc
3948           && sym->attr.if_source != IFSRC_IFBODY)
3949         {
3950           gfc_warning ("Return value '%s' of function '%s' declared at "
3951                        "%L not set", sym->result->name, sym->name,
3952                         &sym->result->declared_at);
3953
3954           /* Prevents "Unused variable" warning for RESULT variables.  */
3955           sym->result->mark = 1;
3956         }
3957     }
3958
3959   if (sym->attr.dummy == 1)
3960     {
3961       /* Modify the tree type for scalar character dummy arguments of bind(c)
3962          procedures if they are passed by value.  The tree type for them will
3963          be promoted to INTEGER_TYPE for the middle end, which appears to be
3964          what C would do with characters passed by-value.  The value attribute
3965          implies the dummy is a scalar.  */
3966       if (sym->attr.value == 1 && sym->backend_decl != NULL
3967           && sym->ts.type == BT_CHARACTER && sym->ts.is_c_interop
3968           && sym->ns->proc_name != NULL && sym->ns->proc_name->attr.is_bind_c)
3969         gfc_conv_scalar_char_value (sym, NULL, NULL);
3970     }
3971
3972   /* Make sure we convert the types of the derived types from iso_c_binding
3973      into (void *).  */
3974   if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
3975       && sym->ts.type == BT_DERIVED)
3976     sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
3977 }
3978
3979 static void
3980 generate_local_vars (gfc_namespace * ns)
3981 {
3982   gfc_traverse_ns (ns, generate_local_decl);
3983 }
3984
3985
3986 /* Generate a switch statement to jump to the correct entry point.  Also
3987    creates the label decls for the entry points.  */
3988
3989 static tree
3990 gfc_trans_entry_master_switch (gfc_entry_list * el)
3991 {
3992   stmtblock_t block;
3993   tree label;
3994   tree tmp;
3995   tree val;
3996
3997   gfc_init_block (&block);
3998   for (; el; el = el->next)
3999     {
4000       /* Add the case label.  */
4001       label = gfc_build_label_decl (NULL_TREE);
4002       val = build_int_cst (gfc_array_index_type, el->id);
4003       tmp = build3_v (CASE_LABEL_EXPR, val, NULL_TREE, label);
4004       gfc_add_expr_to_block (&block, tmp);
4005
4006       /* And jump to the actual entry point.  */
4007       label = gfc_build_label_decl (NULL_TREE);
4008       tmp = build1_v (GOTO_EXPR, label);
4009       gfc_add_expr_to_block (&block, tmp);
4010
4011       /* Save the label decl.  */
4012       el->label = label;
4013     }
4014   tmp = gfc_finish_block (&block);
4015   /* The first argument selects the entry point.  */
4016   val = DECL_ARGUMENTS (current_function_decl);
4017   tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);
4018   return tmp;
4019 }
4020
4021
4022 /* Add code to string lengths of actual arguments passed to a function against
4023    the expected lengths of the dummy arguments.  */
4024
4025 static void
4026 add_argument_checking (stmtblock_t *block, gfc_symbol *sym)
4027 {
4028   gfc_formal_arglist *formal;
4029
4030   for (formal = sym->formal; formal; formal = formal->next)
4031     if (formal->sym && formal->sym->ts.type == BT_CHARACTER)
4032       {
4033         enum tree_code comparison;
4034         tree cond;
4035         tree argname;
4036         gfc_symbol *fsym;
4037         gfc_charlen *cl;
4038         const char *message;
4039
4040         fsym = formal->sym;
4041         cl = fsym->ts.u.cl;
4042
4043         gcc_assert (cl);
4044         gcc_assert (cl->passed_length != NULL_TREE);
4045         gcc_assert (cl->backend_decl != NULL_TREE);
4046
4047         /* For POINTER, ALLOCATABLE and assumed-shape dummy arguments, the
4048            string lengths must match exactly.  Otherwise, it is only required
4049            that the actual string length is *at least* the expected one.
4050            Sequence association allows for a mismatch of the string length
4051            if the actual argument is (part of) an array, but only if the
4052            dummy argument is an array. (See "Sequence association" in
4053            Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.)  */
4054         if (fsym->attr.pointer || fsym->attr.allocatable
4055             || (fsym->as && fsym->as->type == AS_ASSUMED_SHAPE))
4056           {
4057             comparison = NE_EXPR;
4058             message = _("Actual string length does not match the declared one"
4059                         " for dummy argument '%s' (%ld/%ld)");
4060           }
4061         else if (fsym->as && fsym->as->rank != 0)
4062           continue;
4063         else
4064           {
4065             comparison = LT_EXPR;
4066             message = _("Actual string length is shorter than the declared one"
4067                         " for dummy argument '%s' (%ld/%ld)");
4068           }
4069
4070         /* Build the condition.  For optional arguments, an actual length
4071            of 0 is also acceptable if the associated string is NULL, which
4072            means the argument was not passed.  */
4073         cond = fold_build2 (comparison, boolean_type_node,
4074                             cl->passed_length, cl->backend_decl);
4075         if (fsym->attr.optional)
4076           {
4077             tree not_absent;
4078             tree not_0length;
4079             tree absent_failed;
4080
4081             not_0length = fold_build2 (NE_EXPR, boolean_type_node,
4082                                        cl->passed_length,
4083                                        fold_convert (gfc_charlen_type_node,
4084                                                      integer_zero_node));
4085             /* The symbol needs to be referenced for gfc_get_symbol_decl.  */
4086             fsym->attr.referenced = 1;
4087             not_absent = gfc_conv_expr_present (fsym);
4088
4089             absent_failed = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
4090                                          not_0length, not_absent);
4091
4092             cond = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
4093                                 cond, absent_failed);
4094           }
4095
4096         /* Build the runtime check.  */
4097         argname = gfc_build_cstring_const (fsym->name);
4098         argname = gfc_build_addr_expr (pchar_type_node, argname);
4099         gfc_trans_runtime_check (true, false, cond, block, &fsym->declared_at,
4100                                  message, argname,
4101                                  fold_convert (long_integer_type_node,
4102                                                cl->passed_length),
4103                                  fold_convert (long_integer_type_node,
4104                                                cl->backend_decl));
4105       }
4106 }
4107
4108
4109 static void
4110 create_main_function (tree fndecl)
4111 {
4112   tree old_context;
4113   tree ftn_main;
4114   tree tmp, decl, result_decl, argc, argv, typelist, arglist;
4115   stmtblock_t body;
4116
4117   old_context = current_function_decl;
4118
4119   if (old_context)
4120     {
4121       push_function_context ();
4122       saved_parent_function_decls = saved_function_decls;
4123       saved_function_decls = NULL_TREE;
4124     }
4125
4126   /* main() function must be declared with global scope.  */
4127   gcc_assert (current_function_decl == NULL_TREE);
4128
4129   /* Declare the function.  */
4130   tmp =  build_function_type_list (integer_type_node, integer_type_node,
4131                                    build_pointer_type (pchar_type_node),
4132                                    NULL_TREE);
4133   main_identifier_node = get_identifier ("main");
4134   ftn_main = build_decl (input_location, FUNCTION_DECL,
4135                          main_identifier_node, tmp);
4136   DECL_EXTERNAL (ftn_main) = 0;
4137   TREE_PUBLIC (ftn_main) = 1;
4138   TREE_STATIC (ftn_main) = 1;
4139   DECL_ATTRIBUTES (ftn_main)
4140       = tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE);
4141
4142   /* Setup the result declaration (for "return 0").  */
4143   result_decl = build_decl (input_location,
4144                             RESULT_DECL, NULL_TREE, integer_type_node);
4145   DECL_ARTIFICIAL (result_decl) = 1;
4146   DECL_IGNORED_P (result_decl) = 1;
4147   DECL_CONTEXT (result_decl) = ftn_main;
4148   DECL_RESULT (ftn_main) = result_decl;
4149
4150   pushdecl (ftn_main);
4151
4152   /* Get the arguments.  */
4153
4154   arglist = NULL_TREE;
4155   typelist = TYPE_ARG_TYPES (TREE_TYPE (ftn_main));
4156
4157   tmp = TREE_VALUE (typelist);
4158   argc = build_decl (input_location, PARM_DECL, get_identifier ("argc"), tmp);
4159   DECL_CONTEXT (argc) = ftn_main;
4160   DECL_ARG_TYPE (argc) = TREE_VALUE (typelist);
4161   TREE_READONLY (argc) = 1;
4162   gfc_finish_decl (argc);
4163   arglist = chainon (arglist, argc);
4164
4165   typelist = TREE_CHAIN (typelist);
4166   tmp = TREE_VALUE (typelist);
4167   argv = build_decl (input_location, PARM_DECL, get_identifier ("argv"), tmp);
4168   DECL_CONTEXT (argv) = ftn_main;
4169   DECL_ARG_TYPE (argv) = TREE_VALUE (typelist);
4170   TREE_READONLY (argv) = 1;
4171   DECL_BY_REFERENCE (argv) = 1;
4172   gfc_finish_decl (argv);
4173   arglist = chainon (arglist, argv);
4174
4175   DECL_ARGUMENTS (ftn_main) = arglist;
4176   current_function_decl = ftn_main;
4177   announce_function (ftn_main);
4178
4179   rest_of_decl_compilation (ftn_main, 1, 0);
4180   make_decl_rtl (ftn_main);
4181   init_function_start (ftn_main);
4182   pushlevel (0);
4183
4184   gfc_init_block (&body);
4185
4186   /* Call some libgfortran initialization routines, call then MAIN__(). */
4187
4188   /* Call _gfortran_set_args (argc, argv).  */
4189   TREE_USED (argc) = 1;
4190   TREE_USED (argv) = 1;
4191   tmp = build_call_expr_loc (input_location,
4192                          gfor_fndecl_set_args, 2, argc, argv);
4193   gfc_add_expr_to_block (&body, tmp);
4194
4195   /* Add a call to set_options to set up the runtime library Fortran
4196      language standard parameters.  */
4197   {
4198     tree array_type, array, var;
4199     VEC(constructor_elt,gc) *v = NULL;
4200
4201     /* Passing a new option to the library requires four modifications:
4202      + add it to the tree_cons list below
4203           + change the array size in the call to build_array_type
4204           + change the first argument to the library call
4205             gfor_fndecl_set_options
4206           + modify the library (runtime/compile_options.c)!  */
4207
4208     CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4209                             build_int_cst (integer_type_node,
4210                                            gfc_option.warn_std));
4211     CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4212                             build_int_cst (integer_type_node,
4213                                            gfc_option.allow_std));
4214     CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4215                             build_int_cst (integer_type_node, pedantic));
4216     CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4217                             build_int_cst (integer_type_node,
4218                                            gfc_option.flag_dump_core));
4219     CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4220                             build_int_cst (integer_type_node,
4221                                            gfc_option.flag_backtrace));
4222     CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4223                             build_int_cst (integer_type_node,
4224                                            gfc_option.flag_sign_zero));
4225     CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4226                             build_int_cst (integer_type_node,
4227                                            (gfc_option.rtcheck
4228                                             & GFC_RTCHECK_BOUNDS)));
4229     CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4230                             build_int_cst (integer_type_node,
4231                                            gfc_option.flag_range_check));
4232
4233     array_type = build_array_type (integer_type_node,
4234                        build_index_type (build_int_cst (NULL_TREE, 7)));
4235     array = build_constructor (array_type, v);
4236     TREE_CONSTANT (array) = 1;
4237     TREE_STATIC (array) = 1;
4238
4239     /* Create a static variable to hold the jump table.  */
4240     var = gfc_create_var (array_type, "options");
4241     TREE_CONSTANT (var) = 1;
4242     TREE_STATIC (var) = 1;
4243     TREE_READONLY (var) = 1;
4244     DECL_INITIAL (var) = array;
4245     var = gfc_build_addr_expr (build_pointer_type (integer_type_node), var);
4246
4247     tmp = build_call_expr_loc (input_location,
4248                            gfor_fndecl_set_options, 2,
4249                            build_int_cst (integer_type_node, 8), var);
4250     gfc_add_expr_to_block (&body, tmp);
4251   }
4252
4253   /* If -ffpe-trap option was provided, add a call to set_fpe so that
4254      the library will raise a FPE when needed.  */
4255   if (gfc_option.fpe != 0)
4256     {
4257       tmp = build_call_expr_loc (input_location,
4258                              gfor_fndecl_set_fpe, 1,
4259                              build_int_cst (integer_type_node,
4260                                             gfc_option.fpe));
4261       gfc_add_expr_to_block (&body, tmp);
4262     }
4263
4264   /* If this is the main program and an -fconvert option was provided,
4265      add a call to set_convert.  */
4266
4267   if (gfc_option.convert != GFC_CONVERT_NATIVE)
4268     {
4269       tmp = build_call_expr_loc (input_location,
4270                              gfor_fndecl_set_convert, 1,
4271                              build_int_cst (integer_type_node,
4272                                             gfc_option.convert));
4273       gfc_add_expr_to_block (&body, tmp);
4274     }
4275
4276   /* If this is the main program and an -frecord-marker option was provided,
4277      add a call to set_record_marker.  */
4278
4279   if (gfc_option.record_marker != 0)
4280     {
4281       tmp = build_call_expr_loc (input_location,
4282                              gfor_fndecl_set_record_marker, 1,
4283                              build_int_cst (integer_type_node,
4284                                             gfc_option.record_marker));
4285       gfc_add_expr_to_block (&body, tmp);
4286     }
4287
4288   if (gfc_option.max_subrecord_length != 0)
4289     {
4290       tmp = build_call_expr_loc (input_location,
4291                              gfor_fndecl_set_max_subrecord_length, 1,
4292                              build_int_cst (integer_type_node,
4293                                             gfc_option.max_subrecord_length));
4294       gfc_add_expr_to_block (&body, tmp);
4295     }
4296
4297   /* Call MAIN__().  */
4298   tmp = build_call_expr_loc (input_location,
4299                          fndecl, 0);
4300   gfc_add_expr_to_block (&body, tmp);
4301
4302   /* Mark MAIN__ as used.  */
4303   TREE_USED (fndecl) = 1;
4304
4305   /* "return 0".  */
4306   tmp = fold_build2 (MODIFY_EXPR, integer_type_node, DECL_RESULT (ftn_main),
4307                      build_int_cst (integer_type_node, 0));
4308   tmp = build1_v (RETURN_EXPR, tmp);
4309   gfc_add_expr_to_block (&body, tmp);
4310
4311
4312   DECL_SAVED_TREE (ftn_main) = gfc_finish_block (&body);
4313   decl = getdecls ();
4314
4315   /* Finish off this function and send it for code generation.  */
4316   poplevel (1, 0, 1);
4317   BLOCK_SUPERCONTEXT (DECL_INITIAL (ftn_main)) = ftn_main;
4318
4319   DECL_SAVED_TREE (ftn_main)
4320     = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (ftn_main),
4321                 DECL_INITIAL (ftn_main));
4322
4323   /* Output the GENERIC tree.  */
4324   dump_function (TDI_original, ftn_main);
4325
4326   cgraph_finalize_function (ftn_main, true);
4327
4328   if (old_context)
4329     {
4330       pop_function_context ();
4331       saved_function_decls = saved_parent_function_decls;
4332     }
4333   current_function_decl = old_context;
4334 }
4335
4336
4337 /* Generate code for a function.  */
4338
4339 void
4340 gfc_generate_function_code (gfc_namespace * ns)
4341 {
4342   tree fndecl;
4343   tree old_context;
4344   tree decl;
4345   tree tmp;
4346   tree tmp2;
4347   stmtblock_t block;
4348   stmtblock_t body;
4349   tree result;
4350   tree recurcheckvar = NULL_TREE;
4351   gfc_symbol *sym;
4352   int rank;
4353   bool is_recursive;
4354
4355   sym = ns->proc_name;
4356
4357   /* Check that the frontend isn't still using this.  */
4358   gcc_assert (sym->tlink == NULL);
4359   sym->tlink = sym;
4360
4361   /* Create the declaration for functions with global scope.  */
4362   if (!sym->backend_decl)
4363     gfc_create_function_decl (ns);
4364
4365   fndecl = sym->backend_decl;
4366   old_context = current_function_decl;
4367
4368   if (old_context)
4369     {
4370       push_function_context ();
4371       saved_parent_function_decls = saved_function_decls;
4372       saved_function_decls = NULL_TREE;
4373     }
4374
4375   trans_function_start (sym);
4376
4377   gfc_init_block (&block);
4378
4379   if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
4380     {
4381       /* Copy length backend_decls to all entry point result
4382          symbols.  */
4383       gfc_entry_list *el;
4384       tree backend_decl;
4385
4386       gfc_conv_const_charlen (ns->proc_name->ts.u.cl);
4387       backend_decl = ns->proc_name->result->ts.u.cl->backend_decl;
4388       for (el = ns->entries; el; el = el->next)
4389         el->sym->result->ts.u.cl->backend_decl = backend_decl;
4390     }
4391
4392   /* Translate COMMON blocks.  */
4393   gfc_trans_common (ns);
4394
4395   /* Null the parent fake result declaration if this namespace is
4396      a module function or an external procedures.  */
4397   if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
4398         || ns->parent == NULL)
4399     parent_fake_result_decl = NULL_TREE;
4400
4401   gfc_generate_contained_functions (ns);
4402
4403   nonlocal_dummy_decls = NULL;
4404   nonlocal_dummy_decl_pset = NULL;
4405
4406   generate_local_vars (ns);
4407
4408   /* Keep the parent fake result declaration in module functions
4409      or external procedures.  */
4410   if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
4411         || ns->parent == NULL)
4412     current_fake_result_decl = parent_fake_result_decl;
4413   else
4414     current_fake_result_decl = NULL_TREE;
4415
4416   current_function_return_label = NULL;
4417
4418   /* Now generate the code for the body of this function.  */
4419   gfc_init_block (&body);
4420
4421    is_recursive = sym->attr.recursive
4422                   || (sym->attr.entry_master
4423                       && sym->ns->entries->sym->attr.recursive);
4424    if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
4425           && !is_recursive
4426           && !gfc_option.flag_recursive)
4427      {
4428        char * msg;
4429
4430        asprintf (&msg, "Recursive call to nonrecursive procedure '%s'",
4431                  sym->name);
4432        recurcheckvar = gfc_create_var (boolean_type_node, "is_recursive");
4433        TREE_STATIC (recurcheckvar) = 1;
4434        DECL_INITIAL (recurcheckvar) = boolean_false_node;
4435        gfc_add_expr_to_block (&block, recurcheckvar);
4436        gfc_trans_runtime_check (true, false, recurcheckvar, &block,
4437                                 &sym->declared_at, msg);
4438        gfc_add_modify (&block, recurcheckvar, boolean_true_node);
4439        gfc_free (msg);
4440     }
4441
4442   if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
4443         && sym->attr.subroutine)
4444     {
4445       tree alternate_return;
4446       alternate_return = gfc_get_fake_result_decl (sym, 0);
4447       gfc_add_modify (&body, alternate_return, integer_zero_node);
4448     }
4449
4450   if (ns->entries)
4451     {
4452       /* Jump to the correct entry point.  */
4453       tmp = gfc_trans_entry_master_switch (ns->entries);
4454       gfc_add_expr_to_block (&body, tmp);
4455     }
4456
4457   /* If bounds-checking is enabled, generate code to check passed in actual
4458      arguments against the expected dummy argument attributes (e.g. string
4459      lengths).  */
4460   if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !sym->attr.is_bind_c)
4461     add_argument_checking (&body, sym);
4462
4463   tmp = gfc_trans_code (ns->code);
4464   gfc_add_expr_to_block (&body, tmp);
4465
4466   /* Add a return label if needed.  */
4467   if (current_function_return_label)
4468     {
4469       tmp = build1_v (LABEL_EXPR, current_function_return_label);
4470       gfc_add_expr_to_block (&body, tmp);
4471     }
4472
4473   tmp = gfc_finish_block (&body);
4474   /* Add code to create and cleanup arrays.  */
4475   tmp = gfc_trans_deferred_vars (sym, tmp);
4476
4477   if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
4478     {
4479       if (sym->attr.subroutine || sym == sym->result)
4480         {
4481           if (current_fake_result_decl != NULL)
4482             result = TREE_VALUE (current_fake_result_decl);
4483           else
4484             result = NULL_TREE;
4485           current_fake_result_decl = NULL_TREE;
4486         }
4487       else
4488         result = sym->result->backend_decl;
4489
4490       if (result != NULL_TREE
4491             && sym->attr.function
4492             && !sym->attr.pointer)
4493         {
4494           if (sym->ts.type == BT_DERIVED
4495               && sym->ts.u.derived->attr.alloc_comp)
4496             {
4497               rank = sym->as ? sym->as->rank : 0;
4498               tmp2 = gfc_nullify_alloc_comp (sym->ts.u.derived, result, rank);
4499               gfc_add_expr_to_block (&block, tmp2);
4500             }
4501           else if (sym->attr.allocatable && sym->attr.dimension == 0)
4502             gfc_add_modify (&block, result, fold_convert (TREE_TYPE (result),
4503                                                           null_pointer_node));
4504         }
4505
4506       gfc_add_expr_to_block (&block, tmp);
4507
4508       /* Reset recursion-check variable.  */
4509       if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
4510              && !is_recursive
4511              && !gfc_option.flag_openmp
4512              && recurcheckvar != NULL_TREE)
4513         {
4514           gfc_add_modify (&block, recurcheckvar, boolean_false_node);
4515           recurcheckvar = NULL;
4516         }
4517
4518       if (result == NULL_TREE)
4519         {
4520           /* TODO: move to the appropriate place in resolve.c.  */
4521           if (warn_return_type && !sym->attr.referenced && sym == sym->result)
4522             gfc_warning ("Return value of function '%s' at %L not set",
4523                          sym->name, &sym->declared_at);
4524
4525           TREE_NO_WARNING(sym->backend_decl) = 1;
4526         }
4527       else
4528         {
4529           /* Set the return value to the dummy result variable.  The
4530              types may be different for scalar default REAL functions
4531              with -ff2c, therefore we have to convert.  */
4532           tmp = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
4533           tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (tmp),
4534                              DECL_RESULT (fndecl), tmp);
4535           tmp = build1_v (RETURN_EXPR, tmp);
4536           gfc_add_expr_to_block (&block, tmp);
4537         }
4538     }
4539   else
4540     {
4541       gfc_add_expr_to_block (&block, tmp);
4542       /* Reset recursion-check variable.  */
4543       if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
4544              && !is_recursive
4545              && !gfc_option.flag_openmp
4546              && recurcheckvar != NULL_TREE)
4547         {
4548           gfc_add_modify (&block, recurcheckvar, boolean_false_node);
4549           recurcheckvar = NULL_TREE;
4550         }
4551     }
4552
4553
4554   /* Add all the decls we created during processing.  */
4555   decl = saved_function_decls;
4556   while (decl)
4557     {
4558       tree next;
4559
4560       next = TREE_CHAIN (decl);
4561       TREE_CHAIN (decl) = NULL_TREE;
4562       pushdecl (decl);
4563       decl = next;
4564     }
4565   saved_function_decls = NULL_TREE;
4566
4567   DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);
4568   decl = getdecls ();
4569
4570   /* Finish off this function and send it for code generation.  */
4571   poplevel (1, 0, 1);
4572   BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
4573
4574   DECL_SAVED_TREE (fndecl)
4575     = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
4576                 DECL_INITIAL (fndecl));
4577
4578   if (nonlocal_dummy_decls)
4579     {
4580       BLOCK_VARS (DECL_INITIAL (fndecl))
4581         = chainon (BLOCK_VARS (DECL_INITIAL (fndecl)), nonlocal_dummy_decls);
4582       pointer_set_destroy (nonlocal_dummy_decl_pset);
4583       nonlocal_dummy_decls = NULL;
4584       nonlocal_dummy_decl_pset = NULL;
4585     }
4586
4587   /* Output the GENERIC tree.  */
4588   dump_function (TDI_original, fndecl);
4589
4590   /* Store the end of the function, so that we get good line number
4591      info for the epilogue.  */
4592   cfun->function_end_locus = input_location;
4593
4594   /* We're leaving the context of this function, so zap cfun.
4595      It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
4596      tree_rest_of_compilation.  */
4597   set_cfun (NULL);
4598
4599   if (old_context)
4600     {
4601       pop_function_context ();
4602       saved_function_decls = saved_parent_function_decls;
4603     }
4604   current_function_decl = old_context;
4605
4606   if (decl_function_context (fndecl))
4607     /* Register this function with cgraph just far enough to get it
4608        added to our parent's nested function list.  */
4609     (void) cgraph_node (fndecl);
4610   else
4611     cgraph_finalize_function (fndecl, true);
4612
4613   gfc_trans_use_stmts (ns);
4614   gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
4615
4616   if (sym->attr.is_main_program)
4617     create_main_function (fndecl);
4618 }
4619
4620
4621 void
4622 gfc_generate_constructors (void)
4623 {
4624   gcc_assert (gfc_static_ctors == NULL_TREE);
4625 #if 0
4626   tree fnname;
4627   tree type;
4628   tree fndecl;
4629   tree decl;
4630   tree tmp;
4631
4632   if (gfc_static_ctors == NULL_TREE)
4633     return;
4634
4635   fnname = get_file_function_name ("I");
4636   type = build_function_type_list (void_type_node, NULL_TREE);
4637
4638   fndecl = build_decl (input_location,
4639                        FUNCTION_DECL, fnname, type);
4640   TREE_PUBLIC (fndecl) = 1;
4641
4642   decl = build_decl (input_location,
4643                      RESULT_DECL, NULL_TREE, void_type_node);
4644   DECL_ARTIFICIAL (decl) = 1;
4645   DECL_IGNORED_P (decl) = 1;
4646   DECL_CONTEXT (decl) = fndecl;
4647   DECL_RESULT (fndecl) = decl;
4648
4649   pushdecl (fndecl);
4650
4651   current_function_decl = fndecl;
4652
4653   rest_of_decl_compilation (fndecl, 1, 0);
4654
4655   make_decl_rtl (fndecl);
4656
4657   init_function_start (fndecl);
4658
4659   pushlevel (0);
4660
4661   for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
4662     {
4663       tmp = build_call_expr_loc (input_location,
4664                              TREE_VALUE (gfc_static_ctors), 0);
4665       DECL_SAVED_TREE (fndecl) = build_stmt (input_location, EXPR_STMT, tmp);
4666     }
4667
4668   decl = getdecls ();
4669   poplevel (1, 0, 1);
4670
4671   BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
4672   DECL_SAVED_TREE (fndecl)
4673     = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
4674                 DECL_INITIAL (fndecl));
4675
4676   free_after_parsing (cfun);
4677   free_after_compilation (cfun);
4678
4679   tree_rest_of_compilation (fndecl);
4680
4681   current_function_decl = NULL_TREE;
4682 #endif
4683 }
4684
4685 /* Translates a BLOCK DATA program unit. This means emitting the
4686    commons contained therein plus their initializations. We also emit
4687    a globally visible symbol to make sure that each BLOCK DATA program
4688    unit remains unique.  */
4689
4690 void
4691 gfc_generate_block_data (gfc_namespace * ns)
4692 {
4693   tree decl;
4694   tree id;
4695
4696   /* Tell the backend the source location of the block data.  */
4697   if (ns->proc_name)
4698     gfc_set_backend_locus (&ns->proc_name->declared_at);
4699   else
4700     gfc_set_backend_locus (&gfc_current_locus);
4701
4702   /* Process the DATA statements.  */
4703   gfc_trans_common (ns);
4704
4705   /* Create a global symbol with the mane of the block data.  This is to
4706      generate linker errors if the same name is used twice.  It is never
4707      really used.  */
4708   if (ns->proc_name)
4709     id = gfc_sym_mangled_function_id (ns->proc_name);
4710   else
4711     id = get_identifier ("__BLOCK_DATA__");
4712
4713   decl = build_decl (input_location,
4714                      VAR_DECL, id, gfc_array_index_type);
4715   TREE_PUBLIC (decl) = 1;
4716   TREE_STATIC (decl) = 1;
4717   DECL_IGNORED_P (decl) = 1;
4718
4719   pushdecl (decl);
4720   rest_of_decl_compilation (decl, 1, 0);
4721 }
4722
4723
4724 /* Process the local variables of a BLOCK construct.  */
4725
4726 void
4727 gfc_process_block_locals (gfc_namespace* ns)
4728 {
4729   tree decl;
4730
4731   gcc_assert (saved_local_decls == NULL_TREE);
4732   generate_local_vars (ns);
4733
4734   decl = saved_local_decls;
4735   while (decl)
4736     {
4737       tree next;
4738
4739       next = TREE_CHAIN (decl);
4740       TREE_CHAIN (decl) = NULL_TREE;
4741       pushdecl (decl);
4742       decl = next;
4743     }
4744   saved_local_decls = NULL_TREE;
4745 }
4746
4747
4748 #include "gt-fortran-trans-decl.h"