OSDN Git Service

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