OSDN Git Service

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