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.  */
 782           if (GFC_TYPE_ARRAY_LBOUND (type, dim)
 783               && TREE_CODE (GFC_TYPE_ARRAY_LBOUND (type, dim)) == VAR_DECL)
 784             DECL_IGNORED_P (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 0;
 785           if (GFC_TYPE_ARRAY_UBOUND (type, dim)
 786               && TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type, dim)) == VAR_DECL)
 787             DECL_IGNORED_P (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 0;
 788         }
 789       TYPE_NAME (type) = type_decl = build_decl (input_location,
 790                                                  TYPE_DECL, NULL, gtype);
 791       DECL_ORIGINAL_TYPE (type_decl) = gtype;
 792     }
 793 }
 794
 795
 796 /* For some dummy arguments we don't use the actual argument directly.
 797    Instead we create a local decl and use that.  This allows us to perform
 798    initialization, and construct full type information.  */
 799
 800 static tree
 801 gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
 802 {
 803   tree decl;
 804   tree type;
 805   gfc_array_spec *as;
 806   char *name;
 807   gfc_packed packed;
 808   int n;
 809   bool known_size;
 810
 811   if (sym->attr.pointer || sym->attr.allocatable)
 812     return dummy;
 813
 814   /* Add to list of variables if not a fake result variable.  */
 815   if (sym->attr.result || sym->attr.dummy)
 816     gfc_defer_symbol_init (sym);
 817
 818   type = TREE_TYPE (dummy);
 819   gcc_assert (TREE_CODE (dummy) == PARM_DECL
 820           && POINTER_TYPE_P (type));
 821
 822   /* Do we know the element size?  */
 823   known_size = sym->ts.type != BT_CHARACTER
 824           || INTEGER_CST_P (sym->ts.u.cl->backend_decl);
 825
 826   if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
 827     {
 828       /* For descriptorless arrays with known element size the actual
 829          argument is sufficient.  */
 830       gcc_assert (GFC_ARRAY_TYPE_P (type));
 831       gfc_build_qualified_array (dummy, sym);
 832       return dummy;
 833     }
 834
 835   type = TREE_TYPE (type);
 836   if (GFC_DESCRIPTOR_TYPE_P (type))
 837     {
 838       /* Create a descriptorless array pointer.  */
 839       as = sym->as;
 840       packed = PACKED_NO;
 841
 842       /* Even when -frepack-arrays is used, symbols with TARGET attribute
 843          are not repacked.  */
 844       if (!gfc_option.flag_repack_arrays || sym->attr.target)
 845         {
 846           if (as->type == AS_ASSUMED_SIZE)
 847             packed = PACKED_FULL;
 848         }
 849       else
 850         {
 851           if (as->type == AS_EXPLICIT)
 852             {
 853               packed = PACKED_FULL;
 854               for (n = 0; n < as->rank; n++)
 855                 {
 856                   if (!(as->upper[n]
 857                         && as->lower[n]
 858                         && as->upper[n]->expr_type == EXPR_CONSTANT
 859                         && as->lower[n]->expr_type == EXPR_CONSTANT))
 860                     packed = PACKED_PARTIAL;
 861                 }
 862             }
 863           else
 864             packed = PACKED_PARTIAL;
 865         }
 866
 867       type = gfc_typenode_for_spec (&sym->ts);
 868       type = gfc_get_nodesc_array_type (type, sym->as, packed,
 869                                         !sym->attr.target);
 870     }
 871   else
 872     {
 873       /* We now have an expression for the element size, so create a fully
 874          qualified type.  Reset sym->backend decl or this will just return the
 875          old type.  */
 876       DECL_ARTIFICIAL (sym->backend_decl) = 1;
 877       sym->backend_decl = NULL_TREE;
 878       type = gfc_sym_type (sym);
 879       packed = PACKED_FULL;
 880     }
 881
 882   ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);
 883   decl = build_decl (input_location,
 884                      VAR_DECL, get_identifier (name), type);
 885
 886   DECL_ARTIFICIAL (decl) = 1;
 887   TREE_PUBLIC (decl) = 0;
 888   TREE_STATIC (decl) = 0;
 889   DECL_EXTERNAL (decl) = 0;
 890
 891   /* We should never get deferred shape arrays here.  We used to because of
 892      frontend bugs.  */
 893   gcc_assert (sym->as->type != AS_DEFERRED);
 894
 895   if (packed == PACKED_PARTIAL)
 896     GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;
 897   else if (packed == PACKED_FULL)
 898     GFC_DECL_PACKED_ARRAY (decl) = 1;
 899
 900   gfc_build_qualified_array (decl, sym);
 901
 902   if (DECL_LANG_SPECIFIC (dummy))
 903     DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (dummy);
 904   else
 905     gfc_allocate_lang_decl (decl);
 906
 907   GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy;
 908
 909   if (sym->ns->proc_name->backend_decl == current_function_decl
 910       || sym->attr.contained)
 911     gfc_add_decl_to_function (decl);
 912   else
 913     gfc_add_decl_to_parent_function (decl);
 914
 915   return decl;
 916 }
 917
 918 /* For symbol SYM with GFC_DECL_SAVED_DESCRIPTOR used in contained
 919    function add a VAR_DECL to the current function with DECL_VALUE_EXPR
 920    pointing to the artificial variable for debug info purposes.  */
 921
 922 static void
 923 gfc_nonlocal_dummy_array_decl (gfc_symbol *sym)
 924 {
 925   tree decl, dummy;
 926
 927   if (! nonlocal_dummy_decl_pset)
 928     nonlocal_dummy_decl_pset = pointer_set_create ();
 929
 930   if (pointer_set_insert (nonlocal_dummy_decl_pset, sym->backend_decl))
 931     return;
 932
 933   dummy = GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl);
 934   decl = build_decl (input_location, VAR_DECL, DECL_NAME (dummy),
 935                      TREE_TYPE (sym->backend_decl));
 936   DECL_ARTIFICIAL (decl) = 0;
 937   TREE_USED (decl) = 1;
 938   TREE_PUBLIC (decl) = 0;
 939   TREE_STATIC (decl) = 0;
 940   DECL_EXTERNAL (decl) = 0;
 941   if (DECL_BY_REFERENCE (dummy))
 942     DECL_BY_REFERENCE (decl) = 1;
 943   DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (sym->backend_decl);
 944   SET_DECL_VALUE_EXPR (decl, sym->backend_decl);
 945   DECL_HAS_VALUE_EXPR_P (decl) = 1;
 946   DECL_CONTEXT (decl) = DECL_CONTEXT (sym->backend_decl);
 947   TREE_CHAIN (decl) = nonlocal_dummy_decls;
 948   nonlocal_dummy_decls = decl;
 949 }
 950
 951 /* Return a constant or a variable to use as a string length.  Does not
 952    add the decl to the current scope.  */
 953
 954 static tree
 955 gfc_create_string_length (gfc_symbol * sym)
 956 {
 957   gcc_assert (sym->ts.u.cl);
 958   gfc_conv_const_charlen (sym->ts.u.cl);
 959
 960   if (sym->ts.u.cl->backend_decl == NULL_TREE)
 961     {
 962       tree length;
 963       char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
 964
 965       /* Also prefix the mangled name.  */
 966       strcpy (&name[1], sym->name);
 967       name[0] = '.';
 968       length = build_decl (input_location,
 969                            VAR_DECL, get_identifier (name),
 970                            gfc_charlen_type_node);
 971       DECL_ARTIFICIAL (length) = 1;
 972       TREE_USED (length) = 1;
 973       if (sym->ns->proc_name->tlink != NULL)
 974         gfc_defer_symbol_init (sym);
 975
 976       sym->ts.u.cl->backend_decl = length;
 977     }
 978
 979   gcc_assert (sym->ts.u.cl->backend_decl != NULL_TREE);
 980   return sym->ts.u.cl->backend_decl;
 981 }
 982
 983 /* If a variable is assigned a label, we add another two auxiliary
 984    variables.  */
 985
 986 static void
 987 gfc_add_assign_aux_vars (gfc_symbol * sym)
 988 {
 989   tree addr;
 990   tree length;
 991   tree decl;
 992
 993   gcc_assert (sym->backend_decl);
 994
 995   decl = sym->backend_decl;
 996   gfc_allocate_lang_decl (decl);
 997   GFC_DECL_ASSIGN (decl) = 1;
 998   length = build_decl (input_location,
 999                        VAR_DECL, create_tmp_var_name (sym->name),
1000                        gfc_charlen_type_node);
1001   addr = build_decl (input_location,
1002                      VAR_DECL, create_tmp_var_name (sym->name),
1003                      pvoid_type_node);
1004   gfc_finish_var_decl (length, sym);
1005   gfc_finish_var_decl (addr, sym);
1006   /*  STRING_LENGTH is also used as flag. Less than -1 means that
1007       ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
1008       target label's address. Otherwise, value is the length of a format string
1009       and ASSIGN_ADDR is its address.  */
1010   if (TREE_STATIC (length))
1011     DECL_INITIAL (length) = build_int_cst (NULL_TREE, -2);
1012   else
1013     gfc_defer_symbol_init (sym);
1014
1015   GFC_DECL_STRING_LEN (decl) = length;
1016   GFC_DECL_ASSIGN_ADDR (decl) = addr;
1017 }
1018
1019
1020 static tree
1021 add_attributes_to_decl (symbol_attribute sym_attr, tree list)
1022 {
1023   unsigned id;
1024   tree attr;
1025
1026   for (id = 0; id < EXT_ATTR_NUM; id++)
1027     if (sym_attr.ext_attr & (1 << id))
1028       {
1029         attr = build_tree_list (
1030                  get_identifier (ext_attr_list[id].middle_end_name),
1031                                  NULL_TREE);
1032         list = chainon (list, attr);
1033       }
1034
1035   return list;
1036 }
1037
1038
1039 /* Return the decl for a gfc_symbol, create it if it doesn't already
1040    exist.  */
1041
1042 tree
1043 gfc_get_symbol_decl (gfc_symbol * sym)
1044 {
1045   tree decl;
1046   tree length = NULL_TREE;
1047   tree attributes;
1048   int byref;
1049
1050   gcc_assert (sym->attr.referenced
1051                 || sym->attr.use_assoc
1052                 || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY);
1053
1054   if (sym->ns && sym->ns->proc_name && sym->ns->proc_name->attr.function)
1055     byref = gfc_return_by_reference (sym->ns->proc_name);
1056   else
1057     byref = 0;
1058
1059   /* Make sure that the vtab for the declared type is completed.  */
1060   if (sym->ts.type == BT_CLASS)
1061     {
1062       gfc_component *c = gfc_find_component (sym->ts.u.derived,
1063                                              "$data", true, true);
1064       if (!c->ts.u.derived->backend_decl)
1065         gfc_find_derived_vtab (c->ts.u.derived, true);
1066     }
1067
1068   if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
1069     {
1070       /* Return via extra parameter.  */
1071       if (sym->attr.result && byref
1072           && !sym->backend_decl)
1073         {
1074           sym->backend_decl =
1075             DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);
1076           /* For entry master function skip over the __entry
1077              argument.  */
1078           if (sym->ns->proc_name->attr.entry_master)
1079             sym->backend_decl = TREE_CHAIN (sym->backend_decl);
1080         }
1081
1082       /* Dummy variables should already have been created.  */
1083       gcc_assert (sym->backend_decl);
1084
1085       /* Create a character length variable.  */
1086       if (sym->ts.type == BT_CHARACTER)
1087         {
1088           if (sym->ts.u.cl->backend_decl == NULL_TREE)
1089             length = gfc_create_string_length (sym);
1090           else
1091             length = sym->ts.u.cl->backend_decl;
1092           if (TREE_CODE (length) == VAR_DECL
1093               && DECL_CONTEXT (length) == NULL_TREE)
1094             {
1095               /* Add the string length to the same context as the symbol.  */
1096               if (DECL_CONTEXT (sym->backend_decl) == current_function_decl)
1097                 gfc_add_decl_to_function (length);
1098               else
1099                 gfc_add_decl_to_parent_function (length);
1100
1101               gcc_assert (DECL_CONTEXT (sym->backend_decl) ==
1102                             DECL_CONTEXT (length));
1103
1104               gfc_defer_symbol_init (sym);
1105             }
1106         }
1107
1108       /* Use a copy of the descriptor for dummy arrays.  */
1109       if (sym->attr.dimension && !TREE_USED (sym->backend_decl))
1110         {
1111           decl = gfc_build_dummy_array_decl (sym, sym->backend_decl);
1112           /* Prevent the dummy from being detected as unused if it is copied.  */
1113           if (sym->backend_decl != NULL && decl != sym->backend_decl)
1114             DECL_ARTIFICIAL (sym->backend_decl) = 1;
1115           sym->backend_decl = decl;
1116         }
1117
1118       TREE_USED (sym->backend_decl) = 1;
1119       if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0)
1120         {
1121           gfc_add_assign_aux_vars (sym);
1122         }
1123
1124       if (sym->attr.dimension
1125           && DECL_LANG_SPECIFIC (sym->backend_decl)
1126           && GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl)
1127           && DECL_CONTEXT (sym->backend_decl) != current_function_decl)
1128         gfc_nonlocal_dummy_array_decl (sym);
1129
1130       return sym->backend_decl;
1131     }
1132
1133   if (sym->backend_decl)
1134     return sym->backend_decl;
1135
1136   /* If use associated and whole file compilation, use the module
1137      declaration.  This is only needed for intrinsic types because
1138      they are substituted for one another during optimization.  */
1139   if (gfc_option.flag_whole_file
1140         && sym->attr.flavor == FL_VARIABLE
1141         && sym->ts.type != BT_DERIVED
1142         && sym->attr.use_assoc
1143         && sym->module)
1144     {
1145       gfc_gsymbol *gsym;
1146
1147       gsym =  gfc_find_gsymbol (gfc_gsym_root, sym->module);
1148       if (gsym && gsym->ns && gsym->type == GSYM_MODULE)
1149         {
1150           gfc_symbol *s;
1151           s = NULL;
1152           gfc_find_symbol (sym->name, gsym->ns, 0, &s);
1153           if (s && s->backend_decl)
1154             {
1155               if (sym->ts.type == BT_CHARACTER)
1156                 sym->ts.u.cl->backend_decl = s->ts.u.cl->backend_decl;
1157               return s->backend_decl;
1158             }
1159         }
1160     }
1161
1162   /* Catch function declarations.  Only used for actual parameters and
1163      procedure pointers.  */
1164   if (sym->attr.flavor == FL_PROCEDURE)
1165     {
1166       decl = gfc_get_extern_function_decl (sym);
1167       gfc_set_decl_location (decl, &sym->declared_at);
1168       return decl;
1169     }
1170
1171   if (sym->attr.intrinsic)
1172     internal_error ("intrinsic variable which isn't a procedure");
1173
1174   /* Create string length decl first so that they can be used in the
1175      type declaration.  */
1176   if (sym->ts.type == BT_CHARACTER)
1177     length = gfc_create_string_length (sym);
1178
1179   /* Create the decl for the variable.  */
1180   decl = build_decl (sym->declared_at.lb->location,
1181                      VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
1182
1183   /* Add attributes to variables.  Functions are handled elsewhere.  */
1184   attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1185   decl_attributes (&decl, attributes, 0);
1186
1187   /* Symbols from modules should have their assembler names mangled.
1188      This is done here rather than in gfc_finish_var_decl because it
1189      is different for string length variables.  */
1190   if (sym->module)
1191     {
1192       gfc_set_decl_assembler_name (decl, gfc_sym_mangled_identifier (sym));
1193       if (sym->attr.use_assoc)
1194         DECL_IGNORED_P (decl) = 1;
1195     }
1196
1197   if (sym->attr.dimension)
1198     {
1199       /* Create variables to hold the non-constant bits of array info.  */
1200       gfc_build_qualified_array (decl, sym);
1201
1202       if ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer)
1203         GFC_DECL_PACKED_ARRAY (decl) = 1;
1204     }
1205
1206   /* Remember this variable for allocation/cleanup.  */
1207   if (sym->attr.dimension || sym->attr.allocatable
1208       || (sym->ts.type == BT_CLASS &&
1209           (sym->ts.u.derived->components->attr.dimension
1210            || sym->ts.u.derived->components->attr.allocatable))
1211       || (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
1212       /* This applies a derived type default initializer.  */
1213       || (sym->ts.type == BT_DERIVED
1214           && sym->attr.save == SAVE_NONE
1215           && !sym->attr.data
1216           && !sym->attr.allocatable
1217           && (sym->value && !sym->ns->proc_name->attr.is_main_program)
1218           && !sym->attr.use_assoc))
1219     gfc_defer_symbol_init (sym);
1220
1221   gfc_finish_var_decl (decl, sym);
1222
1223   if (sym->ts.type == BT_CHARACTER)
1224     {
1225       /* Character variables need special handling.  */
1226       gfc_allocate_lang_decl (decl);
1227
1228       if (TREE_CODE (length) != INTEGER_CST)
1229         {
1230           char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
1231
1232           if (sym->module)
1233             {
1234               /* Also prefix the mangled name for symbols from modules.  */
1235               strcpy (&name[1], sym->name);
1236               name[0] = '.';
1237               strcpy (&name[1],
1238                       IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length)));
1239               gfc_set_decl_assembler_name (decl, get_identifier (name));
1240             }
1241           gfc_finish_var_decl (length, sym);
1242           gcc_assert (!sym->value);
1243         }
1244     }
1245   else if (sym->attr.subref_array_pointer)
1246     {
1247       /* We need the span for these beasts.  */
1248       gfc_allocate_lang_decl (decl);
1249     }
1250
1251   if (sym->attr.subref_array_pointer)
1252     {
1253       tree span;
1254       GFC_DECL_SUBREF_ARRAY_P (decl) = 1;
1255       span = build_decl (input_location,
1256                          VAR_DECL, create_tmp_var_name ("span"),
1257                          gfc_array_index_type);
1258       gfc_finish_var_decl (span, sym);
1259       TREE_STATIC (span) = TREE_STATIC (decl);
1260       DECL_ARTIFICIAL (span) = 1;
1261       DECL_INITIAL (span) = build_int_cst (gfc_array_index_type, 0);
1262
1263       GFC_DECL_SPAN (decl) = span;
1264       GFC_TYPE_ARRAY_SPAN (TREE_TYPE (decl)) = span;
1265     }
1266
1267   sym->backend_decl = decl;
1268
1269   if (sym->attr.assign)
1270     gfc_add_assign_aux_vars (sym);
1271
1272   if (TREE_STATIC (decl) && !sym->attr.use_assoc
1273       && (sym->attr.save || sym->ns->proc_name->attr.is_main_program
1274           || gfc_option.flag_max_stack_var_size == 0
1275           || sym->attr.data || sym->ns->proc_name->attr.flavor == FL_MODULE))
1276     {
1277       /* Add static initializer. For procedures, it is only needed if
1278          SAVE is specified otherwise they need to be reinitialized
1279          every time the procedure is entered. The TREE_STATIC is
1280          in this case due to -fmax-stack-var-size=.  */
1281       DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1282           TREE_TYPE (decl), sym->attr.dimension,
1283           sym->attr.pointer || sym->attr.allocatable);
1284     }
1285
1286   if (!TREE_STATIC (decl)
1287       && POINTER_TYPE_P (TREE_TYPE (decl))
1288       && !sym->attr.pointer
1289       && !sym->attr.allocatable
1290       && !sym->attr.proc_pointer)
1291     DECL_BY_REFERENCE (decl) = 1;
1292
1293   return decl;
1294 }
1295
1296
1297 /* Substitute a temporary variable in place of the real one.  */
1298
1299 void
1300 gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
1301 {
1302   save->attr = sym->attr;
1303   save->decl = sym->backend_decl;
1304
1305   gfc_clear_attr (&sym->attr);
1306   sym->attr.referenced = 1;
1307   sym->attr.flavor = FL_VARIABLE;
1308
1309   sym->backend_decl = decl;
1310 }
1311
1312
1313 /* Restore the original variable.  */
1314
1315 void
1316 gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
1317 {
1318   sym->attr = save->attr;
1319   sym->backend_decl = save->decl;
1320 }
1321
1322
1323 /* Declare a procedure pointer.  */
1324
1325 static tree
1326 get_proc_pointer_decl (gfc_symbol *sym)
1327 {
1328   tree decl;
1329   tree attributes;
1330
1331   decl = sym->backend_decl;
1332   if (decl)
1333     return decl;
1334
1335   decl = build_decl (input_location,
1336                      VAR_DECL, get_identifier (sym->name),
1337                      build_pointer_type (gfc_get_function_type (sym)));
1338
1339   if ((sym->ns->proc_name
1340       && sym->ns->proc_name->backend_decl == current_function_decl)
1341       || sym->attr.contained)
1342     gfc_add_decl_to_function (decl);
1343   else if (sym->ns->proc_name->attr.flavor != FL_MODULE)
1344     gfc_add_decl_to_parent_function (decl);
1345
1346   sym->backend_decl = decl;
1347
1348   /* If a variable is USE associated, it's always external.  */
1349   if (sym->attr.use_assoc)
1350     {
1351       DECL_EXTERNAL (decl) = 1;
1352       TREE_PUBLIC (decl) = 1;
1353     }
1354   else if (sym->module && sym->ns->proc_name->attr.flavor == FL_MODULE)
1355     {
1356       /* This is the declaration of a module variable.  */
1357       TREE_PUBLIC (decl) = 1;
1358       TREE_STATIC (decl) = 1;
1359     }
1360
1361   if (!sym->attr.use_assoc
1362         && (sym->attr.save != SAVE_NONE || sym->attr.data
1363               || (sym->value && sym->ns->proc_name->attr.is_main_program)))
1364     TREE_STATIC (decl) = 1;
1365
1366   if (TREE_STATIC (decl) && sym->value)
1367     {
1368       /* Add static initializer.  */
1369       DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1370           TREE_TYPE (decl),
1371           sym->attr.proc_pointer ? false : sym->attr.dimension,
1372           sym->attr.proc_pointer);
1373     }
1374
1375   attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1376   decl_attributes (&decl, attributes, 0);
1377
1378   return decl;
1379 }
1380
1381
1382 /* Get a basic decl for an external function.  */
1383
1384 tree
1385 gfc_get_extern_function_decl (gfc_symbol * sym)
1386 {
1387   tree type;
1388   tree fndecl;
1389   tree attributes;
1390   gfc_expr e;
1391   gfc_intrinsic_sym *isym;
1392   gfc_expr argexpr;
1393   char s[GFC_MAX_SYMBOL_LEN + 23]; /* "_gfortran_f2c_specific" and '\0'.  */
1394   tree name;
1395   tree mangled_name;
1396   gfc_gsymbol *gsym;
1397
1398   if (sym->backend_decl)
1399     return sym->backend_decl;
1400
1401   /* We should never be creating external decls for alternate entry points.
1402      The procedure may be an alternate entry point, but we don't want/need
1403      to know that.  */
1404   gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
1405
1406   if (sym->attr.proc_pointer)
1407     return get_proc_pointer_decl (sym);
1408
1409   /* See if this is an external procedure from the same file.  If so,
1410      return the backend_decl.  */
1411   gsym =  gfc_find_gsymbol (gfc_gsym_root, sym->name);
1412
1413   if (gfc_option.flag_whole_file
1414         && !sym->attr.use_assoc
1415         && !sym->backend_decl
1416         && gsym && gsym->ns
1417         && ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION))
1418         && gsym->ns->proc_name->backend_decl)
1419     {
1420       /* If the namespace has entries, the proc_name is the
1421          entry master.  Find the entry and use its backend_decl.
1422          otherwise, use the proc_name backend_decl.  */
1423       if (gsym->ns->entries)
1424         {
1425           gfc_entry_list *entry = gsym->ns->entries;
1426
1427           for (; entry; entry = entry->next)
1428             {
1429               if (strcmp (gsym->name, entry->sym->name) == 0)
1430                 {
1431                   sym->backend_decl = entry->sym->backend_decl;
1432                   break;
1433                 }
1434             }
1435         }
1436       else
1437         {
1438           sym->backend_decl = gsym->ns->proc_name->backend_decl;
1439         }
1440
1441       if (sym->backend_decl)
1442         return sym->backend_decl;
1443     }
1444
1445   /* See if this is a module procedure from the same file.  If so,
1446      return the backend_decl.  */
1447   if (sym->module)
1448     gsym =  gfc_find_gsymbol (gfc_gsym_root, sym->module);
1449
1450   if (gfc_option.flag_whole_file
1451         && gsym && gsym->ns
1452         && gsym->type == GSYM_MODULE)
1453     {
1454       gfc_symbol *s;
1455
1456       s = NULL;
1457       gfc_find_symbol (sym->name, gsym->ns, 0, &s);
1458       if (s && s->backend_decl)
1459         {
1460           sym->backend_decl = s->backend_decl;
1461           return sym->backend_decl;
1462         }
1463     }
1464
1465   if (sym->attr.intrinsic)
1466     {
1467       /* Call the resolution function to get the actual name.  This is
1468          a nasty hack which relies on the resolution functions only looking
1469          at the first argument.  We pass NULL for the second argument
1470          otherwise things like AINT get confused.  */
1471       isym = gfc_find_function (sym->name);
1472       gcc_assert (isym->resolve.f0 != NULL);
1473
1474       memset (&e, 0, sizeof (e));
1475       e.expr_type = EXPR_FUNCTION;
1476
1477       memset (&argexpr, 0, sizeof (argexpr));
1478       gcc_assert (isym->formal);
1479       argexpr.ts = isym->formal->ts;
1480
1481       if (isym->formal->next == NULL)
1482         isym->resolve.f1 (&e, &argexpr);
1483       else
1484         {
1485           if (isym->formal->next->next == NULL)
1486             isym->resolve.f2 (&e, &argexpr, NULL);
1487           else
1488             {
1489               if (isym->formal->next->next->next == NULL)
1490                 isym->resolve.f3 (&e, &argexpr, NULL, NULL);
1491               else
1492                 {
1493                   /* All specific intrinsics take less than 5 arguments.  */
1494                   gcc_assert (isym->formal->next->next->next->next == NULL);
1495                   isym->resolve.f4 (&e, &argexpr, NULL, NULL, NULL);
1496                 }
1497             }
1498         }
1499
1500       if (gfc_option.flag_f2c
1501           && ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)
1502               || e.ts.type == BT_COMPLEX))
1503         {
1504           /* Specific which needs a different implementation if f2c
1505              calling conventions are used.  */
1506           sprintf (s, "_gfortran_f2c_specific%s", e.value.function.name);
1507         }
1508       else
1509         sprintf (s, "_gfortran_specific%s", e.value.function.name);
1510
1511       name = get_identifier (s);
1512       mangled_name = name;
1513     }
1514   else
1515     {
1516       name = gfc_sym_identifier (sym);
1517       mangled_name = gfc_sym_mangled_function_id (sym);
1518     }
1519
1520   type = gfc_get_function_type (sym);
1521   fndecl = build_decl (input_location,
1522                        FUNCTION_DECL, name, type);
1523
1524   attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1525   decl_attributes (&fndecl, attributes, 0);
1526
1527   gfc_set_decl_assembler_name (fndecl, mangled_name);
1528
1529   /* Set the context of this decl.  */
1530   if (0 && sym->ns && sym->ns->proc_name)
1531     {
1532       /* TODO: Add external decls to the appropriate scope.  */
1533       DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
1534     }
1535   else
1536     {
1537       /* Global declaration, e.g. intrinsic subroutine.  */
1538       DECL_CONTEXT (fndecl) = NULL_TREE;
1539     }
1540
1541   DECL_EXTERNAL (fndecl) = 1;
1542
1543   /* This specifies if a function is globally addressable, i.e. it is
1544      the opposite of declaring static in C.  */
1545   TREE_PUBLIC (fndecl) = 1;
1546
1547   /* Set attributes for PURE functions. A call to PURE function in the
1548      Fortran 95 sense is both pure and without side effects in the C
1549      sense.  */
1550   if (sym->attr.pure || sym->attr.elemental)
1551     {
1552       if (sym->attr.function && !gfc_return_by_reference (sym))
1553         DECL_PURE_P (fndecl) = 1;
1554       /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
1555          parameters and don't use alternate returns (is this
1556          allowed?). In that case, calls to them are meaningless, and
1557          can be optimized away. See also in build_function_decl().  */
1558       TREE_SIDE_EFFECTS (fndecl) = 0;
1559     }
1560
1561   /* Mark non-returning functions.  */
1562   if (sym->attr.noreturn)
1563       TREE_THIS_VOLATILE(fndecl) = 1;
1564
1565   sym->backend_decl = fndecl;
1566
1567   if (DECL_CONTEXT (fndecl) == NULL_TREE)
1568     pushdecl_top_level (fndecl);
1569
1570   return fndecl;
1571 }
1572
1573
1574 /* Create a declaration for a procedure.  For external functions (in the C
1575    sense) use gfc_get_extern_function_decl.  HAS_ENTRIES is true if this is
1576    a master function with alternate entry points.  */
1577
1578 static void
1579 build_function_decl (gfc_symbol * sym)
1580 {
1581   tree fndecl, type, attributes;
1582   symbol_attribute attr;
1583   tree result_decl;
1584   gfc_formal_arglist *f;
1585
1586   gcc_assert (!sym->backend_decl);
1587   gcc_assert (!sym->attr.external);
1588
1589   /* Set the line and filename.  sym->declared_at seems to point to the
1590      last statement for subroutines, but it'll do for now.  */
1591   gfc_set_backend_locus (&sym->declared_at);
1592
1593   /* Allow only one nesting level.  Allow public declarations.  */
1594   gcc_assert (current_function_decl == NULL_TREE
1595               || DECL_CONTEXT (current_function_decl) == NULL_TREE
1596               || TREE_CODE (DECL_CONTEXT (current_function_decl))
1597                  == NAMESPACE_DECL);
1598
1599   type = gfc_get_function_type (sym);
1600   fndecl = build_decl (input_location,
1601                        FUNCTION_DECL, gfc_sym_identifier (sym), type);
1602
1603   attr = sym->attr;
1604
1605   attributes = add_attributes_to_decl (attr, NULL_TREE);
1606   decl_attributes (&fndecl, attributes, 0);
1607
1608   /* Perform name mangling if this is a top level or module procedure.  */
1609   if (current_function_decl == NULL_TREE)
1610     gfc_set_decl_assembler_name (fndecl, gfc_sym_mangled_function_id (sym));
1611
1612   /* Figure out the return type of the declared function, and build a
1613      RESULT_DECL for it.  If this is a subroutine with alternate
1614      returns, build a RESULT_DECL for it.  */
1615   result_decl = NULL_TREE;
1616   /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)).  */
1617   if (attr.function)
1618     {
1619       if (gfc_return_by_reference (sym))
1620         type = void_type_node;
1621       else
1622         {
1623           if (sym->result != sym)
1624             result_decl = gfc_sym_identifier (sym->result);
1625
1626           type = TREE_TYPE (TREE_TYPE (fndecl));
1627         }
1628     }
1629   else
1630     {
1631       /* Look for alternate return placeholders.  */
1632       int has_alternate_returns = 0;
1633       for (f = sym->formal; f; f = f->next)
1634         {
1635           if (f->sym == NULL)
1636             {
1637               has_alternate_returns = 1;
1638               break;
1639             }
1640         }
1641
1642       if (has_alternate_returns)
1643         type = integer_type_node;
1644       else
1645         type = void_type_node;
1646     }
1647
1648   result_decl = build_decl (input_location,
1649                             RESULT_DECL, result_decl, type);
1650   DECL_ARTIFICIAL (result_decl) = 1;
1651   DECL_IGNORED_P (result_decl) = 1;
1652   DECL_CONTEXT (result_decl) = fndecl;
1653   DECL_RESULT (fndecl) = result_decl;
1654
1655   /* Don't call layout_decl for a RESULT_DECL.
1656      layout_decl (result_decl, 0);  */
1657
1658   /* Set up all attributes for the function.  */
1659   DECL_CONTEXT (fndecl) = current_function_decl;
1660   DECL_EXTERNAL (fndecl) = 0;
1661
1662   /* This specifies if a function is globally visible, i.e. it is
1663      the opposite of declaring static in C.  */
1664   if (DECL_CONTEXT (fndecl) == NULL_TREE
1665       && !sym->attr.entry_master && !sym->attr.is_main_program)
1666     TREE_PUBLIC (fndecl) = 1;
1667
1668   /* TREE_STATIC means the function body is defined here.  */
1669   TREE_STATIC (fndecl) = 1;
1670
1671   /* Set attributes for PURE functions. A call to a PURE function in the
1672      Fortran 95 sense is both pure and without side effects in the C
1673      sense.  */
1674   if (attr.pure || attr.elemental)
1675     {
1676       /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
1677          including an alternate return. In that case it can also be
1678          marked as PURE. See also in gfc_get_extern_function_decl().  */
1679       if (attr.function && !gfc_return_by_reference (sym))
1680         DECL_PURE_P (fndecl) = 1;
1681       TREE_SIDE_EFFECTS (fndecl) = 0;
1682     }
1683
1684
1685   /* Layout the function declaration and put it in the binding level
1686      of the current function.  */
1687   pushdecl (fndecl);
1688
1689   sym->backend_decl = fndecl;
1690 }
1691
1692
1693 /* Create the DECL_ARGUMENTS for a procedure.  */
1694
1695 static void
1696 create_function_arglist (gfc_symbol * sym)
1697 {
1698   tree fndecl;
1699   gfc_formal_arglist *f;
1700   tree typelist, hidden_typelist;
1701   tree arglist, hidden_arglist;
1702   tree type;
1703   tree parm;
1704
1705   fndecl = sym->backend_decl;
1706
1707   /* Build formal argument list. Make sure that their TREE_CONTEXT is
1708      the new FUNCTION_DECL node.  */
1709   arglist = NULL_TREE;
1710   hidden_arglist = NULL_TREE;
1711   typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
1712
1713   if (sym->attr.entry_master)
1714     {
1715       type = TREE_VALUE (typelist);
1716       parm = build_decl (input_location,
1717                          PARM_DECL, get_identifier ("__entry"), type);
1718
1719       DECL_CONTEXT (parm) = fndecl;
1720       DECL_ARG_TYPE (parm) = type;
1721       TREE_READONLY (parm) = 1;
1722       gfc_finish_decl (parm);
1723       DECL_ARTIFICIAL (parm) = 1;
1724
1725       arglist = chainon (arglist, parm);
1726       typelist = TREE_CHAIN (typelist);
1727     }
1728
1729   if (gfc_return_by_reference (sym))
1730     {
1731       tree type = TREE_VALUE (typelist), length = NULL;
1732
1733       if (sym->ts.type == BT_CHARACTER)
1734         {
1735           /* Length of character result.  */
1736           tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
1737           gcc_assert (len_type == gfc_charlen_type_node);
1738
1739           length = build_decl (input_location,
1740                                PARM_DECL,
1741                                get_identifier (".__result"),
1742                                len_type);
1743           if (!sym->ts.u.cl->length)
1744             {
1745               sym->ts.u.cl->backend_decl = length;
1746               TREE_USED (length) = 1;
1747             }
1748           gcc_assert (TREE_CODE (length) == PARM_DECL);
1749           DECL_CONTEXT (length) = fndecl;
1750           DECL_ARG_TYPE (length) = len_type;
1751           TREE_READONLY (length) = 1;
1752           DECL_ARTIFICIAL (length) = 1;
1753           gfc_finish_decl (length);
1754           if (sym->ts.u.cl->backend_decl == NULL
1755               || sym->ts.u.cl->backend_decl == length)
1756             {
1757               gfc_symbol *arg;
1758               tree backend_decl;
1759
1760               if (sym->ts.u.cl->backend_decl == NULL)
1761                 {
1762                   tree len = build_decl (input_location,
1763                                          VAR_DECL,
1764                                          get_identifier ("..__result"),
1765                                          gfc_charlen_type_node);
1766                   DECL_ARTIFICIAL (len) = 1;
1767                   TREE_USED (len) = 1;
1768                   sym->ts.u.cl->backend_decl = len;
1769                 }
1770
1771               /* Make sure PARM_DECL type doesn't point to incomplete type.  */
1772               arg = sym->result ? sym->result : sym;
1773               backend_decl = arg->backend_decl;
1774               /* Temporary clear it, so that gfc_sym_type creates complete
1775                  type.  */
1776               arg->backend_decl = NULL;
1777               type = gfc_sym_type (arg);
1778               arg->backend_decl = backend_decl;
1779               type = build_reference_type (type);
1780             }
1781         }
1782
1783       parm = build_decl (input_location,
1784                          PARM_DECL, get_identifier ("__result"), type);
1785
1786       DECL_CONTEXT (parm) = fndecl;
1787       DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1788       TREE_READONLY (parm) = 1;
1789       DECL_ARTIFICIAL (parm) = 1;
1790       gfc_finish_decl (parm);
1791
1792       arglist = chainon (arglist, parm);
1793       typelist = TREE_CHAIN (typelist);
1794
1795       if (sym->ts.type == BT_CHARACTER)
1796         {
1797           gfc_allocate_lang_decl (parm);
1798           arglist = chainon (arglist, length);
1799           typelist = TREE_CHAIN (typelist);
1800         }
1801     }
1802
1803   hidden_typelist = typelist;
1804   for (f = sym->formal; f; f = f->next)
1805     if (f->sym != NULL) /* Ignore alternate returns.  */
1806       hidden_typelist = TREE_CHAIN (hidden_typelist);
1807
1808   for (f = sym->formal; f; f = f->next)
1809     {
1810       char name[GFC_MAX_SYMBOL_LEN + 2];
1811
1812       /* Ignore alternate returns.  */
1813       if (f->sym == NULL)
1814         continue;
1815
1816       type = TREE_VALUE (typelist);
1817
1818       if (f->sym->ts.type == BT_CHARACTER
1819           && (!sym->attr.is_bind_c || sym->attr.entry_master))
1820         {
1821           tree len_type = TREE_VALUE (hidden_typelist);
1822           tree length = NULL_TREE;
1823           gcc_assert (len_type == gfc_charlen_type_node);
1824
1825           strcpy (&name[1], f->sym->name);
1826           name[0] = '_';
1827           length = build_decl (input_location,
1828                                PARM_DECL, get_identifier (name), len_type);
1829
1830           hidden_arglist = chainon (hidden_arglist, length);
1831           DECL_CONTEXT (length) = fndecl;
1832           DECL_ARTIFICIAL (length) = 1;
1833           DECL_ARG_TYPE (length) = len_type;
1834           TREE_READONLY (length) = 1;
1835           gfc_finish_decl (length);
1836
1837           /* Remember the passed value.  */
1838           if (f->sym->ts.u.cl->passed_length != NULL)
1839             {
1840               /* This can happen if the same type is used for multiple
1841                  arguments. We need to copy cl as otherwise
1842                  cl->passed_length gets overwritten.  */
1843               f->sym->ts.u.cl = gfc_new_charlen (f->sym->ns, f->sym->ts.u.cl);
1844             }
1845           f->sym->ts.u.cl->passed_length = length;
1846
1847           /* Use the passed value for assumed length variables.  */
1848           if (!f->sym->ts.u.cl->length)
1849             {
1850               TREE_USED (length) = 1;
1851               gcc_assert (!f->sym->ts.u.cl->backend_decl);
1852               f->sym->ts.u.cl->backend_decl = length;
1853             }
1854
1855           hidden_typelist = TREE_CHAIN (hidden_typelist);
1856
1857           if (f->sym->ts.u.cl->backend_decl == NULL
1858               || f->sym->ts.u.cl->backend_decl == length)
1859             {
1860               if (f->sym->ts.u.cl->backend_decl == NULL)
1861                 gfc_create_string_length (f->sym);
1862
1863               /* Make sure PARM_DECL type doesn't point to incomplete type.  */
1864               if (f->sym->attr.flavor == FL_PROCEDURE)
1865                 type = build_pointer_type (gfc_get_function_type (f->sym));
1866               else
1867                 type = gfc_sym_type (f->sym);
1868             }
1869         }
1870
1871       /* For non-constant length array arguments, make sure they use
1872          a different type node from TYPE_ARG_TYPES type.  */
1873       if (f->sym->attr.dimension
1874           && type == TREE_VALUE (typelist)
1875           && TREE_CODE (type) == POINTER_TYPE
1876           && GFC_ARRAY_TYPE_P (type)
1877           && f->sym->as->type != AS_ASSUMED_SIZE
1878           && ! COMPLETE_TYPE_P (TREE_TYPE (type)))
1879         {
1880           if (f->sym->attr.flavor == FL_PROCEDURE)
1881             type = build_pointer_type (gfc_get_function_type (f->sym));
1882           else
1883             type = gfc_sym_type (f->sym);
1884         }
1885
1886       if (f->sym->attr.proc_pointer)
1887         type = build_pointer_type (type);
1888
1889       /* Build the argument declaration.  */
1890       parm = build_decl (input_location,
1891                          PARM_DECL, gfc_sym_identifier (f->sym), type);
1892
1893       /* Fill in arg stuff.  */
1894       DECL_CONTEXT (parm) = fndecl;
1895       DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1896       /* All implementation args are read-only.  */
1897       TREE_READONLY (parm) = 1;
1898       if (POINTER_TYPE_P (type)
1899           && (!f->sym->attr.proc_pointer
1900               && f->sym->attr.flavor != FL_PROCEDURE))
1901         DECL_BY_REFERENCE (parm) = 1;
1902
1903       gfc_finish_decl (parm);
1904
1905       f->sym->backend_decl = parm;
1906
1907       arglist = chainon (arglist, parm);
1908       typelist = TREE_CHAIN (typelist);
1909     }
1910
1911   /* Add the hidden string length parameters, unless the procedure
1912      is bind(C).  */
1913   if (!sym->attr.is_bind_c)
1914     arglist = chainon (arglist, hidden_arglist);
1915
1916   gcc_assert (hidden_typelist == NULL_TREE
1917               || TREE_VALUE (hidden_typelist) == void_type_node);
1918   DECL_ARGUMENTS (fndecl) = arglist;
1919 }
1920
1921 /* Do the setup necessary before generating the body of a function.  */
1922
1923 static void
1924 trans_function_start (gfc_symbol * sym)
1925 {
1926   tree fndecl;
1927
1928   fndecl = sym->backend_decl;
1929
1930   /* Let GCC know the current scope is this function.  */
1931   current_function_decl = fndecl;
1932
1933   /* Let the world know what we're about to do.  */
1934   announce_function (fndecl);
1935
1936   if (DECL_CONTEXT (fndecl) == NULL_TREE)
1937     {
1938       /* Create RTL for function declaration.  */
1939       rest_of_decl_compilation (fndecl, 1, 0);
1940     }
1941
1942   /* Create RTL for function definition.  */
1943   make_decl_rtl (fndecl);
1944
1945   init_function_start (fndecl);
1946
1947   /* Even though we're inside a function body, we still don't want to
1948      call expand_expr to calculate the size of a variable-sized array.
1949      We haven't necessarily assigned RTL to all variables yet, so it's
1950      not safe to try to expand expressions involving them.  */
1951   cfun->dont_save_pending_sizes_p = 1;
1952
1953   /* function.c requires a push at the start of the function.  */
1954   pushlevel (0);
1955 }
1956
1957 /* Create thunks for alternate entry points.  */
1958
1959 static void
1960 build_entry_thunks (gfc_namespace * ns)
1961 {
1962   gfc_formal_arglist *formal;
1963   gfc_formal_arglist *thunk_formal;
1964   gfc_entry_list *el;
1965   gfc_symbol *thunk_sym;
1966   stmtblock_t body;
1967   tree thunk_fndecl;
1968   tree args;
1969   tree string_args;
1970   tree tmp;
1971   locus old_loc;
1972
1973   /* This should always be a toplevel function.  */
1974   gcc_assert (current_function_decl == NULL_TREE);
1975
1976   gfc_get_backend_locus (&old_loc);
1977   for (el = ns->entries; el; el = el->next)
1978     {
1979       thunk_sym = el->sym;
1980
1981       build_function_decl (thunk_sym);
1982       create_function_arglist (thunk_sym);
1983
1984       trans_function_start (thunk_sym);
1985
1986       thunk_fndecl = thunk_sym->backend_decl;
1987
1988       gfc_init_block (&body);
1989
1990       /* Pass extra parameter identifying this entry point.  */
1991       tmp = build_int_cst (gfc_array_index_type, el->id);
1992       args = tree_cons (NULL_TREE, tmp, NULL_TREE);
1993       string_args = NULL_TREE;
1994
1995       if (thunk_sym->attr.function)
1996         {
1997           if (gfc_return_by_reference (ns->proc_name))
1998             {
1999               tree ref = DECL_ARGUMENTS (current_function_decl);
2000               args = tree_cons (NULL_TREE, ref, args);
2001               if (ns->proc_name->ts.type == BT_CHARACTER)
2002                 args = tree_cons (NULL_TREE, TREE_CHAIN (ref),
2003                                   args);
2004             }
2005         }
2006
2007       for (formal = ns->proc_name->formal; formal; formal = formal->next)
2008         {
2009           /* Ignore alternate returns.  */
2010           if (formal->sym == NULL)
2011             continue;
2012
2013           /* We don't have a clever way of identifying arguments, so resort to
2014              a brute-force search.  */
2015           for (thunk_formal = thunk_sym->formal;
2016                thunk_formal;
2017                thunk_formal = thunk_formal->next)
2018             {
2019               if (thunk_formal->sym == formal->sym)
2020                 break;
2021             }
2022
2023           if (thunk_formal)
2024             {
2025               /* Pass the argument.  */
2026               DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1;
2027               args = tree_cons (NULL_TREE, thunk_formal->sym->backend_decl,
2028                                 args);
2029               if (formal->sym->ts.type == BT_CHARACTER)
2030                 {
2031                   tmp = thunk_formal->sym->ts.u.cl->backend_decl;
2032                   string_args = tree_cons (NULL_TREE, tmp, string_args);
2033                 }
2034             }
2035           else
2036             {
2037               /* Pass NULL for a missing argument.  */
2038               args = tree_cons (NULL_TREE, null_pointer_node, args);
2039               if (formal->sym->ts.type == BT_CHARACTER)
2040                 {
2041                   tmp = build_int_cst (gfc_charlen_type_node, 0);
2042                   string_args = tree_cons (NULL_TREE, tmp, string_args);
2043                 }
2044             }
2045         }
2046
2047       /* Call the master function.  */
2048       args = nreverse (args);
2049       args = chainon (args, nreverse (string_args));
2050       tmp = ns->proc_name->backend_decl;
2051       tmp = build_function_call_expr (input_location, tmp, args);
2052       if (ns->proc_name->attr.mixed_entry_master)
2053         {
2054           tree union_decl, field;
2055           tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
2056
2057           union_decl = build_decl (input_location,
2058                                    VAR_DECL, get_identifier ("__result"),
2059                                    TREE_TYPE (master_type));
2060           DECL_ARTIFICIAL (union_decl) = 1;
2061           DECL_EXTERNAL (union_decl) = 0;
2062           TREE_PUBLIC (union_decl) = 0;
2063           TREE_USED (union_decl) = 1;
2064           layout_decl (union_decl, 0);
2065           pushdecl (union_decl);
2066
2067           DECL_CONTEXT (union_decl) = current_function_decl;
2068           tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (union_decl),
2069                              union_decl, tmp);
2070           gfc_add_expr_to_block (&body, tmp);
2071
2072           for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
2073                field; field = TREE_CHAIN (field))
2074             if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
2075                 thunk_sym->result->name) == 0)
2076               break;
2077           gcc_assert (field != NULL_TREE);
2078           tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
2079                              union_decl, field, NULL_TREE);
2080           tmp = fold_build2 (MODIFY_EXPR,
2081                              TREE_TYPE (DECL_RESULT (current_function_decl)),
2082                              DECL_RESULT (current_function_decl), tmp);
2083           tmp = build1_v (RETURN_EXPR, tmp);
2084         }
2085       else if (TREE_TYPE (DECL_RESULT (current_function_decl))
2086                != void_type_node)
2087         {
2088           tmp = fold_build2 (MODIFY_EXPR,
2089                              TREE_TYPE (DECL_RESULT (current_function_decl)),
2090                              DECL_RESULT (current_function_decl), tmp);
2091           tmp = build1_v (RETURN_EXPR, tmp);
2092         }
2093       gfc_add_expr_to_block (&body, tmp);
2094
2095       /* Finish off this function and send it for code generation.  */
2096       DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
2097       tmp = getdecls ();
2098       poplevel (1, 0, 1);
2099       BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
2100       DECL_SAVED_TREE (thunk_fndecl)
2101         = build3_v (BIND_EXPR, tmp, DECL_SAVED_TREE (thunk_fndecl),
2102                     DECL_INITIAL (thunk_fndecl));
2103
2104       /* Output the GENERIC tree.  */
2105       dump_function (TDI_original, thunk_fndecl);
2106
2107       /* Store the end of the function, so that we get good line number
2108          info for the epilogue.  */
2109       cfun->function_end_locus = input_location;
2110
2111       /* We're leaving the context of this function, so zap cfun.
2112          It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
2113          tree_rest_of_compilation.  */
2114       set_cfun (NULL);
2115
2116       current_function_decl = NULL_TREE;
2117
2118       cgraph_finalize_function (thunk_fndecl, true);
2119
2120       /* We share the symbols in the formal argument list with other entry
2121          points and the master function.  Clear them so that they are
2122          recreated for each function.  */
2123       for (formal = thunk_sym->formal; formal; formal = formal->next)
2124         if (formal->sym != NULL)  /* Ignore alternate returns.  */
2125           {
2126             formal->sym->backend_decl = NULL_TREE;
2127             if (formal->sym->ts.type == BT_CHARACTER)
2128               formal->sym->ts.u.cl->backend_decl = NULL_TREE;
2129           }
2130
2131       if (thunk_sym->attr.function)
2132         {
2133           if (thunk_sym->ts.type == BT_CHARACTER)
2134             thunk_sym->ts.u.cl->backend_decl = NULL_TREE;
2135           if (thunk_sym->result->ts.type == BT_CHARACTER)
2136             thunk_sym->result->ts.u.cl->backend_decl = NULL_TREE;
2137         }
2138     }
2139
2140   gfc_set_backend_locus (&old_loc);
2141 }
2142
2143
2144 /* Create a decl for a function, and create any thunks for alternate entry
2145    points.  */
2146
2147 void
2148 gfc_create_function_decl (gfc_namespace * ns)
2149 {
2150   /* Create a declaration for the master function.  */
2151   build_function_decl (ns->proc_name);
2152
2153   /* Compile the entry thunks.  */
2154   if (ns->entries)
2155     build_entry_thunks (ns);
2156
2157   /* Now create the read argument list.  */
2158   create_function_arglist (ns->proc_name);
2159 }
2160
2161 /* Return the decl used to hold the function return value.  If
2162    parent_flag is set, the context is the parent_scope.  */
2163
2164 tree
2165 gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
2166 {
2167   tree decl;
2168   tree length;
2169   tree this_fake_result_decl;
2170   tree this_function_decl;
2171
2172   char name[GFC_MAX_SYMBOL_LEN + 10];
2173
2174   if (parent_flag)
2175     {
2176       this_fake_result_decl = parent_fake_result_decl;
2177       this_function_decl = DECL_CONTEXT (current_function_decl);
2178     }
2179   else
2180     {
2181       this_fake_result_decl = current_fake_result_decl;
2182       this_function_decl = current_function_decl;
2183     }
2184
2185   if (sym
2186       && sym->ns->proc_name->backend_decl == this_function_decl
2187       && sym->ns->proc_name->attr.entry_master
2188       && sym != sym->ns->proc_name)
2189     {
2190       tree t = NULL, var;
2191       if (this_fake_result_decl != NULL)
2192         for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t))
2193           if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
2194             break;
2195       if (t)
2196         return TREE_VALUE (t);
2197       decl = gfc_get_fake_result_decl (sym->ns->proc_name, parent_flag);
2198
2199       if (parent_flag)
2200         this_fake_result_decl = parent_fake_result_decl;
2201       else
2202         this_fake_result_decl = current_fake_result_decl;
2203
2204       if (decl && sym->ns->proc_name->attr.mixed_entry_master)
2205         {
2206           tree field;
2207
2208           for (field = TYPE_FIELDS (TREE_TYPE (decl));
2209                field; field = TREE_CHAIN (field))
2210             if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
2211                 sym->name) == 0)
2212               break;
2213
2214           gcc_assert (field != NULL_TREE);
2215           decl = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
2216                               decl, field, NULL_TREE);
2217         }
2218
2219       var = create_tmp_var_raw (TREE_TYPE (decl), sym->name);
2220       if (parent_flag)
2221         gfc_add_decl_to_parent_function (var);
2222       else
2223         gfc_add_decl_to_function (var);
2224
2225       SET_DECL_VALUE_EXPR (var, decl);
2226       DECL_HAS_VALUE_EXPR_P (var) = 1;
2227       GFC_DECL_RESULT (var) = 1;
2228
2229       TREE_CHAIN (this_fake_result_decl)
2230           = tree_cons (get_identifier (sym->name), var,
2231                        TREE_CHAIN (this_fake_result_decl));
2232       return var;
2233     }
2234
2235   if (this_fake_result_decl != NULL_TREE)
2236     return TREE_VALUE (this_fake_result_decl);
2237
2238   /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
2239      sym is NULL.  */
2240   if (!sym)
2241     return NULL_TREE;
2242
2243   if (sym->ts.type == BT_CHARACTER)
2244     {
2245       if (sym->ts.u.cl->backend_decl == NULL_TREE)
2246         length = gfc_create_string_length (sym);
2247       else
2248         length = sym->ts.u.cl->backend_decl;
2249       if (TREE_CODE (length) == VAR_DECL
2250           && DECL_CONTEXT (length) == NULL_TREE)
2251         gfc_add_decl_to_function (length);
2252     }
2253
2254   if (gfc_return_by_reference (sym))
2255     {
2256       decl = DECL_ARGUMENTS (this_function_decl);
2257
2258       if (sym->ns->proc_name->backend_decl == this_function_decl
2259           && sym->ns->proc_name->attr.entry_master)
2260         decl = TREE_CHAIN (decl);
2261
2262       TREE_USED (decl) = 1;
2263       if (sym->as)
2264         decl = gfc_build_dummy_array_decl (sym, decl);
2265     }
2266   else
2267     {
2268       sprintf (name, "__result_%.20s",
2269                IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
2270
2271       if (!sym->attr.mixed_entry_master && sym->attr.function)
2272         decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl),
2273                            VAR_DECL, get_identifier (name),
2274                            gfc_sym_type (sym));
2275       else
2276         decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl),
2277                            VAR_DECL, get_identifier (name),
2278                            TREE_TYPE (TREE_TYPE (this_function_decl)));
2279       DECL_ARTIFICIAL (decl) = 1;
2280       DECL_EXTERNAL (decl) = 0;
2281       TREE_PUBLIC (decl) = 0;
2282       TREE_USED (decl) = 1;
2283       GFC_DECL_RESULT (decl) = 1;
2284       TREE_ADDRESSABLE (decl) = 1;
2285
2286       layout_decl (decl, 0);
2287
2288       if (parent_flag)
2289         gfc_add_decl_to_parent_function (decl);
2290       else
2291         gfc_add_decl_to_function (decl);
2292     }
2293
2294   if (parent_flag)
2295     parent_fake_result_decl = build_tree_list (NULL, decl);
2296   else
2297     current_fake_result_decl = build_tree_list (NULL, decl);
2298
2299   return decl;
2300 }
2301
2302
2303 /* Builds a function decl.  The remaining parameters are the types of the
2304    function arguments.  Negative nargs indicates a varargs function.  */
2305
2306 static tree
2307 build_library_function_decl_1 (tree name, const char *spec,
2308                                tree rettype, int nargs, va_list p)
2309 {
2310   tree arglist;
2311   tree argtype;
2312   tree fntype;
2313   tree fndecl;
2314   int n;
2315
2316   /* Library functions must be declared with global scope.  */
2317   gcc_assert (current_function_decl == NULL_TREE);
2318
2319   /* Create a list of the argument types.  */
2320   for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
2321     {
2322       argtype = va_arg (p, tree);
2323       arglist = gfc_chainon_list (arglist, argtype);
2324     }
2325
2326   if (nargs >= 0)
2327     {
2328       /* Terminate the list.  */
2329       arglist = gfc_chainon_list (arglist, void_type_node);
2330     }
2331
2332   /* Build the function type and decl.  */
2333   fntype = build_function_type (rettype, arglist);
2334   if (spec)
2335     {
2336       tree attr_args = build_tree_list (NULL_TREE,
2337                                         build_string (strlen (spec), spec));
2338       tree attrs = tree_cons (get_identifier ("fn spec"),
2339                               attr_args, TYPE_ATTRIBUTES (fntype));
2340       fntype = build_type_attribute_variant (fntype, attrs);
2341     }
2342   fndecl = build_decl (input_location,
2343                        FUNCTION_DECL, name, fntype);
2344
2345   /* Mark this decl as external.  */
2346   DECL_EXTERNAL (fndecl) = 1;
2347   TREE_PUBLIC (fndecl) = 1;
2348
2349   pushdecl (fndecl);
2350
2351   rest_of_decl_compilation (fndecl, 1, 0);
2352
2353   return fndecl;
2354 }
2355
2356 /* Builds a function decl.  The remaining parameters are the types of the
2357    function arguments.  Negative nargs indicates a varargs function.  */
2358
2359 tree
2360 gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
2361 {
2362   tree ret;
2363   va_list args;
2364   va_start (args, nargs);
2365   ret = build_library_function_decl_1 (name, NULL, rettype, nargs, args);
2366   va_end (args);
2367   return ret;
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    The SPEC parameter specifies the function argument and return type
2373    specification according to the fnspec function type attribute.  */
2374
2375 static tree
2376 gfc_build_library_function_decl_with_spec (tree name, const char *spec,
2377                                            tree rettype, int nargs, ...)
2378 {
2379   tree ret;
2380   va_list args;
2381   va_start (args, nargs);
2382   ret = build_library_function_decl_1 (name, spec, rettype, nargs, args);
2383   va_end (args);
2384   return ret;
2385 }
2386
2387 static void
2388 gfc_build_intrinsic_function_decls (void)
2389 {
2390   tree gfc_int4_type_node = gfc_get_int_type (4);
2391   tree gfc_int8_type_node = gfc_get_int_type (8);
2392   tree gfc_int16_type_node = gfc_get_int_type (16);
2393   tree gfc_logical4_type_node = gfc_get_logical_type (4);
2394   tree pchar1_type_node = gfc_get_pchar_type (1);
2395   tree pchar4_type_node = gfc_get_pchar_type (4);
2396
2397   /* String functions.  */
2398   gfor_fndecl_compare_string =
2399     gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),
2400                                      integer_type_node, 4,
2401                                      gfc_charlen_type_node, pchar1_type_node,
2402                                      gfc_charlen_type_node, pchar1_type_node);
2403
2404   gfor_fndecl_concat_string =
2405     gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),
2406                                      void_type_node, 6,
2407                                      gfc_charlen_type_node, pchar1_type_node,
2408                                      gfc_charlen_type_node, pchar1_type_node,
2409                                      gfc_charlen_type_node, pchar1_type_node);
2410
2411   gfor_fndecl_string_len_trim =
2412     gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")),
2413                                      gfc_int4_type_node, 2,
2414                                      gfc_charlen_type_node, pchar1_type_node);
2415
2416   gfor_fndecl_string_index =
2417     gfc_build_library_function_decl (get_identifier (PREFIX("string_index")),
2418                                      gfc_int4_type_node, 5,
2419                                      gfc_charlen_type_node, pchar1_type_node,
2420                                      gfc_charlen_type_node, pchar1_type_node,
2421                                      gfc_logical4_type_node);
2422
2423   gfor_fndecl_string_scan =
2424     gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")),
2425                                      gfc_int4_type_node, 5,
2426                                      gfc_charlen_type_node, pchar1_type_node,
2427                                      gfc_charlen_type_node, pchar1_type_node,
2428                                      gfc_logical4_type_node);
2429
2430   gfor_fndecl_string_verify =
2431     gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")),
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_trim =
2438     gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),
2439                                      void_type_node, 4,
2440                                      build_pointer_type (gfc_charlen_type_node),
2441                                      build_pointer_type (pchar1_type_node),
2442                                      gfc_charlen_type_node, pchar1_type_node);
2443
2444   gfor_fndecl_string_minmax =
2445     gfc_build_library_function_decl (get_identifier (PREFIX("string_minmax")),
2446                                      void_type_node, -4,
2447                                      build_pointer_type (gfc_charlen_type_node),
2448                                      build_pointer_type (pchar1_type_node),
2449                                      integer_type_node, integer_type_node);
2450
2451   gfor_fndecl_adjustl =
2452     gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),
2453                                      void_type_node, 3, pchar1_type_node,
2454                                      gfc_charlen_type_node, pchar1_type_node);
2455
2456   gfor_fndecl_adjustr =
2457     gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")),
2458                                      void_type_node, 3, pchar1_type_node,
2459                                      gfc_charlen_type_node, pchar1_type_node);
2460
2461   gfor_fndecl_select_string =
2462     gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
2463                                      integer_type_node, 4, pvoid_type_node,
2464                                      integer_type_node, pchar1_type_node,
2465                                      gfc_charlen_type_node);
2466
2467   gfor_fndecl_compare_string_char4 =
2468     gfc_build_library_function_decl (get_identifier
2469                                         (PREFIX("compare_string_char4")),
2470                                      integer_type_node, 4,
2471                                      gfc_charlen_type_node, pchar4_type_node,
2472                                      gfc_charlen_type_node, pchar4_type_node);
2473
2474   gfor_fndecl_concat_string_char4 =
2475     gfc_build_library_function_decl (get_identifier
2476                                         (PREFIX("concat_string_char4")),
2477                                      void_type_node, 6,
2478                                      gfc_charlen_type_node, pchar4_type_node,
2479                                      gfc_charlen_type_node, pchar4_type_node,
2480                                      gfc_charlen_type_node, pchar4_type_node);
2481
2482   gfor_fndecl_string_len_trim_char4 =
2483     gfc_build_library_function_decl (get_identifier
2484                                         (PREFIX("string_len_trim_char4")),
2485                                      gfc_charlen_type_node, 2,
2486                                      gfc_charlen_type_node, pchar4_type_node);
2487
2488   gfor_fndecl_string_index_char4 =
2489     gfc_build_library_function_decl (get_identifier
2490                                         (PREFIX("string_index_char4")),
2491                                      gfc_charlen_type_node, 5,
2492                                      gfc_charlen_type_node, pchar4_type_node,
2493                                      gfc_charlen_type_node, pchar4_type_node,
2494                                      gfc_logical4_type_node);
2495
2496   gfor_fndecl_string_scan_char4 =
2497     gfc_build_library_function_decl (get_identifier
2498                                         (PREFIX("string_scan_char4")),
2499                                      gfc_charlen_type_node, 5,
2500                                      gfc_charlen_type_node, pchar4_type_node,
2501                                      gfc_charlen_type_node, pchar4_type_node,
2502                                      gfc_logical4_type_node);
2503
2504   gfor_fndecl_string_verify_char4 =
2505     gfc_build_library_function_decl (get_identifier
2506                                         (PREFIX("string_verify_char4")),
2507                                      gfc_charlen_type_node, 5,
2508                                      gfc_charlen_type_node, pchar4_type_node,
2509                                      gfc_charlen_type_node, pchar4_type_node,
2510                                      gfc_logical4_type_node);
2511
2512   gfor_fndecl_string_trim_char4 =
2513     gfc_build_library_function_decl (get_identifier
2514                                         (PREFIX("string_trim_char4")),
2515                                      void_type_node, 4,
2516                                      build_pointer_type (gfc_charlen_type_node),
2517                                      build_pointer_type (pchar4_type_node),
2518                                      gfc_charlen_type_node, pchar4_type_node);
2519
2520   gfor_fndecl_string_minmax_char4 =
2521     gfc_build_library_function_decl (get_identifier
2522                                         (PREFIX("string_minmax_char4")),
2523                                      void_type_node, -4,
2524                                      build_pointer_type (gfc_charlen_type_node),
2525                                      build_pointer_type (pchar4_type_node),
2526                                      integer_type_node, integer_type_node);
2527
2528   gfor_fndecl_adjustl_char4 =
2529     gfc_build_library_function_decl (get_identifier (PREFIX("adjustl_char4")),
2530                                      void_type_node, 3, pchar4_type_node,
2531                                      gfc_charlen_type_node, pchar4_type_node);
2532
2533   gfor_fndecl_adjustr_char4 =
2534     gfc_build_library_function_decl (get_identifier (PREFIX("adjustr_char4")),
2535                                      void_type_node, 3, pchar4_type_node,
2536                                      gfc_charlen_type_node, pchar4_type_node);
2537
2538   gfor_fndecl_select_string_char4 =
2539     gfc_build_library_function_decl (get_identifier
2540                                         (PREFIX("select_string_char4")),
2541                                      integer_type_node, 4, pvoid_type_node,
2542                                      integer_type_node, pvoid_type_node,
2543                                      gfc_charlen_type_node);
2544
2545
2546   /* Conversion between character kinds.  */
2547
2548   gfor_fndecl_convert_char1_to_char4 =
2549     gfc_build_library_function_decl (get_identifier
2550                                         (PREFIX("convert_char1_to_char4")),
2551                                      void_type_node, 3,
2552                                      build_pointer_type (pchar4_type_node),
2553                                      gfc_charlen_type_node, pchar1_type_node);
2554
2555   gfor_fndecl_convert_char4_to_char1 =
2556     gfc_build_library_function_decl (get_identifier
2557                                         (PREFIX("convert_char4_to_char1")),
2558                                      void_type_node, 3,
2559                                      build_pointer_type (pchar1_type_node),
2560                                      gfc_charlen_type_node, pchar4_type_node);
2561
2562   /* Misc. functions.  */
2563
2564   gfor_fndecl_ttynam =
2565     gfc_build_library_function_decl (get_identifier (PREFIX("ttynam")),
2566                                      void_type_node,
2567                                      3,
2568                                      pchar_type_node,
2569                                      gfc_charlen_type_node,
2570                                      integer_type_node);
2571
2572   gfor_fndecl_fdate =
2573     gfc_build_library_function_decl (get_identifier (PREFIX("fdate")),
2574                                      void_type_node,
2575                                      2,
2576                                      pchar_type_node,
2577                                      gfc_charlen_type_node);
2578
2579   gfor_fndecl_ctime =
2580     gfc_build_library_function_decl (get_identifier (PREFIX("ctime")),
2581                                      void_type_node,
2582                                      3,
2583                                      pchar_type_node,
2584                                      gfc_charlen_type_node,
2585                                      gfc_int8_type_node);
2586
2587   gfor_fndecl_sc_kind =
2588     gfc_build_library_function_decl (get_identifier
2589                                         (PREFIX("selected_char_kind")),
2590                                      gfc_int4_type_node, 2,
2591                                      gfc_charlen_type_node, pchar_type_node);
2592
2593   gfor_fndecl_si_kind =
2594     gfc_build_library_function_decl (get_identifier
2595                                         (PREFIX("selected_int_kind")),
2596                                      gfc_int4_type_node, 1, pvoid_type_node);
2597
2598   gfor_fndecl_sr_kind =
2599     gfc_build_library_function_decl (get_identifier
2600                                         (PREFIX("selected_real_kind")),
2601                                      gfc_int4_type_node, 2,
2602                                      pvoid_type_node, pvoid_type_node);
2603
2604   /* Power functions.  */
2605   {
2606     tree ctype, rtype, itype, jtype;
2607     int rkind, ikind, jkind;
2608 #define NIKINDS 3
2609 #define NRKINDS 4
2610     static int ikinds[NIKINDS] = {4, 8, 16};
2611     static int rkinds[NRKINDS] = {4, 8, 10, 16};
2612     char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */
2613
2614     for (ikind=0; ikind < NIKINDS; ikind++)
2615       {
2616         itype = gfc_get_int_type (ikinds[ikind]);
2617
2618         for (jkind=0; jkind < NIKINDS; jkind++)
2619           {
2620             jtype = gfc_get_int_type (ikinds[jkind]);
2621             if (itype && jtype)
2622               {
2623                 sprintf(name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
2624                         ikinds[jkind]);
2625                 gfor_fndecl_math_powi[jkind][ikind].integer =
2626                   gfc_build_library_function_decl (get_identifier (name),
2627                     jtype, 2, jtype, itype);
2628                 TREE_READONLY (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
2629               }
2630           }
2631
2632         for (rkind = 0; rkind < NRKINDS; rkind ++)
2633           {
2634             rtype = gfc_get_real_type (rkinds[rkind]);
2635             if (rtype && itype)
2636               {
2637                 sprintf(name, PREFIX("pow_r%d_i%d"), rkinds[rkind],
2638                         ikinds[ikind]);
2639                 gfor_fndecl_math_powi[rkind][ikind].real =
2640                   gfc_build_library_function_decl (get_identifier (name),
2641                     rtype, 2, rtype, itype);
2642                 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
2643               }
2644
2645             ctype = gfc_get_complex_type (rkinds[rkind]);
2646             if (ctype && itype)
2647               {
2648                 sprintf(name, PREFIX("pow_c%d_i%d"), rkinds[rkind],
2649                         ikinds[ikind]);
2650                 gfor_fndecl_math_powi[rkind][ikind].cmplx =
2651                   gfc_build_library_function_decl (get_identifier (name),
2652                     ctype, 2,ctype, itype);
2653                 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
2654               }
2655           }
2656       }
2657 #undef NIKINDS
2658 #undef NRKINDS
2659   }
2660
2661   gfor_fndecl_math_ishftc4 =
2662     gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")),
2663                                      gfc_int4_type_node,
2664                                      3, gfc_int4_type_node,
2665                                      gfc_int4_type_node, gfc_int4_type_node);
2666   gfor_fndecl_math_ishftc8 =
2667     gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")),
2668                                      gfc_int8_type_node,
2669                                      3, gfc_int8_type_node,
2670                                      gfc_int4_type_node, gfc_int4_type_node);
2671   if (gfc_int16_type_node)
2672     gfor_fndecl_math_ishftc16 =
2673       gfc_build_library_function_decl (get_identifier (PREFIX("ishftc16")),
2674                                        gfc_int16_type_node, 3,
2675                                        gfc_int16_type_node,
2676                                        gfc_int4_type_node,
2677                                        gfc_int4_type_node);
2678
2679   /* BLAS functions.  */
2680   {
2681     tree pint = build_pointer_type (integer_type_node);
2682     tree ps = build_pointer_type (gfc_get_real_type (gfc_default_real_kind));
2683     tree pd = build_pointer_type (gfc_get_real_type (gfc_default_double_kind));
2684     tree pc = build_pointer_type (gfc_get_complex_type (gfc_default_real_kind));
2685     tree pz = build_pointer_type
2686                 (gfc_get_complex_type (gfc_default_double_kind));
2687
2688     gfor_fndecl_sgemm = gfc_build_library_function_decl
2689                           (get_identifier
2690                              (gfc_option.flag_underscoring ? "sgemm_"
2691                                                            : "sgemm"),
2692                            void_type_node, 15, pchar_type_node,
2693                            pchar_type_node, pint, pint, pint, ps, ps, pint,
2694                            ps, pint, ps, ps, pint, integer_type_node,
2695                            integer_type_node);
2696     gfor_fndecl_dgemm = gfc_build_library_function_decl
2697                           (get_identifier
2698                              (gfc_option.flag_underscoring ? "dgemm_"
2699                                                            : "dgemm"),
2700                            void_type_node, 15, pchar_type_node,
2701                            pchar_type_node, pint, pint, pint, pd, pd, pint,
2702                            pd, pint, pd, pd, pint, integer_type_node,
2703                            integer_type_node);
2704     gfor_fndecl_cgemm = gfc_build_library_function_decl
2705                           (get_identifier
2706                              (gfc_option.flag_underscoring ? "cgemm_"
2707                                                            : "cgemm"),
2708                            void_type_node, 15, pchar_type_node,
2709                            pchar_type_node, pint, pint, pint, pc, pc, pint,
2710                            pc, pint, pc, pc, pint, integer_type_node,
2711                            integer_type_node);
2712     gfor_fndecl_zgemm = gfc_build_library_function_decl
2713                           (get_identifier
2714                              (gfc_option.flag_underscoring ? "zgemm_"
2715                                                            : "zgemm"),
2716                            void_type_node, 15, pchar_type_node,
2717                            pchar_type_node, pint, pint, pint, pz, pz, pint,
2718                            pz, pint, pz, pz, pint, integer_type_node,
2719                            integer_type_node);
2720   }
2721
2722   /* Other functions.  */
2723   gfor_fndecl_size0 =
2724     gfc_build_library_function_decl (get_identifier (PREFIX("size0")),
2725                                      gfc_array_index_type,
2726                                      1, pvoid_type_node);
2727   gfor_fndecl_size1 =
2728     gfc_build_library_function_decl (get_identifier (PREFIX("size1")),
2729                                      gfc_array_index_type,
2730                                      2, pvoid_type_node,
2731                                      gfc_array_index_type);
2732
2733   gfor_fndecl_iargc =
2734     gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),
2735                                      gfc_int4_type_node,
2736                                      0);
2737
2738   if (gfc_type_for_size (128, true))
2739     {
2740       tree uint128 = gfc_type_for_size (128, true);
2741
2742       gfor_fndecl_clz128 =
2743         gfc_build_library_function_decl (get_identifier (PREFIX ("clz128")),
2744                                          integer_type_node, 1, uint128);
2745
2746       gfor_fndecl_ctz128 =
2747         gfc_build_library_function_decl (get_identifier (PREFIX ("ctz128")),
2748                                          integer_type_node, 1, uint128);
2749     }
2750 }
2751
2752
2753 /* Make prototypes for runtime library functions.  */
2754
2755 void
2756 gfc_build_builtin_function_decls (void)
2757 {
2758   tree gfc_int4_type_node = gfc_get_int_type (4);
2759
2760   gfor_fndecl_stop_numeric =
2761     gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
2762                                      void_type_node, 1, gfc_int4_type_node);
2763   /* Stop doesn't return.  */
2764   TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
2765
2766   gfor_fndecl_stop_string =
2767     gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),
2768                                      void_type_node, 2, pchar_type_node,
2769                                      gfc_int4_type_node);
2770   /* Stop doesn't return.  */
2771   TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
2772
2773   gfor_fndecl_error_stop_string =
2774     gfc_build_library_function_decl (get_identifier (PREFIX("error_stop_string")),
2775                                      void_type_node, 2, pchar_type_node,
2776                                      gfc_int4_type_node);
2777   /* ERROR STOP doesn't return.  */
2778   TREE_THIS_VOLATILE (gfor_fndecl_error_stop_string) = 1;
2779
2780   gfor_fndecl_pause_numeric =
2781     gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
2782                                      void_type_node, 1, gfc_int4_type_node);
2783
2784   gfor_fndecl_pause_string =
2785     gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")),
2786                                      void_type_node, 2, pchar_type_node,
2787                                      gfc_int4_type_node);
2788
2789   gfor_fndecl_runtime_error =
2790     gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
2791                                      void_type_node, -1, pchar_type_node);
2792   /* The runtime_error function does not return.  */
2793   TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
2794
2795   gfor_fndecl_runtime_error_at =
2796     gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error_at")),
2797                                      void_type_node, -2, pchar_type_node,
2798                                      pchar_type_node);
2799   /* The runtime_error_at function does not return.  */
2800   TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1;
2801
2802   gfor_fndecl_runtime_warning_at =
2803     gfc_build_library_function_decl (get_identifier (PREFIX("runtime_warning_at")),
2804                                      void_type_node, -2, pchar_type_node,
2805                                      pchar_type_node);
2806   gfor_fndecl_generate_error =
2807     gfc_build_library_function_decl (get_identifier (PREFIX("generate_error")),
2808                                      void_type_node, 3, pvoid_type_node,
2809                                      integer_type_node, pchar_type_node);
2810
2811   gfor_fndecl_os_error =
2812     gfc_build_library_function_decl (get_identifier (PREFIX("os_error")),
2813                                      void_type_node, 1, pchar_type_node);
2814   /* The runtime_error function does not return.  */
2815   TREE_THIS_VOLATILE (gfor_fndecl_os_error) = 1;
2816
2817   gfor_fndecl_set_args =
2818     gfc_build_library_function_decl (get_identifier (PREFIX("set_args")),
2819                                      void_type_node, 2, integer_type_node,
2820                                      build_pointer_type (pchar_type_node));
2821
2822   gfor_fndecl_set_fpe =
2823     gfc_build_library_function_decl (get_identifier (PREFIX("set_fpe")),
2824                                     void_type_node, 1, integer_type_node);
2825
2826   /* Keep the array dimension in sync with the call, later in this file.  */
2827   gfor_fndecl_set_options =
2828     gfc_build_library_function_decl (get_identifier (PREFIX("set_options")),
2829                                     void_type_node, 2, integer_type_node,
2830                                     build_pointer_type (integer_type_node));
2831
2832   gfor_fndecl_set_convert =
2833     gfc_build_library_function_decl (get_identifier (PREFIX("set_convert")),
2834                                      void_type_node, 1, integer_type_node);
2835
2836   gfor_fndecl_set_record_marker =
2837     gfc_build_library_function_decl (get_identifier (PREFIX("set_record_marker")),
2838                                      void_type_node, 1, integer_type_node);
2839
2840   gfor_fndecl_set_max_subrecord_length =
2841     gfc_build_library_function_decl (get_identifier (PREFIX("set_max_subrecord_length")),
2842                                      void_type_node, 1, integer_type_node);
2843
2844   gfor_fndecl_in_pack = gfc_build_library_function_decl_with_spec (
2845         get_identifier (PREFIX("internal_pack")), ".r",
2846         pvoid_type_node, 1, pvoid_type_node);
2847
2848   gfor_fndecl_in_unpack = gfc_build_library_function_decl_with_spec (
2849         get_identifier (PREFIX("internal_unpack")), ".wR",
2850         void_type_node, 2, pvoid_type_node, pvoid_type_node);
2851
2852   gfor_fndecl_associated =
2853     gfc_build_library_function_decl (
2854                                      get_identifier (PREFIX("associated")),
2855                                      integer_type_node, 2, ppvoid_type_node,
2856                                      ppvoid_type_node);
2857
2858   gfc_build_intrinsic_function_decls ();
2859   gfc_build_intrinsic_lib_fndecls ();
2860   gfc_build_io_library_fndecls ();
2861 }
2862
2863
2864 /* Evaluate the length of dummy character variables.  */
2865
2866 static tree
2867 gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl, tree fnbody)
2868 {
2869   stmtblock_t body;
2870
2871   gfc_finish_decl (cl->backend_decl);
2872
2873   gfc_start_block (&body);
2874
2875   /* Evaluate the string length expression.  */
2876   gfc_conv_string_length (cl, NULL, &body);
2877
2878   gfc_trans_vla_type_sizes (sym, &body);
2879
2880   gfc_add_expr_to_block (&body, fnbody);
2881   return gfc_finish_block (&body);
2882 }
2883
2884
2885 /* Allocate and cleanup an automatic character variable.  */
2886
2887 static tree
2888 gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
2889 {
2890   stmtblock_t body;
2891   tree decl;
2892   tree tmp;
2893
2894   gcc_assert (sym->backend_decl);
2895   gcc_assert (sym->ts.u.cl && sym->ts.u.cl->length);
2896
2897   gfc_start_block (&body);
2898
2899   /* Evaluate the string length expression.  */
2900   gfc_conv_string_length (sym->ts.u.cl, NULL, &body);
2901
2902   gfc_trans_vla_type_sizes (sym, &body);
2903
2904   decl = sym->backend_decl;
2905
2906   /* Emit a DECL_EXPR for this variable, which will cause the
2907      gimplifier to allocate storage, and all that good stuff.  */
2908   tmp = fold_build1 (DECL_EXPR, TREE_TYPE (decl), decl);
2909   gfc_add_expr_to_block (&body, tmp);
2910
2911   gfc_add_expr_to_block (&body, fnbody);
2912   return gfc_finish_block (&body);
2913 }
2914
2915 /* Set the initial value of ASSIGN statement auxiliary variable explicitly.  */
2916
2917 static tree
2918 gfc_trans_assign_aux_var (gfc_symbol * sym, tree fnbody)
2919 {
2920   stmtblock_t body;
2921
2922   gcc_assert (sym->backend_decl);
2923   gfc_start_block (&body);
2924
2925   /* Set the initial value to length. See the comments in
2926      function gfc_add_assign_aux_vars in this file.  */
2927   gfc_add_modify (&body, GFC_DECL_STRING_LEN (sym->backend_decl),
2928                        build_int_cst (NULL_TREE, -2));
2929
2930   gfc_add_expr_to_block (&body, fnbody);
2931   return gfc_finish_block (&body);
2932 }
2933
2934 static void
2935 gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body)
2936 {
2937   tree t = *tp, var, val;
2938
2939   if (t == NULL || t == error_mark_node)
2940     return;
2941   if (TREE_CONSTANT (t) || DECL_P (t))
2942     return;
2943
2944   if (TREE_CODE (t) == SAVE_EXPR)
2945     {
2946       if (SAVE_EXPR_RESOLVED_P (t))
2947         {
2948           *tp = TREE_OPERAND (t, 0);
2949           return;
2950         }
2951       val = TREE_OPERAND (t, 0);
2952     }
2953   else
2954     val = t;
2955
2956   var = gfc_create_var_np (TREE_TYPE (t), NULL);
2957   gfc_add_decl_to_function (var);
2958   gfc_add_modify (body, var, val);
2959   if (TREE_CODE (t) == SAVE_EXPR)
2960     TREE_OPERAND (t, 0) = var;
2961   *tp = var;
2962 }
2963
2964 static void
2965 gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
2966 {
2967   tree t;
2968
2969   if (type == NULL || type == error_mark_node)
2970     return;
2971
2972   type = TYPE_MAIN_VARIANT (type);
2973
2974   if (TREE_CODE (type) == INTEGER_TYPE)
2975     {
2976       gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body);
2977       gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body);
2978
2979       for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
2980         {
2981           TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type);
2982           TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type);
2983         }
2984     }
2985   else if (TREE_CODE (type) == ARRAY_TYPE)
2986     {
2987       gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);
2988       gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);
2989       gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body);
2990       gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body);
2991
2992       for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
2993         {
2994           TYPE_SIZE (t) = TYPE_SIZE (type);
2995           TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type);
2996         }
2997     }
2998 }
2999
3000 /* Make sure all type sizes and array domains are either constant,
3001    or variable or parameter decls.  This is a simplified variant
3002    of gimplify_type_sizes, but we can't use it here, as none of the
3003    variables in the expressions have been gimplified yet.
3004    As type sizes and domains for various variable length arrays
3005    contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
3006    time, without this routine gimplify_type_sizes in the middle-end
3007    could result in the type sizes being gimplified earlier than where
3008    those variables are initialized.  */
3009
3010 void
3011 gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
3012 {
3013   tree type = TREE_TYPE (sym->backend_decl);
3014
3015   if (TREE_CODE (type) == FUNCTION_TYPE
3016       && (sym->attr.function || sym->attr.result || sym->attr.entry))
3017     {
3018       if (! current_fake_result_decl)
3019         return;
3020
3021       type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));
3022     }
3023
3024   while (POINTER_TYPE_P (type))
3025     type = TREE_TYPE (type);
3026
3027   if (GFC_DESCRIPTOR_TYPE_P (type))
3028     {
3029       tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
3030
3031       while (POINTER_TYPE_P (etype))
3032         etype = TREE_TYPE (etype);
3033
3034       gfc_trans_vla_type_sizes_1 (etype, body);
3035     }
3036
3037   gfc_trans_vla_type_sizes_1 (type, body);
3038 }
3039
3040
3041 /* Initialize a derived type by building an lvalue from the symbol
3042    and using trans_assignment to do the work. Set dealloc to false
3043    if no deallocation prior the assignment is needed.  */
3044 tree
3045 gfc_init_default_dt (gfc_symbol * sym, tree body, bool dealloc)
3046 {
3047   stmtblock_t fnblock;
3048   gfc_expr *e;
3049   tree tmp;
3050   tree present;
3051
3052   gfc_init_block (&fnblock);
3053   gcc_assert (!sym->attr.allocatable);
3054   gfc_set_sym_referenced (sym);
3055   e = gfc_lval_expr_from_sym (sym);
3056   tmp = gfc_trans_assignment (e, sym->value, false, dealloc);
3057   if (sym->attr.dummy && (sym->attr.optional
3058                           || sym->ns->proc_name->attr.entry_master))
3059     {
3060       present = gfc_conv_expr_present (sym);
3061       tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
3062                     tmp, build_empty_stmt (input_location));
3063     }
3064   gfc_add_expr_to_block (&fnblock, tmp);
3065   gfc_free_expr (e);
3066   if (body)
3067     gfc_add_expr_to_block (&fnblock, body);
3068   return gfc_finish_block (&fnblock);
3069 }
3070
3071
3072 /* Initialize INTENT(OUT) derived type dummies.  As well as giving
3073    them their default initializer, if they do not have allocatable
3074    components, they have their allocatable components deallocated. */
3075
3076 static tree
3077 init_intent_out_dt (gfc_symbol * proc_sym, tree body)
3078 {
3079   stmtblock_t fnblock;
3080   gfc_formal_arglist *f;
3081   tree tmp;
3082   tree present;
3083
3084   gfc_init_block (&fnblock);
3085   for (f = proc_sym->formal; f; f = f->next)
3086     if (f->sym && f->sym->attr.intent == INTENT_OUT
3087         && !f->sym->attr.pointer
3088         && f->sym->ts.type == BT_DERIVED)
3089       {
3090         if (f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value)
3091           {
3092             tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived,
3093                                              f->sym->backend_decl,
3094                                              f->sym->as ? f->sym->as->rank : 0);
3095
3096             if (f->sym->attr.optional
3097                 || f->sym->ns->proc_name->attr.entry_master)
3098               {
3099                 present = gfc_conv_expr_present (f->sym);
3100                 tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
3101                               tmp, build_empty_stmt (input_location));
3102               }
3103
3104             gfc_add_expr_to_block (&fnblock, tmp);
3105           }
3106        else if (f->sym->value)
3107           body = gfc_init_default_dt (f->sym, body, true);
3108       }
3109
3110   gfc_add_expr_to_block (&fnblock, body);
3111   return gfc_finish_block (&fnblock);
3112 }
3113
3114
3115 /* Generate function entry and exit code, and add it to the function body.
3116    This includes:
3117     Allocation and initialization of array variables.
3118     Allocation of character string variables.
3119     Initialization and possibly repacking of dummy arrays.
3120     Initialization of ASSIGN statement auxiliary variable.
3121     Automatic deallocation.  */
3122
3123 tree
3124 gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
3125 {
3126   locus loc;
3127   gfc_symbol *sym;
3128   gfc_formal_arglist *f;
3129   stmtblock_t body;
3130   bool seen_trans_deferred_array = false;
3131
3132   /* Deal with implicit return variables.  Explicit return variables will
3133      already have been added.  */
3134   if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
3135     {
3136       if (!current_fake_result_decl)
3137         {
3138           gfc_entry_list *el = NULL;
3139           if (proc_sym->attr.entry_master)
3140             {
3141               for (el = proc_sym->ns->entries; el; el = el->next)
3142                 if (el->sym != el->sym->result)
3143                   break;
3144             }
3145           /* TODO: move to the appropriate place in resolve.c.  */
3146           if (warn_return_type && el == NULL)
3147             gfc_warning ("Return value of function '%s' at %L not set",
3148                          proc_sym->name, &proc_sym->declared_at);
3149         }
3150       else if (proc_sym->as)
3151         {
3152           tree result = TREE_VALUE (current_fake_result_decl);
3153           fnbody = gfc_trans_dummy_array_bias (proc_sym, result, fnbody);
3154
3155           /* An automatic character length, pointer array result.  */
3156           if (proc_sym->ts.type == BT_CHARACTER
3157                 && TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
3158             fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl,
3159                                                 fnbody);
3160         }
3161       else if (proc_sym->ts.type == BT_CHARACTER)
3162         {
3163           if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
3164             fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl,
3165                                                 fnbody);
3166         }
3167       else
3168         gcc_assert (gfc_option.flag_f2c
3169                     && proc_sym->ts.type == BT_COMPLEX);
3170     }
3171
3172   /* Initialize the INTENT(OUT) derived type dummy arguments.  This
3173      should be done here so that the offsets and lbounds of arrays
3174      are available.  */
3175   fnbody = init_intent_out_dt (proc_sym, fnbody);
3176
3177   for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
3178     {
3179       bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
3180                                    && sym->ts.u.derived->attr.alloc_comp;
3181       if (sym->attr.dimension)
3182         {
3183           switch (sym->as->type)
3184             {
3185             case AS_EXPLICIT:
3186               if (sym->attr.dummy || sym->attr.result)
3187                 fnbody =
3188                   gfc_trans_dummy_array_bias (sym, sym->backend_decl, fnbody);
3189               else if (sym->attr.pointer || sym->attr.allocatable)
3190                 {
3191                   if (TREE_STATIC (sym->backend_decl))
3192                     gfc_trans_static_array_pointer (sym);
3193                   else
3194                     {
3195                       seen_trans_deferred_array = true;
3196                       fnbody = gfc_trans_deferred_array (sym, fnbody);
3197                     }
3198                 }
3199               else
3200                 {
3201                   if (sym_has_alloc_comp)
3202                     {
3203                       seen_trans_deferred_array = true;
3204                       fnbody = gfc_trans_deferred_array (sym, fnbody);
3205                     }
3206                   else if (sym->ts.type == BT_DERIVED
3207                              && sym->value
3208                              && !sym->attr.data
3209                              && sym->attr.save == SAVE_NONE)
3210                     fnbody = gfc_init_default_dt (sym, fnbody, false);
3211
3212                   gfc_get_backend_locus (&loc);
3213                   gfc_set_backend_locus (&sym->declared_at);
3214                   fnbody = gfc_trans_auto_array_allocation (sym->backend_decl,
3215                       sym, fnbody);
3216                   gfc_set_backend_locus (&loc);
3217                 }
3218               break;
3219
3220             case AS_ASSUMED_SIZE:
3221               /* Must be a dummy parameter.  */
3222               gcc_assert (sym->attr.dummy || sym->as->cp_was_assumed);
3223
3224               /* We should always pass assumed size arrays the g77 way.  */
3225               if (sym->attr.dummy)
3226                 fnbody = gfc_trans_g77_array (sym, fnbody);
3227               break;
3228
3229             case AS_ASSUMED_SHAPE:
3230               /* Must be a dummy parameter.  */
3231               gcc_assert (sym->attr.dummy);
3232
3233               fnbody = gfc_trans_dummy_array_bias (sym, sym->backend_decl,
3234                                                    fnbody);
3235               break;
3236
3237             case AS_DEFERRED:
3238               seen_trans_deferred_array = true;
3239               fnbody = gfc_trans_deferred_array (sym, fnbody);
3240               break;
3241
3242             default:
3243               gcc_unreachable ();
3244             }
3245           if (sym_has_alloc_comp && !seen_trans_deferred_array)
3246             fnbody = gfc_trans_deferred_array (sym, fnbody);
3247         }
3248       else if (sym->attr.allocatable
3249                || (sym->ts.type == BT_CLASS
3250                    && sym->ts.u.derived->components->attr.allocatable))
3251         {
3252           if (!sym->attr.save)
3253             {
3254               /* Nullify and automatic deallocation of allocatable
3255                  scalars.  */
3256               tree tmp;
3257               gfc_expr *e;
3258               gfc_se se;
3259               stmtblock_t block;
3260
3261               e = gfc_lval_expr_from_sym (sym);
3262               if (sym->ts.type == BT_CLASS)
3263                 gfc_add_component_ref (e, "$data");
3264
3265               gfc_init_se (&se, NULL);
3266               se.want_pointer = 1;
3267               gfc_conv_expr (&se, e);
3268               gfc_free_expr (e);
3269
3270               /* Nullify when entering the scope.  */
3271               gfc_start_block (&block);
3272               gfc_add_modify (&block, se.expr,
3273                               fold_convert (TREE_TYPE (se.expr),
3274                                             null_pointer_node));
3275               gfc_add_expr_to_block (&block, fnbody);
3276
3277               /* Deallocate when leaving the scope. Nullifying is not
3278                  needed.  */
3279               tmp = gfc_deallocate_with_status (se.expr, NULL_TREE, true,
3280                                                 NULL);
3281               gfc_add_expr_to_block (&block, tmp);
3282               fnbody = gfc_finish_block (&block);
3283             }
3284         }
3285       else if (sym_has_alloc_comp)
3286         fnbody = gfc_trans_deferred_array (sym, fnbody);
3287       else if (sym->ts.type == BT_CHARACTER)
3288         {
3289           gfc_get_backend_locus (&loc);
3290           gfc_set_backend_locus (&sym->declared_at);
3291           if (sym->attr.dummy || sym->attr.result)
3292             fnbody = gfc_trans_dummy_character (sym, sym->ts.u.cl, fnbody);
3293           else
3294             fnbody = gfc_trans_auto_character_variable (sym, fnbody);
3295           gfc_set_backend_locus (&loc);
3296         }
3297       else if (sym->attr.assign)
3298         {
3299           gfc_get_backend_locus (&loc);
3300           gfc_set_backend_locus (&sym->declared_at);
3301           fnbody = gfc_trans_assign_aux_var (sym, fnbody);
3302           gfc_set_backend_locus (&loc);
3303         }
3304       else if (sym->ts.type == BT_DERIVED
3305                  && sym->value
3306                  && !sym->attr.data
3307                  && sym->attr.save == SAVE_NONE)
3308         fnbody = gfc_init_default_dt (sym, fnbody, false);
3309       else
3310         gcc_unreachable ();
3311     }
3312
3313   gfc_init_block (&body);
3314
3315   for (f = proc_sym->formal; f; f = f->next)
3316     {
3317       if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
3318         {
3319           gcc_assert (f->sym->ts.u.cl->backend_decl != NULL);
3320           if (TREE_CODE (f->sym->ts.u.cl->backend_decl) == PARM_DECL)
3321             gfc_trans_vla_type_sizes (f->sym, &body);
3322         }
3323     }
3324
3325   if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
3326       && current_fake_result_decl != NULL)
3327     {
3328       gcc_assert (proc_sym->ts.u.cl->backend_decl != NULL);
3329       if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == PARM_DECL)
3330         gfc_trans_vla_type_sizes (proc_sym, &body);
3331     }
3332
3333   gfc_add_expr_to_block (&body, fnbody);
3334   return gfc_finish_block (&body);
3335 }
3336
3337 static GTY ((param_is (struct module_htab_entry))) htab_t module_htab;
3338
3339 /* Hash and equality functions for module_htab.  */
3340
3341 static hashval_t
3342 module_htab_do_hash (const void *x)
3343 {
3344   return htab_hash_string (((const struct module_htab_entry *)x)->name);
3345 }
3346
3347 static int
3348 module_htab_eq (const void *x1, const void *x2)
3349 {
3350   return strcmp ((((const struct module_htab_entry *)x1)->name),
3351                  (const char *)x2) == 0;
3352 }
3353
3354 /* Hash and equality functions for module_htab's decls.  */
3355
3356 static hashval_t
3357 module_htab_decls_hash (const void *x)
3358 {
3359   const_tree t = (const_tree) x;
3360   const_tree n = DECL_NAME (t);
3361   if (n == NULL_TREE)
3362     n = TYPE_NAME (TREE_TYPE (t));
3363   return htab_hash_string (IDENTIFIER_POINTER (n));
3364 }
3365
3366 static int
3367 module_htab_decls_eq (const void *x1, const void *x2)
3368 {
3369   const_tree t1 = (const_tree) x1;
3370   const_tree n1 = DECL_NAME (t1);
3371   if (n1 == NULL_TREE)
3372     n1 = TYPE_NAME (TREE_TYPE (t1));
3373   return strcmp (IDENTIFIER_POINTER (n1), (const char *) x2) == 0;
3374 }
3375
3376 struct module_htab_entry *
3377 gfc_find_module (const char *name)