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