gcc/fortran/trans-decl.c

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