gcc/fortran/trans-decl.c

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