gcc/fortran/trans-decl.c

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