gcc/fortran/trans-decl.c

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