OSDN Git Service

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