OSDN Git Service

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