OSDN Git Service

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