gcc/fortran/trans-decl.c

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