OSDN Git Service

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