OSDN Git Service

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