OSDN Git Service

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