OSDN Git Service

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