OSDN Git Service

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