OSDN Git Service

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