OSDN Git Service

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