gcc/fortran/trans-decl.c

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