gcc/fortran/trans-decl.c

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