gcc/fortran/trans-decl.c

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