OSDN Git Service

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