OSDN Git Service

2010-09-24 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   /* If use associated and whole file compilation, use the module
1137      declaration.  */
1138   if (gfc_option.flag_whole_file
1139         && sym->attr.flavor == FL_VARIABLE
1140         && sym->attr.use_assoc
1141         && sym->module)
1142     {
1143       gfc_gsymbol *gsym;
1144
1145       gsym =  gfc_find_gsymbol (gfc_gsym_root, sym->module);
1146       if (gsym && gsym->ns && gsym->type == GSYM_MODULE)
1147         {
1148           gfc_symbol *s;
1149           s = NULL;
1150           gfc_find_symbol (sym->name, gsym->ns, 0, &s);
1151           if (s && s->backend_decl)
1152             {
1153               if (sym->ts.type == BT_DERIVED)
1154                 gfc_copy_dt_decls_ifequal (s->ts.u.derived, sym->ts.u.derived,
1155                                            true);
1156               if (sym->ts.type == BT_CHARACTER)
1157                 sym->ts.u.cl->backend_decl = s->ts.u.cl->backend_decl;
1158               sym->backend_decl = s->backend_decl;
1159               return sym->backend_decl;
1160             }
1161         }
1162     }
1163
1164   if (sym->attr.flavor == FL_PROCEDURE)
1165     {
1166       /* Catch function declarations. Only used for actual parameters,
1167          procedure pointers and procptr initialization targets.  */
1168       if (sym->attr.external || sym->attr.use_assoc || sym->attr.intrinsic)
1169         {
1170           decl = gfc_get_extern_function_decl (sym);
1171           gfc_set_decl_location (decl, &sym->declared_at);
1172         }
1173       else
1174         {
1175           if (!sym->backend_decl)
1176             build_function_decl (sym, false);
1177           decl = sym->backend_decl;
1178         }
1179       return decl;
1180     }
1181
1182   if (sym->attr.intrinsic)
1183     internal_error ("intrinsic variable which isn't a procedure");
1184
1185   /* Special case for array-valued named constants from intrinsic
1186      procedures; those are inlined.  */
1187   if (sym->attr.use_assoc && sym->from_intmod && sym->attr.dimension
1188       && sym->attr.flavor == FL_PARAMETER)
1189     intrinsic_array_parameter = true;
1190
1191   /* Create string length decl first so that they can be used in the
1192      type declaration.  */
1193   if (sym->ts.type == BT_CHARACTER)
1194     length = gfc_create_string_length (sym);
1195
1196   /* Create the decl for the variable.  */
1197   decl = build_decl (sym->declared_at.lb->location,
1198                      VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
1199
1200   /* Add attributes to variables.  Functions are handled elsewhere.  */
1201   attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1202   decl_attributes (&decl, attributes, 0);
1203
1204   /* Symbols from modules should have their assembler names mangled.
1205      This is done here rather than in gfc_finish_var_decl because it
1206      is different for string length variables.  */
1207   if (sym->module)
1208     {
1209       gfc_set_decl_assembler_name (decl, gfc_sym_mangled_identifier (sym));
1210       if (sym->attr.use_assoc && !intrinsic_array_parameter)
1211         DECL_IGNORED_P (decl) = 1;
1212     }
1213
1214   if (sym->attr.dimension)
1215     {
1216       /* Create variables to hold the non-constant bits of array info.  */
1217       gfc_build_qualified_array (decl, sym);
1218
1219       if (sym->attr.contiguous
1220           || ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer))
1221         GFC_DECL_PACKED_ARRAY (decl) = 1;
1222     }
1223
1224   /* Remember this variable for allocation/cleanup.  */
1225   if (sym->attr.dimension || sym->attr.allocatable
1226       || (sym->ts.type == BT_CLASS &&
1227           (CLASS_DATA (sym)->attr.dimension
1228            || CLASS_DATA (sym)->attr.allocatable))
1229       || (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
1230       /* This applies a derived type default initializer.  */
1231       || (sym->ts.type == BT_DERIVED
1232           && sym->attr.save == SAVE_NONE
1233           && !sym->attr.data
1234           && !sym->attr.allocatable
1235           && (sym->value && !sym->ns->proc_name->attr.is_main_program)
1236           && !(sym->attr.use_assoc && !intrinsic_array_parameter)))
1237     gfc_defer_symbol_init (sym);
1238
1239   gfc_finish_var_decl (decl, sym);
1240
1241   if (sym->ts.type == BT_CHARACTER)
1242     {
1243       /* Character variables need special handling.  */
1244       gfc_allocate_lang_decl (decl);
1245
1246       if (TREE_CODE (length) != INTEGER_CST)
1247         {
1248           char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
1249
1250           if (sym->module)
1251             {
1252               /* Also prefix the mangled name for symbols from modules.  */
1253               strcpy (&name[1], sym->name);
1254               name[0] = '.';
1255               strcpy (&name[1],
1256                       IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length)));
1257               gfc_set_decl_assembler_name (decl, get_identifier (name));
1258             }
1259           gfc_finish_var_decl (length, sym);
1260           gcc_assert (!sym->value);
1261         }
1262     }
1263   else if (sym->attr.subref_array_pointer)
1264     {
1265       /* We need the span for these beasts.  */
1266       gfc_allocate_lang_decl (decl);
1267     }
1268
1269   if (sym->attr.subref_array_pointer)
1270     {
1271       tree span;
1272       GFC_DECL_SUBREF_ARRAY_P (decl) = 1;
1273       span = build_decl (input_location,
1274                          VAR_DECL, create_tmp_var_name ("span"),
1275                          gfc_array_index_type);
1276       gfc_finish_var_decl (span, sym);
1277       TREE_STATIC (span) = TREE_STATIC (decl);
1278       DECL_ARTIFICIAL (span) = 1;
1279       DECL_INITIAL (span) = build_int_cst (gfc_array_index_type, 0);
1280
1281       GFC_DECL_SPAN (decl) = span;
1282       GFC_TYPE_ARRAY_SPAN (TREE_TYPE (decl)) = span;
1283     }
1284
1285   sym->backend_decl = decl;
1286
1287   if (sym->attr.assign)
1288     gfc_add_assign_aux_vars (sym);
1289
1290   if (intrinsic_array_parameter)
1291     {
1292       TREE_STATIC (decl) = 1;
1293       DECL_EXTERNAL (decl) = 0;
1294     }
1295
1296   if (TREE_STATIC (decl)
1297       && !(sym->attr.use_assoc && !intrinsic_array_parameter)
1298       && (sym->attr.save || sym->ns->proc_name->attr.is_main_program
1299           || gfc_option.flag_max_stack_var_size == 0
1300           || sym->attr.data || sym->ns->proc_name->attr.flavor == FL_MODULE))
1301     {
1302       /* Add static initializer. For procedures, it is only needed if
1303          SAVE is specified otherwise they need to be reinitialized
1304          every time the procedure is entered. The TREE_STATIC is
1305          in this case due to -fmax-stack-var-size=.  */
1306       DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1307                                                   TREE_TYPE (decl),
1308                                                   sym->attr.dimension,
1309                                                   sym->attr.pointer
1310                                                   || sym->attr.allocatable,
1311                                                   sym->attr.proc_pointer);
1312     }
1313
1314   if (!TREE_STATIC (decl)
1315       && POINTER_TYPE_P (TREE_TYPE (decl))
1316       && !sym->attr.pointer
1317       && !sym->attr.allocatable
1318       && !sym->attr.proc_pointer)
1319     DECL_BY_REFERENCE (decl) = 1;
1320
1321   return decl;
1322 }
1323
1324
1325 /* Substitute a temporary variable in place of the real one.  */
1326
1327 void
1328 gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
1329 {
1330   save->attr = sym->attr;
1331   save->decl = sym->backend_decl;
1332
1333   gfc_clear_attr (&sym->attr);
1334   sym->attr.referenced = 1;
1335   sym->attr.flavor = FL_VARIABLE;
1336
1337   sym->backend_decl = decl;
1338 }
1339
1340
1341 /* Restore the original variable.  */
1342
1343 void
1344 gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
1345 {
1346   sym->attr = save->attr;
1347   sym->backend_decl = save->decl;
1348 }
1349
1350
1351 /* Declare a procedure pointer.  */
1352
1353 static tree
1354 get_proc_pointer_decl (gfc_symbol *sym)
1355 {
1356   tree decl;
1357   tree attributes;
1358
1359   decl = sym->backend_decl;
1360   if (decl)
1361     return decl;
1362
1363   decl = build_decl (input_location,
1364                      VAR_DECL, get_identifier (sym->name),
1365                      build_pointer_type (gfc_get_function_type (sym)));
1366
1367   if ((sym->ns->proc_name
1368       && sym->ns->proc_name->backend_decl == current_function_decl)
1369       || sym->attr.contained)
1370     gfc_add_decl_to_function (decl);
1371   else if (sym->ns->proc_name->attr.flavor != FL_MODULE)
1372     gfc_add_decl_to_parent_function (decl);
1373
1374   sym->backend_decl = decl;
1375
1376   /* If a variable is USE associated, it's always external.  */
1377   if (sym->attr.use_assoc)
1378     {
1379       DECL_EXTERNAL (decl) = 1;
1380       TREE_PUBLIC (decl) = 1;
1381     }
1382   else if (sym->module && sym->ns->proc_name->attr.flavor == FL_MODULE)
1383     {
1384       /* This is the declaration of a module variable.  */
1385       TREE_PUBLIC (decl) = 1;
1386       TREE_STATIC (decl) = 1;
1387     }
1388
1389   if (!sym->attr.use_assoc
1390         && (sym->attr.save != SAVE_NONE || sym->attr.data
1391               || (sym->value && sym->ns->proc_name->attr.is_main_program)))
1392     TREE_STATIC (decl) = 1;
1393
1394   if (TREE_STATIC (decl) && sym->value)
1395     {
1396       /* Add static initializer.  */
1397       DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1398                                                   TREE_TYPE (decl),
1399                                                   sym->attr.dimension,
1400                                                   false, true);
1401     }
1402
1403   attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1404   decl_attributes (&decl, attributes, 0);
1405
1406   return decl;
1407 }
1408
1409
1410 /* Get a basic decl for an external function.  */
1411
1412 tree
1413 gfc_get_extern_function_decl (gfc_symbol * sym)
1414 {
1415   tree type;
1416   tree fndecl;
1417   tree attributes;
1418   gfc_expr e;
1419   gfc_intrinsic_sym *isym;
1420   gfc_expr argexpr;
1421   char s[GFC_MAX_SYMBOL_LEN + 23]; /* "_gfortran_f2c_specific" and '\0'.  */
1422   tree name;
1423   tree mangled_name;
1424   gfc_gsymbol *gsym;
1425
1426   if (sym->backend_decl)
1427     return sym->backend_decl;
1428
1429   /* We should never be creating external decls for alternate entry points.
1430      The procedure may be an alternate entry point, but we don't want/need
1431      to know that.  */
1432   gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
1433
1434   if (sym->attr.proc_pointer)
1435     return get_proc_pointer_decl (sym);
1436
1437   /* See if this is an external procedure from the same file.  If so,
1438      return the backend_decl.  */
1439   gsym =  gfc_find_gsymbol (gfc_gsym_root, sym->name);
1440
1441   if (gfc_option.flag_whole_file
1442         && (!sym->attr.use_assoc || sym->attr.if_source != IFSRC_DECL)
1443         && !sym->backend_decl
1444         && gsym && gsym->ns
1445         && ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION))
1446         && (gsym->ns->proc_name->backend_decl || !sym->attr.intrinsic))
1447     {
1448       if (!gsym->ns->proc_name->backend_decl)
1449         {
1450           /* By construction, the external function cannot be
1451              a contained procedure.  */
1452           locus old_loc;
1453           tree save_fn_decl = current_function_decl;
1454
1455           current_function_decl = NULL_TREE;
1456           gfc_get_backend_locus (&old_loc);
1457           push_cfun (cfun);
1458
1459           gfc_create_function_decl (gsym->ns, true);
1460
1461           pop_cfun ();
1462           gfc_set_backend_locus (&old_loc);
1463           current_function_decl = save_fn_decl;
1464         }
1465
1466       /* If the namespace has entries, the proc_name is the
1467          entry master.  Find the entry and use its backend_decl.
1468          otherwise, use the proc_name backend_decl.  */
1469       if (gsym->ns->entries)
1470         {
1471           gfc_entry_list *entry = gsym->ns->entries;
1472
1473           for (; entry; entry = entry->next)
1474             {
1475               if (strcmp (gsym->name, entry->sym->name) == 0)
1476                 {
1477                   sym->backend_decl = entry->sym->backend_decl;
1478                   break;
1479                 }
1480             }
1481         }
1482       else
1483         sym->backend_decl = gsym->ns->proc_name->backend_decl;
1484
1485       if (sym->backend_decl)
1486         {
1487           /* Avoid problems of double deallocation of the backend declaration
1488              later in gfc_trans_use_stmts; cf. PR 45087.  */
1489           if (sym->attr.if_source != IFSRC_DECL && sym->attr.use_assoc)
1490             sym->attr.use_assoc = 0;
1491
1492           return sym->backend_decl;
1493         }
1494     }
1495
1496   /* See if this is a module procedure from the same file.  If so,
1497      return the backend_decl.  */
1498   if (sym->module)
1499     gsym =  gfc_find_gsymbol (gfc_gsym_root, sym->module);
1500
1501   if (gfc_option.flag_whole_file
1502         && gsym && gsym->ns
1503         && gsym->type == GSYM_MODULE)
1504     {
1505       gfc_symbol *s;
1506
1507       s = NULL;
1508       gfc_find_symbol (sym->name, gsym->ns, 0, &s);
1509       if (s && s->backend_decl)
1510         {
1511           sym->backend_decl = s->backend_decl;
1512           return sym->backend_decl;
1513         }
1514     }
1515
1516   if (sym->attr.intrinsic)
1517     {
1518       /* Call the resolution function to get the actual name.  This is
1519          a nasty hack which relies on the resolution functions only looking
1520          at the first argument.  We pass NULL for the second argument
1521          otherwise things like AINT get confused.  */
1522       isym = gfc_find_function (sym->name);
1523       gcc_assert (isym->resolve.f0 != NULL);
1524
1525       memset (&e, 0, sizeof (e));
1526       e.expr_type = EXPR_FUNCTION;
1527
1528       memset (&argexpr, 0, sizeof (argexpr));
1529       gcc_assert (isym->formal);
1530       argexpr.ts = isym->formal->ts;
1531
1532       if (isym->formal->next == NULL)
1533         isym->resolve.f1 (&e, &argexpr);
1534       else
1535         {
1536           if (isym->formal->next->next == NULL)
1537             isym->resolve.f2 (&e, &argexpr, NULL);
1538           else
1539             {
1540               if (isym->formal->next->next->next == NULL)
1541                 isym->resolve.f3 (&e, &argexpr, NULL, NULL);
1542               else
1543                 {
1544                   /* All specific intrinsics take less than 5 arguments.  */
1545                   gcc_assert (isym->formal->next->next->next->next == NULL);
1546                   isym->resolve.f4 (&e, &argexpr, NULL, NULL, NULL);
1547                 }
1548             }
1549         }
1550
1551       if (gfc_option.flag_f2c
1552           && ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)
1553               || e.ts.type == BT_COMPLEX))
1554         {
1555           /* Specific which needs a different implementation if f2c
1556              calling conventions are used.  */
1557           sprintf (s, "_gfortran_f2c_specific%s", e.value.function.name);
1558         }
1559       else
1560         sprintf (s, "_gfortran_specific%s", e.value.function.name);
1561
1562       name = get_identifier (s);
1563       mangled_name = name;
1564     }
1565   else
1566     {
1567       name = gfc_sym_identifier (sym);
1568       mangled_name = gfc_sym_mangled_function_id (sym);
1569     }
1570
1571   type = gfc_get_function_type (sym);
1572   fndecl = build_decl (input_location,
1573                        FUNCTION_DECL, name, type);
1574
1575   attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1576   decl_attributes (&fndecl, attributes, 0);
1577
1578   gfc_set_decl_assembler_name (fndecl, mangled_name);
1579
1580   /* Set the context of this decl.  */
1581   if (0 && sym->ns && sym->ns->proc_name)
1582     {
1583       /* TODO: Add external decls to the appropriate scope.  */
1584       DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
1585     }
1586   else
1587     {
1588       /* Global declaration, e.g. intrinsic subroutine.  */
1589       DECL_CONTEXT (fndecl) = NULL_TREE;
1590     }
1591
1592   DECL_EXTERNAL (fndecl) = 1;
1593
1594   /* This specifies if a function is globally addressable, i.e. it is
1595      the opposite of declaring static in C.  */
1596   TREE_PUBLIC (fndecl) = 1;
1597
1598   /* Set attributes for PURE functions. A call to PURE function in the
1599      Fortran 95 sense is both pure and without side effects in the C
1600      sense.  */
1601   if (sym->attr.pure || sym->attr.elemental)
1602     {
1603       if (sym->attr.function && !gfc_return_by_reference (sym))
1604         DECL_PURE_P (fndecl) = 1;
1605       /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
1606          parameters and don't use alternate returns (is this
1607          allowed?). In that case, calls to them are meaningless, and
1608          can be optimized away. See also in build_function_decl().  */
1609       TREE_SIDE_EFFECTS (fndecl) = 0;
1610     }
1611
1612   /* Mark non-returning functions.  */
1613   if (sym->attr.noreturn)
1614       TREE_THIS_VOLATILE(fndecl) = 1;
1615
1616   sym->backend_decl = fndecl;
1617
1618   if (DECL_CONTEXT (fndecl) == NULL_TREE)
1619     pushdecl_top_level (fndecl);
1620
1621   return fndecl;
1622 }
1623
1624
1625 /* Create a declaration for a procedure.  For external functions (in the C
1626    sense) use gfc_get_extern_function_decl.  HAS_ENTRIES is true if this is
1627    a master function with alternate entry points.  */
1628
1629 static void
1630 build_function_decl (gfc_symbol * sym, bool global)
1631 {
1632   tree fndecl, type, attributes;
1633   symbol_attribute attr;
1634   tree result_decl;
1635   gfc_formal_arglist *f;
1636
1637   gcc_assert (!sym->attr.external);
1638
1639   if (sym->backend_decl)
1640     return;
1641
1642   /* Set the line and filename.  sym->declared_at seems to point to the
1643      last statement for subroutines, but it'll do for now.  */
1644   gfc_set_backend_locus (&sym->declared_at);
1645
1646   /* Allow only one nesting level.  Allow public declarations.  */
1647   gcc_assert (current_function_decl == NULL_TREE
1648               || DECL_CONTEXT (current_function_decl) == NULL_TREE
1649               || TREE_CODE (DECL_CONTEXT (current_function_decl))
1650                  == NAMESPACE_DECL);
1651
1652   type = gfc_get_function_type (sym);
1653   fndecl = build_decl (input_location,
1654                        FUNCTION_DECL, gfc_sym_identifier (sym), type);
1655
1656   attr = sym->attr;
1657
1658   attributes = add_attributes_to_decl (attr, NULL_TREE);
1659   decl_attributes (&fndecl, attributes, 0);
1660
1661   /* Perform name mangling if this is a top level or module procedure.  */
1662   if (current_function_decl == NULL_TREE)
1663     gfc_set_decl_assembler_name (fndecl, gfc_sym_mangled_function_id (sym));
1664
1665   /* Figure out the return type of the declared function, and build a
1666      RESULT_DECL for it.  If this is a subroutine with alternate
1667      returns, build a RESULT_DECL for it.  */
1668   result_decl = NULL_TREE;
1669   /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)).  */
1670   if (attr.function)
1671     {
1672       if (gfc_return_by_reference (sym))
1673         type = void_type_node;
1674       else
1675         {
1676           if (sym->result != sym)
1677             result_decl = gfc_sym_identifier (sym->result);
1678
1679           type = TREE_TYPE (TREE_TYPE (fndecl));
1680         }
1681     }
1682   else
1683     {
1684       /* Look for alternate return placeholders.  */
1685       int has_alternate_returns = 0;
1686       for (f = sym->formal; f; f = f->next)
1687         {
1688           if (f->sym == NULL)
1689             {
1690               has_alternate_returns = 1;
1691               break;
1692             }
1693         }
1694
1695       if (has_alternate_returns)
1696         type = integer_type_node;
1697       else
1698         type = void_type_node;
1699     }
1700
1701   result_decl = build_decl (input_location,
1702                             RESULT_DECL, result_decl, type);
1703   DECL_ARTIFICIAL (result_decl) = 1;
1704   DECL_IGNORED_P (result_decl) = 1;
1705   DECL_CONTEXT (result_decl) = fndecl;
1706   DECL_RESULT (fndecl) = result_decl;
1707
1708   /* Don't call layout_decl for a RESULT_DECL.
1709      layout_decl (result_decl, 0);  */
1710
1711   /* Set up all attributes for the function.  */
1712   DECL_CONTEXT (fndecl) = current_function_decl;
1713   DECL_EXTERNAL (fndecl) = 0;
1714
1715   /* This specifies if a function is globally visible, i.e. it is
1716      the opposite of declaring static in C.  */
1717   if (DECL_CONTEXT (fndecl) == NULL_TREE
1718       && !sym->attr.entry_master && !sym->attr.is_main_program)
1719     TREE_PUBLIC (fndecl) = 1;
1720
1721   /* TREE_STATIC means the function body is defined here.  */
1722   TREE_STATIC (fndecl) = 1;
1723
1724   /* Set attributes for PURE functions. A call to a PURE function in the
1725      Fortran 95 sense is both pure and without side effects in the C
1726      sense.  */
1727   if (attr.pure || attr.elemental)
1728     {
1729       /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
1730          including an alternate return. In that case it can also be
1731          marked as PURE. See also in gfc_get_extern_function_decl().  */
1732       if (attr.function && !gfc_return_by_reference (sym))
1733         DECL_PURE_P (fndecl) = 1;
1734       TREE_SIDE_EFFECTS (fndecl) = 0;
1735     }
1736
1737
1738   /* Layout the function declaration and put it in the binding level
1739      of the current function.  */
1740
1741   if (global)
1742     pushdecl_top_level (fndecl);
1743   else
1744     pushdecl (fndecl);
1745
1746   sym->backend_decl = fndecl;
1747 }
1748
1749
1750 /* Create the DECL_ARGUMENTS for a procedure.  */
1751
1752 static void
1753 create_function_arglist (gfc_symbol * sym)
1754 {
1755   tree fndecl;
1756   gfc_formal_arglist *f;
1757   tree typelist, hidden_typelist;
1758   tree arglist, hidden_arglist;
1759   tree type;
1760   tree parm;
1761
1762   fndecl = sym->backend_decl;
1763
1764   /* Build formal argument list. Make sure that their TREE_CONTEXT is
1765      the new FUNCTION_DECL node.  */
1766   arglist = NULL_TREE;
1767   hidden_arglist = NULL_TREE;
1768   typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
1769
1770   if (sym->attr.entry_master)
1771     {
1772       type = TREE_VALUE (typelist);
1773       parm = build_decl (input_location,
1774                          PARM_DECL, get_identifier ("__entry"), type);
1775       
1776       DECL_CONTEXT (parm) = fndecl;
1777       DECL_ARG_TYPE (parm) = type;
1778       TREE_READONLY (parm) = 1;
1779       gfc_finish_decl (parm);
1780       DECL_ARTIFICIAL (parm) = 1;
1781
1782       arglist = chainon (arglist, parm);
1783       typelist = TREE_CHAIN (typelist);
1784     }
1785
1786   if (gfc_return_by_reference (sym))
1787     {
1788       tree type = TREE_VALUE (typelist), length = NULL;
1789
1790       if (sym->ts.type == BT_CHARACTER)
1791         {
1792           /* Length of character result.  */
1793           tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
1794           gcc_assert (len_type == gfc_charlen_type_node);
1795
1796           length = build_decl (input_location,
1797                                PARM_DECL,
1798                                get_identifier (".__result"),
1799                                len_type);
1800           if (!sym->ts.u.cl->length)
1801             {
1802               sym->ts.u.cl->backend_decl = length;
1803               TREE_USED (length) = 1;
1804             }
1805           gcc_assert (TREE_CODE (length) == PARM_DECL);
1806           DECL_CONTEXT (length) = fndecl;
1807           DECL_ARG_TYPE (length) = len_type;
1808           TREE_READONLY (length) = 1;
1809           DECL_ARTIFICIAL (length) = 1;
1810           gfc_finish_decl (length);
1811           if (sym->ts.u.cl->backend_decl == NULL
1812               || sym->ts.u.cl->backend_decl == length)
1813             {
1814               gfc_symbol *arg;
1815               tree backend_decl;
1816
1817               if (sym->ts.u.cl->backend_decl == NULL)
1818                 {
1819                   tree len = build_decl (input_location,
1820                                          VAR_DECL,
1821                                          get_identifier ("..__result"),
1822                                          gfc_charlen_type_node);
1823                   DECL_ARTIFICIAL (len) = 1;
1824                   TREE_USED (len) = 1;
1825                   sym->ts.u.cl->backend_decl = len;
1826                 }
1827
1828               /* Make sure PARM_DECL type doesn't point to incomplete type.  */
1829               arg = sym->result ? sym->result : sym;
1830               backend_decl = arg->backend_decl;
1831               /* Temporary clear it, so that gfc_sym_type creates complete
1832                  type.  */
1833               arg->backend_decl = NULL;
1834               type = gfc_sym_type (arg);
1835               arg->backend_decl = backend_decl;
1836               type = build_reference_type (type);
1837             }
1838         }
1839
1840       parm = build_decl (input_location,
1841                          PARM_DECL, get_identifier ("__result"), type);
1842
1843       DECL_CONTEXT (parm) = fndecl;
1844       DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1845       TREE_READONLY (parm) = 1;
1846       DECL_ARTIFICIAL (parm) = 1;
1847       gfc_finish_decl (parm);
1848
1849       arglist = chainon (arglist, parm);
1850       typelist = TREE_CHAIN (typelist);
1851
1852       if (sym->ts.type == BT_CHARACTER)
1853         {
1854           gfc_allocate_lang_decl (parm);
1855           arglist = chainon (arglist, length);
1856           typelist = TREE_CHAIN (typelist);
1857         }
1858     }
1859
1860   hidden_typelist = typelist;
1861   for (f = sym->formal; f; f = f->next)
1862     if (f->sym != NULL) /* Ignore alternate returns.  */
1863       hidden_typelist = TREE_CHAIN (hidden_typelist);
1864
1865   for (f = sym->formal; f; f = f->next)
1866     {
1867       char name[GFC_MAX_SYMBOL_LEN + 2];
1868
1869       /* Ignore alternate returns.  */
1870       if (f->sym == NULL)
1871         continue;
1872
1873       type = TREE_VALUE (typelist);
1874
1875       if (f->sym->ts.type == BT_CHARACTER
1876           && (!sym->attr.is_bind_c || sym->attr.entry_master))
1877         {
1878           tree len_type = TREE_VALUE (hidden_typelist);
1879           tree length = NULL_TREE;
1880           gcc_assert (len_type == gfc_charlen_type_node);
1881
1882           strcpy (&name[1], f->sym->name);
1883           name[0] = '_';
1884           length = build_decl (input_location,
1885                                PARM_DECL, get_identifier (name), len_type);
1886
1887           hidden_arglist = chainon (hidden_arglist, length);
1888           DECL_CONTEXT (length) = fndecl;
1889           DECL_ARTIFICIAL (length) = 1;
1890           DECL_ARG_TYPE (length) = len_type;
1891           TREE_READONLY (length) = 1;
1892           gfc_finish_decl (length);
1893
1894           /* Remember the passed value.  */
1895           if (f->sym->ts.u.cl->passed_length != NULL)
1896             {
1897               /* This can happen if the same type is used for multiple
1898                  arguments. We need to copy cl as otherwise
1899                  cl->passed_length gets overwritten.  */
1900               f->sym->ts.u.cl = gfc_new_charlen (f->sym->ns, f->sym->ts.u.cl);
1901             }
1902           f->sym->ts.u.cl->passed_length = length;
1903
1904           /* Use the passed value for assumed length variables.  */
1905           if (!f->sym->ts.u.cl->length)
1906             {
1907               TREE_USED (length) = 1;
1908               gcc_assert (!f->sym->ts.u.cl->backend_decl);
1909               f->sym->ts.u.cl->backend_decl = length;
1910             }
1911
1912           hidden_typelist = TREE_CHAIN (hidden_typelist);
1913
1914           if (f->sym->ts.u.cl->backend_decl == NULL
1915               || f->sym->ts.u.cl->backend_decl == length)
1916             {
1917               if (f->sym->ts.u.cl->backend_decl == NULL)
1918                 gfc_create_string_length (f->sym);
1919
1920               /* Make sure PARM_DECL type doesn't point to incomplete type.  */
1921               if (f->sym->attr.flavor == FL_PROCEDURE)
1922                 type = build_pointer_type (gfc_get_function_type (f->sym));
1923               else
1924                 type = gfc_sym_type (f->sym);
1925             }
1926         }
1927
1928       /* For non-constant length array arguments, make sure they use
1929          a different type node from TYPE_ARG_TYPES type.  */
1930       if (f->sym->attr.dimension
1931           && type == TREE_VALUE (typelist)
1932           && TREE_CODE (type) == POINTER_TYPE
1933           && GFC_ARRAY_TYPE_P (type)
1934           && f->sym->as->type != AS_ASSUMED_SIZE
1935           && ! COMPLETE_TYPE_P (TREE_TYPE (type)))
1936         {
1937           if (f->sym->attr.flavor == FL_PROCEDURE)
1938             type = build_pointer_type (gfc_get_function_type (f->sym));
1939           else
1940             type = gfc_sym_type (f->sym);
1941         }
1942
1943       if (f->sym->attr.proc_pointer)
1944         type = build_pointer_type (type);
1945
1946       /* Build the argument declaration.  */
1947       parm = build_decl (input_location,
1948                          PARM_DECL, gfc_sym_identifier (f->sym), type);
1949
1950       /* Fill in arg stuff.  */
1951       DECL_CONTEXT (parm) = fndecl;
1952       DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1953       /* All implementation args are read-only.  */
1954       TREE_READONLY (parm) = 1;
1955       if (POINTER_TYPE_P (type)
1956           && (!f->sym->attr.proc_pointer
1957               && f->sym->attr.flavor != FL_PROCEDURE))
1958         DECL_BY_REFERENCE (parm) = 1;
1959
1960       gfc_finish_decl (parm);
1961
1962       f->sym->backend_decl = parm;
1963
1964       arglist = chainon (arglist, parm);
1965       typelist = TREE_CHAIN (typelist);
1966     }
1967
1968   /* Add the hidden string length parameters, unless the procedure
1969      is bind(C).  */
1970   if (!sym->attr.is_bind_c)
1971     arglist = chainon (arglist, hidden_arglist);
1972
1973   gcc_assert (hidden_typelist == NULL_TREE
1974               || TREE_VALUE (hidden_typelist) == void_type_node);
1975   DECL_ARGUMENTS (fndecl) = arglist;
1976 }
1977
1978 /* Do the setup necessary before generating the body of a function.  */
1979
1980 static void
1981 trans_function_start (gfc_symbol * sym)
1982 {
1983   tree fndecl;
1984
1985   fndecl = sym->backend_decl;
1986
1987   /* Let GCC know the current scope is this function.  */
1988   current_function_decl = fndecl;
1989
1990   /* Let the world know what we're about to do.  */
1991   announce_function (fndecl);
1992
1993   if (DECL_CONTEXT (fndecl) == NULL_TREE)
1994     {
1995       /* Create RTL for function declaration.  */
1996       rest_of_decl_compilation (fndecl, 1, 0);
1997     }
1998
1999   /* Create RTL for function definition.  */
2000   make_decl_rtl (fndecl);
2001
2002   init_function_start (fndecl);
2003
2004   /* Even though we're inside a function body, we still don't want to
2005      call expand_expr to calculate the size of a variable-sized array.
2006      We haven't necessarily assigned RTL to all variables yet, so it's
2007      not safe to try to expand expressions involving them.  */
2008   cfun->dont_save_pending_sizes_p = 1;
2009
2010   /* function.c requires a push at the start of the function.  */
2011   pushlevel (0);
2012 }
2013
2014 /* Create thunks for alternate entry points.  */
2015
2016 static void
2017 build_entry_thunks (gfc_namespace * ns, bool global)
2018 {
2019   gfc_formal_arglist *formal;
2020   gfc_formal_arglist *thunk_formal;
2021   gfc_entry_list *el;
2022   gfc_symbol *thunk_sym;
2023   stmtblock_t body;
2024   tree thunk_fndecl;
2025   tree tmp;
2026   locus old_loc;
2027
2028   /* This should always be a toplevel function.  */
2029   gcc_assert (current_function_decl == NULL_TREE);
2030
2031   gfc_get_backend_locus (&old_loc);
2032   for (el = ns->entries; el; el = el->next)
2033     {
2034       VEC(tree,gc) *args = NULL;
2035       VEC(tree,gc) *string_args = NULL;
2036
2037       thunk_sym = el->sym;
2038       
2039       build_function_decl (thunk_sym, global);
2040       create_function_arglist (thunk_sym);
2041
2042       trans_function_start (thunk_sym);
2043
2044       thunk_fndecl = thunk_sym->backend_decl;
2045
2046       gfc_init_block (&body);
2047
2048       /* Pass extra parameter identifying this entry point.  */
2049       tmp = build_int_cst (gfc_array_index_type, el->id);
2050       VEC_safe_push (tree, gc, args, tmp);
2051
2052       if (thunk_sym->attr.function)
2053         {
2054           if (gfc_return_by_reference (ns->proc_name))
2055             {
2056               tree ref = DECL_ARGUMENTS (current_function_decl);
2057               VEC_safe_push (tree, gc, args, ref);
2058               if (ns->proc_name->ts.type == BT_CHARACTER)
2059                 VEC_safe_push (tree, gc, args, DECL_CHAIN (ref));
2060             }
2061         }
2062
2063       for (formal = ns->proc_name->formal; formal; formal = formal->next)
2064         {
2065           /* Ignore alternate returns.  */
2066           if (formal->sym == NULL)
2067             continue;
2068
2069           /* We don't have a clever way of identifying arguments, so resort to
2070              a brute-force search.  */
2071           for (thunk_formal = thunk_sym->formal;
2072                thunk_formal;
2073                thunk_formal = thunk_formal->next)
2074             {
2075               if (thunk_formal->sym == formal->sym)
2076                 break;
2077             }
2078
2079           if (thunk_formal)
2080             {
2081               /* Pass the argument.  */
2082               DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1;
2083               VEC_safe_push (tree, gc, args, thunk_formal->sym->backend_decl);
2084               if (formal->sym->ts.type == BT_CHARACTER)
2085                 {
2086                   tmp = thunk_formal->sym->ts.u.cl->backend_decl;
2087                   VEC_safe_push (tree, gc, string_args, tmp);
2088                 }
2089             }
2090           else
2091             {
2092               /* Pass NULL for a missing argument.  */
2093               VEC_safe_push (tree, gc, args, null_pointer_node);
2094               if (formal->sym->ts.type == BT_CHARACTER)
2095                 {
2096                   tmp = build_int_cst (gfc_charlen_type_node, 0);
2097                   VEC_safe_push (tree, gc, string_args, tmp);
2098                 }
2099             }
2100         }
2101
2102       /* Call the master function.  */
2103       VEC_safe_splice (tree, gc, args, string_args);
2104       tmp = ns->proc_name->backend_decl;
2105       tmp = build_call_expr_loc_vec (input_location, tmp, args);
2106       if (ns->proc_name->attr.mixed_entry_master)
2107         {
2108           tree union_decl, field;
2109           tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
2110
2111           union_decl = build_decl (input_location,
2112                                    VAR_DECL, get_identifier ("__result"),
2113                                    TREE_TYPE (master_type));
2114           DECL_ARTIFICIAL (union_decl) = 1;
2115           DECL_EXTERNAL (union_decl) = 0;
2116           TREE_PUBLIC (union_decl) = 0;
2117           TREE_USED (union_decl) = 1;
2118           layout_decl (union_decl, 0);
2119           pushdecl (union_decl);
2120
2121           DECL_CONTEXT (union_decl) = current_function_decl;
2122           tmp = fold_build2_loc (input_location, MODIFY_EXPR,
2123                                  TREE_TYPE (union_decl), union_decl, tmp);
2124           gfc_add_expr_to_block (&body, tmp);
2125
2126           for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
2127                field; field = DECL_CHAIN (field))
2128             if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
2129                 thunk_sym->result->name) == 0)
2130               break;
2131           gcc_assert (field != NULL_TREE);
2132           tmp = fold_build3_loc (input_location, COMPONENT_REF,
2133                                  TREE_TYPE (field), union_decl, field,
2134                                  NULL_TREE);
2135           tmp = fold_build2_loc (input_location, MODIFY_EXPR, 
2136                              TREE_TYPE (DECL_RESULT (current_function_decl)),
2137                              DECL_RESULT (current_function_decl), tmp);
2138           tmp = build1_v (RETURN_EXPR, tmp);
2139         }
2140       else if (TREE_TYPE (DECL_RESULT (current_function_decl))
2141                != void_type_node)
2142         {
2143           tmp = fold_build2_loc (input_location, MODIFY_EXPR,
2144                              TREE_TYPE (DECL_RESULT (current_function_decl)),
2145                              DECL_RESULT (current_function_decl), tmp);
2146           tmp = build1_v (RETURN_EXPR, tmp);
2147         }
2148       gfc_add_expr_to_block (&body, tmp);
2149
2150       /* Finish off this function and send it for code generation.  */
2151       DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
2152       tmp = getdecls ();
2153       poplevel (1, 0, 1);
2154       BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
2155       DECL_SAVED_TREE (thunk_fndecl)
2156         = build3_v (BIND_EXPR, tmp, DECL_SAVED_TREE (thunk_fndecl),
2157                     DECL_INITIAL (thunk_fndecl));
2158
2159       /* Output the GENERIC tree.  */
2160       dump_function (TDI_original, thunk_fndecl);
2161
2162       /* Store the end of the function, so that we get good line number
2163          info for the epilogue.  */
2164       cfun->function_end_locus = input_location;
2165
2166       /* We're leaving the context of this function, so zap cfun.
2167          It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
2168          tree_rest_of_compilation.  */
2169       set_cfun (NULL);
2170
2171       current_function_decl = NULL_TREE;
2172
2173       cgraph_finalize_function (thunk_fndecl, true);
2174
2175       /* We share the symbols in the formal argument list with other entry
2176          points and the master function.  Clear them so that they are
2177          recreated for each function.  */
2178       for (formal = thunk_sym->formal; formal; formal = formal->next)
2179         if (formal->sym != NULL)  /* Ignore alternate returns.  */
2180           {
2181             formal->sym->backend_decl = NULL_TREE;
2182             if (formal->sym->ts.type == BT_CHARACTER)
2183               formal->sym->ts.u.cl->backend_decl = NULL_TREE;
2184           }
2185
2186       if (thunk_sym->attr.function)
2187         {
2188           if (thunk_sym->ts.type == BT_CHARACTER)
2189             thunk_sym->ts.u.cl->backend_decl = NULL_TREE;
2190           if (thunk_sym->result->ts.type == BT_CHARACTER)
2191             thunk_sym->result->ts.u.cl->backend_decl = NULL_TREE;
2192         }
2193     }
2194
2195   gfc_set_backend_locus (&old_loc);
2196 }
2197
2198
2199 /* Create a decl for a function, and create any thunks for alternate entry
2200    points. If global is true, generate the function in the global binding
2201    level, otherwise in the current binding level (which can be global).  */
2202
2203 void
2204 gfc_create_function_decl (gfc_namespace * ns, bool global)
2205 {
2206   /* Create a declaration for the master function.  */
2207   build_function_decl (ns->proc_name, global);
2208
2209   /* Compile the entry thunks.  */
2210   if (ns->entries)
2211     build_entry_thunks (ns, global);
2212
2213   /* Now create the read argument list.  */
2214   create_function_arglist (ns->proc_name);
2215 }
2216
2217 /* Return the decl used to hold the function return value.  If
2218    parent_flag is set, the context is the parent_scope.  */
2219
2220 tree
2221 gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
2222 {
2223   tree decl;
2224   tree length;
2225   tree this_fake_result_decl;
2226   tree this_function_decl;
2227
2228   char name[GFC_MAX_SYMBOL_LEN + 10];
2229
2230   if (parent_flag)
2231     {
2232       this_fake_result_decl = parent_fake_result_decl;
2233       this_function_decl = DECL_CONTEXT (current_function_decl);
2234     }
2235   else
2236     {
2237       this_fake_result_decl = current_fake_result_decl;
2238       this_function_decl = current_function_decl;
2239     }
2240
2241   if (sym
2242       && sym->ns->proc_name->backend_decl == this_function_decl
2243       && sym->ns->proc_name->attr.entry_master
2244       && sym != sym->ns->proc_name)
2245     {
2246       tree t = NULL, var;
2247       if (this_fake_result_decl != NULL)
2248         for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t))
2249           if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
2250             break;
2251       if (t)
2252         return TREE_VALUE (t);
2253       decl = gfc_get_fake_result_decl (sym->ns->proc_name, parent_flag);
2254
2255       if (parent_flag)
2256         this_fake_result_decl = parent_fake_result_decl;
2257       else
2258         this_fake_result_decl = current_fake_result_decl;
2259
2260       if (decl && sym->ns->proc_name->attr.mixed_entry_master)
2261         {
2262           tree field;
2263
2264           for (field = TYPE_FIELDS (TREE_TYPE (decl));
2265                field; field = DECL_CHAIN (field))
2266             if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
2267                 sym->name) == 0)
2268               break;
2269
2270           gcc_assert (field != NULL_TREE);
2271           decl = fold_build3_loc (input_location, COMPONENT_REF,
2272                                   TREE_TYPE (field), decl, field, NULL_TREE);
2273         }
2274
2275       var = create_tmp_var_raw (TREE_TYPE (decl), sym->name);
2276       if (parent_flag)
2277         gfc_add_decl_to_parent_function (var);
2278       else
2279         gfc_add_decl_to_function (var);
2280
2281       SET_DECL_VALUE_EXPR (var, decl);
2282       DECL_HAS_VALUE_EXPR_P (var) = 1;
2283       GFC_DECL_RESULT (var) = 1;
2284
2285       TREE_CHAIN (this_fake_result_decl)
2286           = tree_cons (get_identifier (sym->name), var,
2287                        TREE_CHAIN (this_fake_result_decl));
2288       return var;
2289     }
2290
2291   if (this_fake_result_decl != NULL_TREE)
2292     return TREE_VALUE (this_fake_result_decl);
2293
2294   /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
2295      sym is NULL.  */
2296   if (!sym)
2297     return NULL_TREE;
2298
2299   if (sym->ts.type == BT_CHARACTER)
2300     {
2301       if (sym->ts.u.cl->backend_decl == NULL_TREE)
2302         length = gfc_create_string_length (sym);
2303       else
2304         length = sym->ts.u.cl->backend_decl;
2305       if (TREE_CODE (length) == VAR_DECL
2306           && DECL_CONTEXT (length) == NULL_TREE)
2307         gfc_add_decl_to_function (length);
2308     }
2309
2310   if (gfc_return_by_reference (sym))
2311     {
2312       decl = DECL_ARGUMENTS (this_function_decl);
2313
2314       if (sym->ns->proc_name->backend_decl == this_function_decl
2315           && sym->ns->proc_name->attr.entry_master)
2316         decl = DECL_CHAIN (decl);
2317
2318       TREE_USED (decl) = 1;
2319       if (sym->as)
2320         decl = gfc_build_dummy_array_decl (sym, decl);
2321     }
2322   else
2323     {
2324       sprintf (name, "__result_%.20s",
2325                IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
2326
2327       if (!sym->attr.mixed_entry_master && sym->attr.function)
2328         decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl),
2329                            VAR_DECL, get_identifier (name),
2330                            gfc_sym_type (sym));
2331       else
2332         decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl),
2333                            VAR_DECL, get_identifier (name),
2334                            TREE_TYPE (TREE_TYPE (this_function_decl)));
2335       DECL_ARTIFICIAL (decl) = 1;
2336       DECL_EXTERNAL (decl) = 0;
2337       TREE_PUBLIC (decl) = 0;
2338       TREE_USED (decl) = 1;
2339       GFC_DECL_RESULT (decl) = 1;
2340       TREE_ADDRESSABLE (decl) = 1;
2341
2342       layout_decl (decl, 0);
2343
2344       if (parent_flag)
2345         gfc_add_decl_to_parent_function (decl);
2346       else
2347         gfc_add_decl_to_function (decl);
2348     }
2349
2350   if (parent_flag)
2351     parent_fake_result_decl = build_tree_list (NULL, decl);
2352   else
2353     current_fake_result_decl = build_tree_list (NULL, decl);
2354
2355   return decl;
2356 }
2357
2358
2359 /* Builds a function decl.  The remaining parameters are the types of the
2360    function arguments.  Negative nargs indicates a varargs function.  */
2361
2362 static tree
2363 build_library_function_decl_1 (tree name, const char *spec,
2364                                tree rettype, int nargs, va_list p)
2365 {
2366   tree arglist;
2367   tree argtype;
2368   tree fntype;
2369   tree fndecl;
2370   int n;
2371
2372   /* Library functions must be declared with global scope.  */
2373   gcc_assert (current_function_decl == NULL_TREE);
2374
2375   /* Create a list of the argument types.  */
2376   for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
2377     {
2378       argtype = va_arg (p, tree);
2379       arglist = gfc_chainon_list (arglist, argtype);
2380     }
2381
2382   if (nargs >= 0)
2383     {
2384       /* Terminate the list.  */
2385       arglist = chainon (arglist, void_list_node);
2386     }
2387
2388   /* Build the function type and decl.  */
2389   fntype = build_function_type (rettype, arglist);
2390   if (spec)
2391     {
2392       tree attr_args = build_tree_list (NULL_TREE,
2393                                         build_string (strlen (spec), spec));
2394       tree attrs = tree_cons (get_identifier ("fn spec"),
2395                               attr_args, TYPE_ATTRIBUTES (fntype));
2396       fntype = build_type_attribute_variant (fntype, attrs);
2397     }
2398   fndecl = build_decl (input_location,
2399                        FUNCTION_DECL, name, fntype);
2400
2401   /* Mark this decl as external.  */
2402   DECL_EXTERNAL (fndecl) = 1;
2403   TREE_PUBLIC (fndecl) = 1;
2404
2405   pushdecl (fndecl);
2406
2407   rest_of_decl_compilation (fndecl, 1, 0);
2408
2409   return fndecl;
2410 }
2411
2412 /* Builds a function decl.  The remaining parameters are the types of the
2413    function arguments.  Negative nargs indicates a varargs function.  */
2414
2415 tree
2416 gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
2417 {
2418   tree ret;
2419   va_list args;
2420   va_start (args, nargs);
2421   ret = build_library_function_decl_1 (name, NULL, rettype, nargs, args);
2422   va_end (args);
2423   return ret;
2424 }
2425
2426 /* Builds a function decl.  The remaining parameters are the types of the
2427    function arguments.  Negative nargs indicates a varargs function.
2428    The SPEC parameter specifies the function argument and return type
2429    specification according to the fnspec function type attribute.  */
2430
2431 tree
2432 gfc_build_library_function_decl_with_spec (tree name, const char *spec,
2433                                            tree rettype, int nargs, ...)
2434 {
2435   tree ret;
2436   va_list args;
2437   va_start (args, nargs);
2438   ret = build_library_function_decl_1 (name, spec, rettype, nargs, args);
2439   va_end (args);
2440   return ret;
2441 }
2442
2443 static void
2444 gfc_build_intrinsic_function_decls (void)
2445 {
2446   tree gfc_int4_type_node = gfc_get_int_type (4);
2447   tree gfc_int8_type_node = gfc_get_int_type (8);
2448   tree gfc_int16_type_node = gfc_get_int_type (16);
2449   tree gfc_logical4_type_node = gfc_get_logical_type (4);
2450   tree pchar1_type_node = gfc_get_pchar_type (1);
2451   tree pchar4_type_node = gfc_get_pchar_type (4);
2452
2453   /* String functions.  */
2454   gfor_fndecl_compare_string = gfc_build_library_function_decl_with_spec (
2455         get_identifier (PREFIX("compare_string")), "..R.R",
2456         integer_type_node, 4, gfc_charlen_type_node, pchar1_type_node,
2457         gfc_charlen_type_node, pchar1_type_node);
2458   DECL_PURE_P (gfor_fndecl_compare_string) = 1;
2459   TREE_NOTHROW (gfor_fndecl_compare_string) = 1;
2460
2461   gfor_fndecl_concat_string = gfc_build_library_function_decl_with_spec (
2462         get_identifier (PREFIX("concat_string")), "..W.R.R",
2463         void_type_node, 6, gfc_charlen_type_node, pchar1_type_node,
2464         gfc_charlen_type_node, pchar1_type_node,
2465         gfc_charlen_type_node, pchar1_type_node);
2466   TREE_NOTHROW (gfor_fndecl_concat_string) = 1;
2467
2468   gfor_fndecl_string_len_trim = gfc_build_library_function_decl_with_spec (
2469         get_identifier (PREFIX("string_len_trim")), "..R",
2470         gfc_charlen_type_node, 2, gfc_charlen_type_node, pchar1_type_node);
2471   DECL_PURE_P (gfor_fndecl_string_len_trim) = 1;
2472   TREE_NOTHROW (gfor_fndecl_string_len_trim) = 1;
2473
2474   gfor_fndecl_string_index = gfc_build_library_function_decl_with_spec (
2475         get_identifier (PREFIX("string_index")), "..R.R.",
2476         gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node,
2477         gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
2478   DECL_PURE_P (gfor_fndecl_string_index) = 1;
2479   TREE_NOTHROW (gfor_fndecl_string_index) = 1;
2480
2481   gfor_fndecl_string_scan = gfc_build_library_function_decl_with_spec (
2482         get_identifier (PREFIX("string_scan")), "..R.R.",
2483         gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node,
2484         gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
2485   DECL_PURE_P (gfor_fndecl_string_scan) = 1;
2486   TREE_NOTHROW (gfor_fndecl_string_scan) = 1;
2487
2488   gfor_fndecl_string_verify = gfc_build_library_function_decl_with_spec (
2489         get_identifier (PREFIX("string_verify")), "..R.R.",
2490         gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node,
2491         gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
2492   DECL_PURE_P (gfor_fndecl_string_verify) = 1;
2493   TREE_NOTHROW (gfor_fndecl_string_verify) = 1;
2494
2495   gfor_fndecl_string_trim = gfc_build_library_function_decl_with_spec (
2496         get_identifier (PREFIX("string_trim")), ".Ww.R",
2497         void_type_node, 4, build_pointer_type (gfc_charlen_type_node),
2498         build_pointer_type (pchar1_type_node), gfc_charlen_type_node,
2499         pchar1_type_node);
2500
2501   gfor_fndecl_string_minmax = gfc_build_library_function_decl_with_spec (
2502         get_identifier (PREFIX("string_minmax")), ".Ww.R",
2503         void_type_node, -4, build_pointer_type (gfc_charlen_type_node),
2504         build_pointer_type (pchar1_type_node), integer_type_node,
2505         integer_type_node);
2506
2507   gfor_fndecl_adjustl = gfc_build_library_function_decl_with_spec (
2508         get_identifier (PREFIX("adjustl")), ".W.R",
2509         void_type_node, 3, pchar1_type_node, gfc_charlen_type_node,
2510         pchar1_type_node);
2511   TREE_NOTHROW (gfor_fndecl_adjustl) = 1;
2512
2513   gfor_fndecl_adjustr = gfc_build_library_function_decl_with_spec (
2514         get_identifier (PREFIX("adjustr")), ".W.R",
2515         void_type_node, 3, pchar1_type_node, gfc_charlen_type_node,
2516         pchar1_type_node);
2517   TREE_NOTHROW (gfor_fndecl_adjustr) = 1;
2518
2519   gfor_fndecl_select_string =  gfc_build_library_function_decl_with_spec (
2520         get_identifier (PREFIX("select_string")), ".R.R.",
2521         integer_type_node, 4, pvoid_type_node, integer_type_node,
2522         pchar1_type_node, gfc_charlen_type_node);
2523   DECL_PURE_P (gfor_fndecl_select_string) = 1;
2524   TREE_NOTHROW (gfor_fndecl_select_string) = 1;
2525
2526   gfor_fndecl_compare_string_char4 = gfc_build_library_function_decl_with_spec (
2527         get_identifier (PREFIX("compare_string_char4")), "..R.R",
2528         integer_type_node, 4, gfc_charlen_type_node, pchar4_type_node,
2529         gfc_charlen_type_node, pchar4_type_node);
2530   DECL_PURE_P (gfor_fndecl_compare_string_char4) = 1;
2531   TREE_NOTHROW (gfor_fndecl_compare_string_char4) = 1;
2532
2533   gfor_fndecl_concat_string_char4 = gfc_build_library_function_decl_with_spec (
2534         get_identifier (PREFIX("concat_string_char4")), "..W.R.R",
2535         void_type_node, 6, gfc_charlen_type_node, pchar4_type_node,
2536         gfc_charlen_type_node, pchar4_type_node, gfc_charlen_type_node,
2537         pchar4_type_node);
2538   TREE_NOTHROW (gfor_fndecl_concat_string_char4) = 1;
2539
2540   gfor_fndecl_string_len_trim_char4 = gfc_build_library_function_decl_with_spec (
2541         get_identifier (PREFIX("string_len_trim_char4")), "..R",
2542         gfc_charlen_type_node, 2, gfc_charlen_type_node, pchar4_type_node);
2543   DECL_PURE_P (gfor_fndecl_string_len_trim_char4) = 1;
2544   TREE_NOTHROW (gfor_fndecl_string_len_trim_char4) = 1;
2545
2546   gfor_fndecl_string_index_char4 = gfc_build_library_function_decl_with_spec (
2547         get_identifier (PREFIX("string_index_char4")), "..R.R.",
2548         gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node,
2549         gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
2550   DECL_PURE_P (gfor_fndecl_string_index_char4) = 1;
2551   TREE_NOTHROW (gfor_fndecl_string_index_char4) = 1;
2552
2553   gfor_fndecl_string_scan_char4 = gfc_build_library_function_decl_with_spec (
2554         get_identifier (PREFIX("string_scan_char4")), "..R.R.",
2555         gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node,
2556         gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
2557   DECL_PURE_P (gfor_fndecl_string_scan_char4) = 1;
2558   TREE_NOTHROW (gfor_fndecl_string_scan_char4) = 1;
2559
2560   gfor_fndecl_string_verify_char4 = gfc_build_library_function_decl_with_spec (
2561         get_identifier (PREFIX("string_verify_char4")), "..R.R.",
2562         gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node,
2563         gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
2564   DECL_PURE_P (gfor_fndecl_string_verify_char4) = 1;
2565   TREE_NOTHROW (gfor_fndecl_string_verify_char4) = 1;
2566
2567   gfor_fndecl_string_trim_char4 = gfc_build_library_function_decl_with_spec (
2568         get_identifier (PREFIX("string_trim_char4")), ".Ww.R",
2569         void_type_node, 4, build_pointer_type (gfc_charlen_type_node),
2570         build_pointer_type (pchar4_type_node), gfc_charlen_type_node,
2571         pchar4_type_node);
2572
2573   gfor_fndecl_string_minmax_char4 = gfc_build_library_function_decl_with_spec (
2574         get_identifier (PREFIX("string_minmax_char4")), ".Ww.R",
2575         void_type_node, -4, build_pointer_type (gfc_charlen_type_node),
2576         build_pointer_type (pchar4_type_node), integer_type_node,
2577         integer_type_node);
2578
2579   gfor_fndecl_adjustl_char4 = gfc_build_library_function_decl_with_spec (
2580         get_identifier (PREFIX("adjustl_char4")), ".W.R",
2581         void_type_node, 3, pchar4_type_node, gfc_charlen_type_node,
2582         pchar4_type_node);
2583   TREE_NOTHROW (gfor_fndecl_adjustl_char4) = 1;
2584
2585   gfor_fndecl_adjustr_char4 = gfc_build_library_function_decl_with_spec (
2586         get_identifier (PREFIX("adjustr_char4")), ".W.R",
2587         void_type_node, 3, pchar4_type_node, gfc_charlen_type_node,
2588         pchar4_type_node);
2589   TREE_NOTHROW (gfor_fndecl_adjustr_char4) = 1;
2590
2591   gfor_fndecl_select_string_char4 = gfc_build_library_function_decl_with_spec (
2592         get_identifier (PREFIX("select_string_char4")), ".R.R.",
2593         integer_type_node, 4, pvoid_type_node, integer_type_node,
2594         pvoid_type_node, gfc_charlen_type_node);
2595   DECL_PURE_P (gfor_fndecl_select_string_char4) = 1;
2596   TREE_NOTHROW (gfor_fndecl_select_string_char4) = 1;
2597
2598
2599   /* Conversion between character kinds.  */
2600
2601   gfor_fndecl_convert_char1_to_char4 = gfc_build_library_function_decl_with_spec (
2602         get_identifier (PREFIX("convert_char1_to_char4")), ".w.R",
2603         void_type_node, 3, build_pointer_type (pchar4_type_node),
2604         gfc_charlen_type_node, pchar1_type_node);
2605
2606   gfor_fndecl_convert_char4_to_char1 = gfc_build_library_function_decl_with_spec (
2607         get_identifier (PREFIX("convert_char4_to_char1")), ".w.R",
2608         void_type_node, 3, build_pointer_type (pchar1_type_node),
2609         gfc_charlen_type_node, pchar4_type_node);
2610
2611   /* Misc. functions.  */
2612
2613   gfor_fndecl_ttynam = gfc_build_library_function_decl_with_spec (
2614         get_identifier (PREFIX("ttynam")), ".W",
2615         void_type_node, 3, pchar_type_node, gfc_charlen_type_node,
2616         integer_type_node);
2617
2618   gfor_fndecl_fdate = gfc_build_library_function_decl_with_spec (
2619         get_identifier (PREFIX("fdate")), ".W",
2620         void_type_node, 2, pchar_type_node, gfc_charlen_type_node);
2621
2622   gfor_fndecl_ctime = gfc_build_library_function_decl_with_spec (
2623         get_identifier (PREFIX("ctime")), ".W",
2624         void_type_node, 3, pchar_type_node, gfc_charlen_type_node,
2625         gfc_int8_type_node);
2626
2627   gfor_fndecl_sc_kind = gfc_build_library_function_decl_with_spec (
2628         get_identifier (PREFIX("selected_char_kind")), "..R",
2629         gfc_int4_type_node, 2, gfc_charlen_type_node, pchar_type_node);
2630   DECL_PURE_P (gfor_fndecl_sc_kind) = 1;
2631   TREE_NOTHROW (gfor_fndecl_sc_kind) = 1;
2632
2633   gfor_fndecl_si_kind = gfc_build_library_function_decl_with_spec (
2634         get_identifier (PREFIX("selected_int_kind")), ".R",
2635         gfc_int4_type_node, 1, pvoid_type_node);
2636   DECL_PURE_P (gfor_fndecl_si_kind) = 1;
2637   TREE_NOTHROW (gfor_fndecl_si_kind) = 1;
2638
2639   gfor_fndecl_sr_kind = gfc_build_library_function_decl_with_spec (
2640         get_identifier (PREFIX("selected_real_kind2008")), ".RR",
2641         gfc_int4_type_node, 3, pvoid_type_node, pvoid_type_node,
2642         pvoid_type_node);
2643   DECL_PURE_P (gfor_fndecl_sr_kind) = 1;
2644   TREE_NOTHROW (gfor_fndecl_sr_kind) = 1;
2645
2646   /* Power functions.  */
2647   {
2648     tree ctype, rtype, itype, jtype;
2649     int rkind, ikind, jkind;
2650 #define NIKINDS 3
2651 #define NRKINDS 4
2652     static int ikinds[NIKINDS] = {4, 8, 16};
2653     static int rkinds[NRKINDS] = {4, 8, 10, 16};
2654     char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */
2655
2656     for (ikind=0; ikind < NIKINDS; ikind++)
2657       {
2658         itype = gfc_get_int_type (ikinds[ikind]);
2659
2660         for (jkind=0; jkind < NIKINDS; jkind++)
2661           {
2662             jtype = gfc_get_int_type (ikinds[jkind]);
2663             if (itype && jtype)
2664               {
2665                 sprintf(name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
2666                         ikinds[jkind]);
2667                 gfor_fndecl_math_powi[jkind][ikind].integer =
2668                   gfc_build_library_function_decl (get_identifier (name),
2669                     jtype, 2, jtype, itype);
2670                 TREE_READONLY (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
2671                 TREE_NOTHROW (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
2672               }
2673           }
2674
2675         for (rkind = 0; rkind < NRKINDS; rkind ++)
2676           {
2677             rtype = gfc_get_real_type (rkinds[rkind]);
2678             if (rtype && itype)
2679               {
2680                 sprintf(name, PREFIX("pow_r%d_i%d"), rkinds[rkind],
2681                         ikinds[ikind]);
2682                 gfor_fndecl_math_powi[rkind][ikind].real =
2683                   gfc_build_library_function_decl (get_identifier (name),
2684                     rtype, 2, rtype, itype);
2685                 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
2686                 TREE_NOTHROW (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
2687               }
2688
2689             ctype = gfc_get_complex_type (rkinds[rkind]);
2690             if (ctype && itype)
2691               {
2692                 sprintf(name, PREFIX("pow_c%d_i%d"), rkinds[rkind],
2693                         ikinds[ikind]);
2694                 gfor_fndecl_math_powi[rkind][ikind].cmplx =
2695                   gfc_build_library_function_decl (get_identifier (name),
2696                     ctype, 2,ctype, itype);
2697                 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
2698                 TREE_NOTHROW (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
2699               }
2700           }
2701       }
2702 #undef NIKINDS
2703 #undef NRKINDS
2704   }
2705
2706   gfor_fndecl_math_ishftc4 = gfc_build_library_function_decl (
2707         get_identifier (PREFIX("ishftc4")),
2708         gfc_int4_type_node, 3, gfc_int4_type_node, gfc_int4_type_node,
2709         gfc_int4_type_node);
2710   TREE_READONLY (gfor_fndecl_math_ishftc4) = 1;
2711   TREE_NOTHROW (gfor_fndecl_math_ishftc4) = 1;
2712         
2713   gfor_fndecl_math_ishftc8 = gfc_build_library_function_decl (
2714         get_identifier (PREFIX("ishftc8")),
2715         gfc_int8_type_node, 3, gfc_int8_type_node, gfc_int4_type_node,
2716         gfc_int4_type_node);
2717   TREE_READONLY (gfor_fndecl_math_ishftc8) = 1;
2718   TREE_NOTHROW (gfor_fndecl_math_ishftc8) = 1;
2719
2720   if (gfc_int16_type_node)
2721     {
2722       gfor_fndecl_math_ishftc16 = gfc_build_library_function_decl (
2723         get_identifier (PREFIX("ishftc16")),
2724         gfc_int16_type_node, 3, gfc_int16_type_node, gfc_int4_type_node,
2725         gfc_int4_type_node);
2726       TREE_READONLY (gfor_fndecl_math_ishftc16) = 1;
2727       TREE_NOTHROW (gfor_fndecl_math_ishftc16) = 1;
2728     }
2729
2730   /* BLAS functions.  */
2731   {
2732     tree pint = build_pointer_type (integer_type_node);
2733     tree ps = build_pointer_type (gfc_get_real_type (gfc_default_real_kind));
2734     tree pd = build_pointer_type (gfc_get_real_type (gfc_default_double_kind));
2735     tree pc = build_pointer_type (gfc_get_complex_type (gfc_default_real_kind));
2736     tree pz = build_pointer_type
2737                 (gfc_get_complex_type (gfc_default_double_kind));
2738
2739     gfor_fndecl_sgemm = gfc_build_library_function_decl
2740                           (get_identifier
2741                              (gfc_option.flag_underscoring ? "sgemm_"
2742                                                            : "sgemm"),
2743                            void_type_node, 15, pchar_type_node,
2744                            pchar_type_node, pint, pint, pint, ps, ps, pint,
2745                            ps, pint, ps, ps, pint, integer_type_node,
2746                            integer_type_node);
2747     gfor_fndecl_dgemm = gfc_build_library_function_decl
2748                           (get_identifier
2749                              (gfc_option.flag_underscoring ? "dgemm_"
2750                                                            : "dgemm"),
2751                            void_type_node, 15, pchar_type_node,
2752                            pchar_type_node, pint, pint, pint, pd, pd, pint,
2753                            pd, pint, pd, pd, pint, integer_type_node,
2754                            integer_type_node);
2755     gfor_fndecl_cgemm = gfc_build_library_function_decl
2756                           (get_identifier
2757                              (gfc_option.flag_underscoring ? "cgemm_"
2758                                                            : "cgemm"),
2759                            void_type_node, 15, pchar_type_node,
2760                            pchar_type_node, pint, pint, pint, pc, pc, pint,
2761                            pc, pint, pc, pc, pint, integer_type_node,
2762                            integer_type_node);
2763     gfor_fndecl_zgemm = gfc_build_library_function_decl
2764                           (get_identifier
2765                              (gfc_option.flag_underscoring ? "zgemm_"
2766                                                            : "zgemm"),
2767                            void_type_node, 15, pchar_type_node,
2768                            pchar_type_node, pint, pint, pint, pz, pz, pint,
2769                            pz, pint, pz, pz, pint, integer_type_node,
2770                            integer_type_node);
2771   }
2772
2773   /* Other functions.  */
2774   gfor_fndecl_size0 = gfc_build_library_function_decl_with_spec (
2775         get_identifier (PREFIX("size0")), ".R",
2776         gfc_array_index_type, 1, pvoid_type_node);
2777   DECL_PURE_P (gfor_fndecl_size0) = 1;
2778   TREE_NOTHROW (gfor_fndecl_size0) = 1;
2779
2780   gfor_fndecl_size1 = gfc_build_library_function_decl_with_spec (
2781         get_identifier (PREFIX("size1")), ".R",
2782         gfc_array_index_type, 2, pvoid_type_node, gfc_array_index_type);
2783   DECL_PURE_P (gfor_fndecl_size1) = 1;
2784   TREE_NOTHROW (gfor_fndecl_size1) = 1;
2785
2786   gfor_fndecl_iargc = gfc_build_library_function_decl (
2787         get_identifier (PREFIX ("iargc")), gfc_int4_type_node, 0);
2788   TREE_NOTHROW (gfor_fndecl_iargc) = 1;
2789 }
2790
2791
2792 /* Make prototypes for runtime library functions.  */
2793
2794 void
2795 gfc_build_builtin_function_decls (void)
2796 {
2797   tree gfc_int4_type_node = gfc_get_int_type (4);
2798
2799   gfor_fndecl_stop_numeric = gfc_build_library_function_decl (
2800         get_identifier (PREFIX("stop_numeric")),
2801         void_type_node, 1, gfc_int4_type_node);
2802   /* STOP doesn't return.  */
2803   TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
2804
2805   gfor_fndecl_stop_string = gfc_build_library_function_decl_with_spec (
2806         get_identifier (PREFIX("stop_string")), ".R.",
2807         void_type_node, 2, pchar_type_node, gfc_int4_type_node);
2808   /* STOP doesn't return.  */
2809   TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
2810
2811   gfor_fndecl_error_stop_numeric = gfc_build_library_function_decl (
2812         get_identifier (PREFIX("error_stop_numeric")),
2813         void_type_node, 1, gfc_int4_type_node);
2814   /* ERROR STOP doesn't return.  */
2815   TREE_THIS_VOLATILE (gfor_fndecl_error_stop_numeric) = 1;
2816
2817   gfor_fndecl_error_stop_string = gfc_build_library_function_decl_with_spec (
2818         get_identifier (PREFIX("error_stop_string")), ".R.",
2819         void_type_node, 2, pchar_type_node, gfc_int4_type_node);
2820   /* ERROR STOP doesn't return.  */
2821   TREE_THIS_VOLATILE (gfor_fndecl_error_stop_string) = 1;
2822
2823   gfor_fndecl_pause_numeric = gfc_build_library_function_decl (
2824         get_identifier (PREFIX("pause_numeric")),
2825         void_type_node, 1, gfc_int4_type_node);
2826
2827   gfor_fndecl_pause_string = gfc_build_library_function_decl_with_spec (
2828         get_identifier (PREFIX("pause_string")), ".R.",
2829         void_type_node, 2, pchar_type_node, gfc_int4_type_node);
2830
2831   gfor_fndecl_runtime_error = gfc_build_library_function_decl_with_spec (
2832         get_identifier (PREFIX("runtime_error")), ".R",
2833         void_type_node, -1, pchar_type_node);
2834   /* The runtime_error function does not return.  */
2835   TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
2836
2837   gfor_fndecl_runtime_error_at = gfc_build_library_function_decl_with_spec (
2838         get_identifier (PREFIX("runtime_error_at")), ".RR",
2839         void_type_node, -2, pchar_type_node, pchar_type_node);
2840   /* The runtime_error_at function does not return.  */
2841   TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1;
2842   
2843   gfor_fndecl_runtime_warning_at = gfc_build_library_function_decl_with_spec (
2844         get_identifier (PREFIX("runtime_warning_at")), ".RR",
2845         void_type_node, -2, pchar_type_node, pchar_type_node);
2846
2847   gfor_fndecl_generate_error = gfc_build_library_function_decl_with_spec (
2848         get_identifier (PREFIX("generate_error")), ".R.R",
2849         void_type_node, 3, pvoid_type_node, integer_type_node,
2850         pchar_type_node);
2851
2852   gfor_fndecl_os_error = gfc_build_library_function_decl_with_spec (
2853         get_identifier (PREFIX("os_error")), ".R",
2854         void_type_node, 1, pchar_type_node);
2855   /* The runtime_error function does not return.  */
2856   TREE_THIS_VOLATILE (gfor_fndecl_os_error) = 1;
2857
2858   gfor_fndecl_set_args = gfc_build_library_function_decl (
2859         get_identifier (PREFIX("set_args")),
2860         void_type_node, 2, integer_type_node,
2861         build_pointer_type (pchar_type_node));
2862
2863   gfor_fndecl_set_fpe = gfc_build_library_function_decl (
2864         get_identifier (PREFIX("set_fpe")),
2865         void_type_node, 1, integer_type_node);
2866
2867   /* Keep the array dimension in sync with the call, later in this file.  */
2868   gfor_fndecl_set_options = gfc_build_library_function_decl_with_spec (
2869         get_identifier (PREFIX("set_options")), "..R",
2870         void_type_node, 2, integer_type_node,
2871         build_pointer_type (integer_type_node));
2872
2873   gfor_fndecl_set_convert = gfc_build_library_function_decl (
2874         get_identifier (PREFIX("set_convert")),
2875         void_type_node, 1, integer_type_node);
2876
2877   gfor_fndecl_set_record_marker = gfc_build_library_function_decl (
2878         get_identifier (PREFIX("set_record_marker")),
2879         void_type_node, 1, integer_type_node);
2880
2881   gfor_fndecl_set_max_subrecord_length = gfc_build_library_function_decl (
2882         get_identifier (PREFIX("set_max_subrecord_length")),
2883         void_type_node, 1, integer_type_node);
2884
2885   gfor_fndecl_in_pack = gfc_build_library_function_decl_with_spec (
2886         get_identifier (PREFIX("internal_pack")), ".r",
2887         pvoid_type_node, 1, pvoid_type_node);
2888
2889   gfor_fndecl_in_unpack = gfc_build_library_function_decl_with_spec (
2890         get_identifier (PREFIX("internal_unpack")), ".wR",
2891         void_type_node, 2, pvoid_type_node, pvoid_type_node);
2892
2893   gfor_fndecl_associated = gfc_build_library_function_decl_with_spec (
2894         get_identifier (PREFIX("associated")), ".RR",
2895         integer_type_node, 2, ppvoid_type_node, ppvoid_type_node);
2896   DECL_PURE_P (gfor_fndecl_associated) = 1;
2897   TREE_NOTHROW (gfor_fndecl_associated) = 1;
2898
2899   gfc_build_intrinsic_function_decls ();
2900   gfc_build_intrinsic_lib_fndecls ();
2901   gfc_build_io_library_fndecls ();
2902 }
2903
2904
2905 /* Evaluate the length of dummy character variables.  */
2906
2907 static void
2908 gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl,
2909                            gfc_wrapped_block *block)
2910 {
2911   stmtblock_t init;
2912
2913   gfc_finish_decl (cl->backend_decl);
2914
2915   gfc_start_block (&init);
2916
2917   /* Evaluate the string length expression.  */
2918   gfc_conv_string_length (cl, NULL, &init);
2919
2920   gfc_trans_vla_type_sizes (sym, &init);
2921
2922   gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
2923 }
2924
2925
2926 /* Allocate and cleanup an automatic character variable.  */
2927
2928 static void
2929 gfc_trans_auto_character_variable (gfc_symbol * sym, gfc_wrapped_block * block)
2930 {
2931   stmtblock_t init;
2932   tree decl;
2933   tree tmp;
2934
2935   gcc_assert (sym->backend_decl);
2936   gcc_assert (sym->ts.u.cl && sym->ts.u.cl->length);
2937
2938   gfc_start_block (&init);
2939
2940   /* Evaluate the string length expression.  */
2941   gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
2942
2943   gfc_trans_vla_type_sizes (sym, &init);
2944
2945   decl = sym->backend_decl;
2946
2947   /* Emit a DECL_EXPR for this variable, which will cause the
2948      gimplifier to allocate storage, and all that good stuff.  */
2949   tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
2950   gfc_add_expr_to_block (&init, tmp);
2951
2952   gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
2953 }
2954
2955 /* Set the initial value of ASSIGN statement auxiliary variable explicitly.  */
2956
2957 static void
2958 gfc_trans_assign_aux_var (gfc_symbol * sym, gfc_wrapped_block * block)
2959 {
2960   stmtblock_t init;
2961
2962   gcc_assert (sym->backend_decl);
2963   gfc_start_block (&init);
2964
2965   /* Set the initial value to length. See the comments in
2966      function gfc_add_assign_aux_vars in this file.  */
2967   gfc_add_modify (&init, GFC_DECL_STRING_LEN (sym->backend_decl),
2968                   build_int_cst (NULL_TREE, -2));
2969
2970   gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
2971 }
2972
2973 static void
2974 gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body)
2975 {
2976   tree t = *tp, var, val;
2977
2978   if (t == NULL || t == error_mark_node)
2979     return;
2980   if (TREE_CONSTANT (t) || DECL_P (t))
2981     return;
2982
2983   if (TREE_CODE (t) == SAVE_EXPR)
2984     {
2985       if (SAVE_EXPR_RESOLVED_P (t))
2986         {
2987           *tp = TREE_OPERAND (t, 0);
2988           return;
2989         }
2990       val = TREE_OPERAND (t, 0);
2991     }
2992   else
2993     val = t;
2994
2995   var = gfc_create_var_np (TREE_TYPE (t), NULL);
2996   gfc_add_decl_to_function (var);
2997   gfc_add_modify (body, var, val);
2998   if (TREE_CODE (t) == SAVE_EXPR)
2999     TREE_OPERAND (t, 0) = var;
3000   *tp = var;
3001 }
3002
3003 static void
3004 gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
3005 {
3006   tree t;
3007
3008   if (type == NULL || type == error_mark_node)
3009     return;
3010
3011   type = TYPE_MAIN_VARIANT (type);
3012
3013   if (TREE_CODE (type) == INTEGER_TYPE)
3014     {
3015       gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body);
3016       gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body);
3017
3018       for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
3019         {
3020           TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type);
3021           TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type);
3022         }
3023     }
3024   else if (TREE_CODE (type) == ARRAY_TYPE)
3025     {
3026       gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);
3027       gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);
3028       gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body);
3029       gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body);
3030
3031       for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
3032         {
3033           TYPE_SIZE (t) = TYPE_SIZE (type);
3034           TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type);
3035         }
3036     }
3037 }
3038
3039 /* Make sure all type sizes and array domains are either constant,
3040    or variable or parameter decls.  This is a simplified variant
3041    of gimplify_type_sizes, but we can't use it here, as none of the
3042    variables in the expressions have been gimplified yet.
3043    As type sizes and domains for various variable length arrays
3044    contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
3045    time, without this routine gimplify_type_sizes in the middle-end
3046    could result in the type sizes being gimplified earlier than where
3047    those variables are initialized.  */
3048
3049 void
3050 gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
3051 {
3052   tree type = TREE_TYPE (sym->backend_decl);
3053
3054   if (TREE_CODE (type) == FUNCTION_TYPE
3055       && (sym->attr.function || sym->attr.result || sym->attr.entry))
3056     {
3057       if (! current_fake_result_decl)
3058         return;
3059
3060       type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));
3061     }
3062
3063   while (POINTER_TYPE_P (type))
3064     type = TREE_TYPE (type);
3065
3066   if (GFC_DESCRIPTOR_TYPE_P (type))
3067     {
3068       tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
3069
3070       while (POINTER_TYPE_P (etype))
3071         etype = TREE_TYPE (etype);
3072
3073       gfc_trans_vla_type_sizes_1 (etype, body);
3074     }
3075
3076   gfc_trans_vla_type_sizes_1 (type, body);
3077 }
3078
3079
3080 /* Initialize a derived type by building an lvalue from the symbol
3081    and using trans_assignment to do the work. Set dealloc to false
3082    if no deallocation prior the assignment is needed.  */
3083 void
3084 gfc_init_default_dt (gfc_symbol * sym, stmtblock_t * block, bool dealloc)
3085 {
3086   gfc_expr *e;
3087   tree tmp;
3088   tree present;
3089
3090   gcc_assert (block);
3091
3092   gcc_assert (!sym->attr.allocatable);
3093   gfc_set_sym_referenced (sym);
3094   e = gfc_lval_expr_from_sym (sym);
3095   tmp = gfc_trans_assignment (e, sym->value, false, dealloc);
3096   if (sym->attr.dummy && (sym->attr.optional
3097                           || sym->ns->proc_name->attr.entry_master))
3098     {
3099       present = gfc_conv_expr_present (sym);
3100       tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
3101                         tmp, build_empty_stmt (input_location));
3102     }
3103   gfc_add_expr_to_block (block, tmp);
3104   gfc_free_expr (e);
3105 }
3106
3107
3108 /* Initialize INTENT(OUT) derived type dummies.  As well as giving
3109    them their default initializer, if they do not have allocatable
3110    components, they have their allocatable components deallocated. */
3111
3112 static void
3113 init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block)
3114 {
3115   stmtblock_t init;
3116   gfc_formal_arglist *f;
3117   tree tmp;
3118   tree present;
3119
3120   gfc_init_block (&init);
3121   for (f = proc_sym->formal; f; f = f->next)
3122     if (f->sym && f->sym->attr.intent == INTENT_OUT
3123         && !f->sym->attr.pointer
3124         && f->sym->ts.type == BT_DERIVED)
3125       {
3126         if (f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value)
3127           {
3128             tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived,
3129                                              f->sym->backend_decl,
3130                                              f->sym->as ? f->sym->as->rank : 0);
3131
3132             if (f->sym->attr.optional
3133                 || f->sym->ns->proc_name->attr.entry_master)
3134               {
3135                 present = gfc_conv_expr_present (f->sym);
3136                 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
3137                                   present, tmp,
3138                                   build_empty_stmt (input_location));
3139               }
3140
3141             gfc_add_expr_to_block (&init, tmp);
3142           }
3143        else if (f->sym->value)
3144           gfc_init_default_dt (f->sym, &init, true);
3145       }
3146
3147   gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
3148 }
3149
3150
3151 /* Do proper initialization for ASSOCIATE names.  */
3152
3153 static void
3154 trans_associate_var (gfc_symbol* sym, gfc_wrapped_block* block)
3155 {
3156   gfc_expr* e;
3157   tree tmp;
3158
3159   gcc_assert (sym->assoc);
3160   e = sym->assoc->target;
3161
3162   /* Do a `pointer assignment' with updated descriptor (or assign descriptor
3163      to array temporary) for arrays with either unknown shape or if associating
3164      to a variable.  */
3165   if (sym->attr.dimension
3166       && (sym->as->type == AS_DEFERRED || sym->assoc->variable))
3167     {
3168       gfc_se se;
3169       gfc_ss* ss;
3170       tree desc;
3171
3172       desc = sym->backend_decl;
3173
3174       /* If association is to an expression, evaluate it and create temporary.
3175          Otherwise, get descriptor of target for pointer assignment.  */
3176       gfc_init_se (&se, NULL);
3177       ss = gfc_walk_expr (e);
3178       if (sym->assoc->variable)
3179         {
3180           se.direct_byref = 1;
3181           se.expr = desc;
3182         }
3183       gfc_conv_expr_descriptor (&se, e, ss);
3184
3185       /* If we didn't already do the pointer assignment, set associate-name
3186          descriptor to the one generated for the temporary.  */
3187       if (!sym->assoc->variable)
3188         {
3189           int dim;
3190
3191           gfc_add_modify (&se.pre, desc, se.expr);
3192
3193           /* The generated descriptor has lower bound zero (as array
3194              temporary), shift bounds so we get lower bounds of 1.  */
3195           for (dim = 0; dim < e->rank; ++dim)
3196             gfc_conv_shift_descriptor_lbound (&se.pre, desc,
3197                                               dim, gfc_index_one_node);
3198         }
3199
3200       /* Done, register stuff as init / cleanup code.  */
3201       gfc_add_init_cleanup (block, gfc_finish_block (&se.pre),
3202                             gfc_finish_block (&se.post));
3203     }
3204
3205   /* Do a scalar pointer assignment; this is for scalar variable targets.  */
3206   else if (gfc_is_associate_pointer (sym))
3207     {
3208       gfc_se se;
3209
3210       gcc_assert (!sym->attr.dimension);
3211
3212       gfc_init_se (&se, NULL);
3213       gfc_conv_expr (&se, e);
3214
3215       tmp = TREE_TYPE (sym->backend_decl);
3216       tmp = gfc_build_addr_expr (tmp, se.expr);
3217       gfc_add_modify (&se.pre, sym->backend_decl, tmp);
3218       
3219       gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
3220                             gfc_finish_block (&se.post));
3221     }
3222
3223   /* Do a simple assignment.  This is for scalar expressions, where we
3224      can simply use expression assignment.  */
3225   else
3226     {
3227       gfc_expr* lhs;
3228
3229       lhs = gfc_lval_expr_from_sym (sym);
3230       tmp = gfc_trans_assignment (lhs, e, false, true);
3231       gfc_add_init_cleanup (block, tmp, NULL_TREE);
3232     }
3233 }
3234
3235
3236 /* Generate function entry and exit code, and add it to the function body.
3237    This includes:
3238     Allocation and initialization of array variables.
3239     Allocation of character string variables.
3240     Initialization and possibly repacking of dummy arrays.
3241     Initialization of ASSIGN statement auxiliary variable.
3242     Initialization of ASSOCIATE names.
3243     Automatic deallocation.  */
3244
3245 void
3246 gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
3247 {
3248   locus loc;
3249   gfc_symbol *sym;
3250   gfc_formal_arglist *f;
3251   stmtblock_t tmpblock;
3252   bool seen_trans_deferred_array = false;
3253
3254   /* Deal with implicit return variables.  Explicit return variables will
3255      already have been added.  */
3256   if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
3257     {
3258       if (!current_fake_result_decl)
3259         {
3260           gfc_entry_list *el = NULL;
3261           if (proc_sym->attr.entry_master)
3262             {
3263               for (el = proc_sym->ns->entries; el; el = el->next)
3264                 if (el->sym != el->sym->result)
3265                   break;
3266             }
3267           /* TODO: move to the appropriate place in resolve.c.  */
3268           if (warn_return_type && el == NULL)
3269             gfc_warning ("Return value of function '%s' at %L not set",
3270                          proc_sym->name, &proc_sym->declared_at);
3271         }
3272       else if (proc_sym->as)
3273         {
3274           tree result = TREE_VALUE (current_fake_result_decl);
3275           gfc_trans_dummy_array_bias (proc_sym, result, block);
3276
3277           /* An automatic character length, pointer array result.  */
3278           if (proc_sym->ts.type == BT_CHARACTER
3279                 && TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
3280             gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block);
3281         }
3282       else if (proc_sym->ts.type == BT_CHARACTER)
3283         {
3284           if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
3285             gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block);
3286         }
3287       else
3288         gcc_assert (gfc_option.flag_f2c
3289                     && proc_sym->ts.type == BT_COMPLEX);
3290     }
3291
3292   /* Initialize the INTENT(OUT) derived type dummy arguments.  This
3293      should be done here so that the offsets and lbounds of arrays
3294      are available.  */
3295   init_intent_out_dt (proc_sym, block);
3296
3297   for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
3298     {
3299       bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
3300                                    && sym->ts.u.derived->attr.alloc_comp;
3301       if (sym->assoc)
3302         trans_associate_var (sym, block);
3303       else if (sym->attr.dimension)
3304         {
3305           switch (sym->as->type)
3306             {
3307             case AS_EXPLICIT:
3308               if (sym->attr.dummy || sym->attr.result)
3309                 gfc_trans_dummy_array_bias (sym, sym->backend_decl, block);
3310               else if (sym->attr.pointer || sym->attr.allocatable)
3311                 {
3312                   if (TREE_STATIC (sym->backend_decl))
3313                     gfc_trans_static_array_pointer (sym);
3314                   else
3315                     {
3316                       seen_trans_deferred_array = true;
3317                       gfc_trans_deferred_array (sym, block);
3318                     }
3319                 }
3320               else
3321                 {
3322                   if (sym_has_alloc_comp)
3323                     {
3324                       seen_trans_deferred_array = true;
3325                       gfc_trans_deferred_array (sym, block);
3326                     }
3327                   else if (sym->ts.type == BT_DERIVED
3328                              && sym->value
3329                              && !sym->attr.data
3330                              && sym->attr.save == SAVE_NONE)
3331                     {
3332                       gfc_start_block (&tmpblock);
3333                       gfc_init_default_dt (sym, &tmpblock, false);
3334                       gfc_add_init_cleanup (block,
3335                                             gfc_finish_block (&tmpblock),
3336                                             NULL_TREE);
3337                     }
3338
3339                   gfc_get_backend_locus (&loc);
3340                   gfc_set_backend_locus (&sym->declared_at);
3341                   gfc_trans_auto_array_allocation (sym->backend_decl,
3342                                                    sym, block);
3343                   gfc_set_backend_locus (&loc);
3344                 }
3345               break;
3346
3347             case AS_ASSUMED_SIZE:
3348               /* Must be a dummy parameter.  */
3349               gcc_assert (sym->attr.dummy || sym->as->cp_was_assumed);
3350
3351               /* We should always pass assumed size arrays the g77 way.  */
3352               if (sym->attr.dummy)
3353                 gfc_trans_g77_array (sym, block);
3354               break;
3355
3356             case AS_ASSUMED_SHAPE:
3357               /* Must be a dummy parameter.  */
3358               gcc_assert (sym->attr.dummy);
3359
3360               gfc_trans_dummy_array_bias (sym, sym->backend_decl, block);
3361               break;
3362
3363             case AS_DEFERRED:
3364               seen_trans_deferred_array = true;
3365               gfc_trans_deferred_array (sym, block);
3366               break;
3367
3368             default:
3369               gcc_unreachable ();
3370             }
3371           if (sym_has_alloc_comp && !seen_trans_deferred_array)
3372             gfc_trans_deferred_array (sym, block);
3373         }
3374       else if (sym->attr.allocatable
3375                || (sym->ts.type == BT_CLASS
3376                    && CLASS_DATA (sym)->attr.allocatable))
3377         {
3378           if (!sym->attr.save)
3379             {
3380               /* Nullify and automatic deallocation of allocatable
3381                  scalars.  */
3382               tree tmp;
3383               gfc_expr *e;
3384               gfc_se se;
3385               stmtblock_t init;
3386
3387               e = gfc_lval_expr_from_sym (sym);
3388               if (sym->ts.type == BT_CLASS)
3389                 gfc_add_component_ref (e, "$data");
3390
3391               gfc_init_se (&se, NULL);
3392               se.want_pointer = 1;
3393               gfc_conv_expr (&se, e);
3394               gfc_free_expr (e);
3395
3396               /* Nullify when entering the scope.  */
3397               gfc_start_block (&init);
3398               gfc_add_modify (&init, se.expr,
3399                               fold_convert (TREE_TYPE (se.expr),
3400                                             null_pointer_node));
3401
3402               /* Deallocate when leaving the scope. Nullifying is not
3403                  needed.  */
3404               tmp = NULL;
3405               if (!sym->attr.result)
3406                 tmp = gfc_deallocate_with_status (se.expr, NULL_TREE,
3407                                                   true, NULL);
3408               gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
3409             }
3410         }
3411       else if (sym_has_alloc_comp)
3412         gfc_trans_deferred_array (sym, block);
3413       else if (sym->ts.type == BT_CHARACTER)
3414         {
3415           gfc_get_backend_locus (&loc);
3416           gfc_set_backend_locus (&sym->declared_at);
3417           if (sym->attr.dummy || sym->attr.result)
3418             gfc_trans_dummy_character (sym, sym->ts.u.cl, block);
3419           else
3420             gfc_trans_auto_character_variable (sym, block);
3421           gfc_set_backend_locus (&loc);
3422         }
3423       else if (sym->attr.assign)
3424         {
3425           gfc_get_backend_locus (&loc);
3426           gfc_set_backend_locus (&sym->declared_at);
3427           gfc_trans_assign_aux_var (sym, block);
3428           gfc_set_backend_locus (&loc);
3429         }
3430       else if (sym->ts.type == BT_DERIVED
3431