OSDN Git Service

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