OSDN Git Service

PR libfortran/20006
[pf3gnuchains/gcc-fork.git] / gcc / fortran / trans-decl.c
1 /* Backend function setup
2    Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
3    Contributed by Paul Brook
4
5 This file is part of GCC.
6
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 2, or (at your option) any later
10 version.
11
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
15 for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING.  If not, write to the Free
19 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
20 02110-1301, USA.  */
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 "tree-gimple.h"
30 #include "ggc.h"
31 #include "toplev.h"
32 #include "tm.h"
33 #include "target.h"
34 #include "function.h"
35 #include "flags.h"
36 #include "cgraph.h"
37 #include "gfortran.h"
38 #include "trans.h"
39 #include "trans-types.h"
40 #include "trans-array.h"
41 #include "trans-const.h"
42 /* Only for gfc_trans_code.  Shouldn't need to include this.  */
43 #include "trans-stmt.h"
44
45 #define MAX_LABEL_VALUE 99999
46
47
48 /* Holds the result of the function if no result variable specified.  */
49
50 static GTY(()) tree current_fake_result_decl;
51
52 static GTY(()) tree current_function_return_label;
53
54
55 /* Holds the variable DECLs for the current function.  */
56
57 static GTY(()) tree saved_function_decls = NULL_TREE;
58 static GTY(()) tree saved_parent_function_decls = NULL_TREE;
59
60
61 /* The namespace of the module we're currently generating.  Only used while
62    outputting decls for module variables.  Do not rely on this being set.  */
63
64 static gfc_namespace *module_namespace;
65
66
67 /* List of static constructor functions.  */
68
69 tree gfc_static_ctors;
70
71
72 /* Function declarations for builtin library functions.  */
73
74 tree gfor_fndecl_internal_malloc;
75 tree gfor_fndecl_internal_malloc64;
76 tree gfor_fndecl_internal_free;
77 tree gfor_fndecl_allocate;
78 tree gfor_fndecl_allocate64;
79 tree gfor_fndecl_deallocate;
80 tree gfor_fndecl_pause_numeric;
81 tree gfor_fndecl_pause_string;
82 tree gfor_fndecl_stop_numeric;
83 tree gfor_fndecl_stop_string;
84 tree gfor_fndecl_select_string;
85 tree gfor_fndecl_runtime_error;
86 tree gfor_fndecl_set_std;
87 tree gfor_fndecl_in_pack;
88 tree gfor_fndecl_in_unpack;
89 tree gfor_fndecl_associated;
90
91
92 /* Math functions.  Many other math functions are handled in
93    trans-intrinsic.c.  */
94
95 gfc_powdecl_list gfor_fndecl_math_powi[3][2];
96 tree gfor_fndecl_math_cpowf;
97 tree gfor_fndecl_math_cpow;
98 tree gfor_fndecl_math_ishftc4;
99 tree gfor_fndecl_math_ishftc8;
100 tree gfor_fndecl_math_exponent4;
101 tree gfor_fndecl_math_exponent8;
102
103
104 /* String functions.  */
105
106 tree gfor_fndecl_copy_string;
107 tree gfor_fndecl_compare_string;
108 tree gfor_fndecl_concat_string;
109 tree gfor_fndecl_string_len_trim;
110 tree gfor_fndecl_string_index;
111 tree gfor_fndecl_string_scan;
112 tree gfor_fndecl_string_verify;
113 tree gfor_fndecl_string_trim;
114 tree gfor_fndecl_string_repeat;
115 tree gfor_fndecl_adjustl;
116 tree gfor_fndecl_adjustr;
117
118
119 /* Other misc. runtime library functions.  */
120
121 tree gfor_fndecl_size0;
122 tree gfor_fndecl_size1;
123 tree gfor_fndecl_iargc;
124
125 /* Intrinsic functions implemented in FORTRAN.  */
126 tree gfor_fndecl_si_kind;
127 tree gfor_fndecl_sr_kind;
128
129
130 static void
131 gfc_add_decl_to_parent_function (tree decl)
132 {
133   gcc_assert (decl);
134   DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl);
135   DECL_NONLOCAL (decl) = 1;
136   TREE_CHAIN (decl) = saved_parent_function_decls;
137   saved_parent_function_decls = decl;
138 }
139
140 void
141 gfc_add_decl_to_function (tree decl)
142 {
143   gcc_assert (decl);
144   TREE_USED (decl) = 1;
145   DECL_CONTEXT (decl) = current_function_decl;
146   TREE_CHAIN (decl) = saved_function_decls;
147   saved_function_decls = decl;
148 }
149
150
151 /* Build a  backend label declaration.  Set TREE_USED for named labels.
152    The context of the label is always the current_function_decl.  All
153    labels are marked artificial.  */
154
155 tree
156 gfc_build_label_decl (tree label_id)
157 {
158   /* 2^32 temporaries should be enough.  */
159   static unsigned int tmp_num = 1;
160   tree label_decl;
161   char *label_name;
162
163   if (label_id == NULL_TREE)
164     {
165       /* Build an internal label name.  */
166       ASM_FORMAT_PRIVATE_NAME (label_name, "L", tmp_num++);
167       label_id = get_identifier (label_name);
168     }
169   else
170     label_name = NULL;
171
172   /* Build the LABEL_DECL node. Labels have no type.  */
173   label_decl = build_decl (LABEL_DECL, label_id, void_type_node);
174   DECL_CONTEXT (label_decl) = current_function_decl;
175   DECL_MODE (label_decl) = VOIDmode;
176
177   /* We always define the label as used, even if the original source
178      file never references the label.  We don't want all kinds of
179      spurious warnings for old-style Fortran code with too many
180      labels.  */
181   TREE_USED (label_decl) = 1;
182
183   DECL_ARTIFICIAL (label_decl) = 1;
184   return label_decl;
185 }
186
187
188 /* Returns the return label for the current function.  */
189
190 tree
191 gfc_get_return_label (void)
192 {
193   char name[GFC_MAX_SYMBOL_LEN + 10];
194
195   if (current_function_return_label)
196     return current_function_return_label;
197
198   sprintf (name, "__return_%s",
199            IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
200
201   current_function_return_label =
202     gfc_build_label_decl (get_identifier (name));
203
204   DECL_ARTIFICIAL (current_function_return_label) = 1;
205
206   return current_function_return_label;
207 }
208
209
210 /* Set the backend source location of a decl.  */
211
212 void
213 gfc_set_decl_location (tree decl, locus * loc)
214 {
215 #ifdef USE_MAPPED_LOCATION
216   DECL_SOURCE_LOCATION (decl) = loc->lb->location;
217 #else
218   DECL_SOURCE_LINE (decl) = loc->lb->linenum;
219   DECL_SOURCE_FILE (decl) = loc->lb->file->filename;
220 #endif
221 }
222
223
224 /* Return the backend label declaration for a given label structure,
225    or create it if it doesn't exist yet.  */
226
227 tree
228 gfc_get_label_decl (gfc_st_label * lp)
229 {
230   if (lp->backend_decl)
231     return lp->backend_decl;
232   else
233     {
234       char label_name[GFC_MAX_SYMBOL_LEN + 1];
235       tree label_decl;
236
237       /* Validate the label declaration from the front end.  */
238       gcc_assert (lp != NULL && lp->value <= MAX_LABEL_VALUE);
239
240       /* Build a mangled name for the label.  */
241       sprintf (label_name, "__label_%.6d", lp->value);
242
243       /* Build the LABEL_DECL node.  */
244       label_decl = gfc_build_label_decl (get_identifier (label_name));
245
246       /* Tell the debugger where the label came from.  */
247       if (lp->value <= MAX_LABEL_VALUE) /* An internal label.  */
248         gfc_set_decl_location (label_decl, &lp->where);
249       else
250         DECL_ARTIFICIAL (label_decl) = 1;
251
252       /* Store the label in the label list and return the LABEL_DECL.  */
253       lp->backend_decl = label_decl;
254       return label_decl;
255     }
256 }
257
258
259 /* Convert a gfc_symbol to an identifier of the same name.  */
260
261 static tree
262 gfc_sym_identifier (gfc_symbol * sym)
263 {
264   return (get_identifier (sym->name));
265 }
266
267
268 /* Construct mangled name from symbol name.  */
269
270 static tree
271 gfc_sym_mangled_identifier (gfc_symbol * sym)
272 {
273   char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
274
275   if (sym->module == NULL)
276     return gfc_sym_identifier (sym);
277   else
278     {
279       snprintf (name, sizeof name, "__%s__%s", sym->module, sym->name);
280       return get_identifier (name);
281     }
282 }
283
284
285 /* Construct mangled function name from symbol name.  */
286
287 static tree
288 gfc_sym_mangled_function_id (gfc_symbol * sym)
289 {
290   int has_underscore;
291   char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
292
293   if (sym->module == NULL || sym->attr.proc == PROC_EXTERNAL
294       || (sym->module != NULL && sym->attr.if_source == IFSRC_IFBODY))
295     {
296       if (strcmp (sym->name, "MAIN__") == 0
297           || sym->attr.proc == PROC_INTRINSIC)
298         return get_identifier (sym->name);
299
300       if (gfc_option.flag_underscoring)
301         {
302           has_underscore = strchr (sym->name, '_') != 0;
303           if (gfc_option.flag_second_underscore && has_underscore)
304             snprintf (name, sizeof name, "%s__", sym->name);
305           else
306             snprintf (name, sizeof name, "%s_", sym->name);
307           return get_identifier (name);
308         }
309       else
310         return get_identifier (sym->name);
311     }
312   else
313     {
314       snprintf (name, sizeof name, "__%s__%s", sym->module, sym->name);
315       return get_identifier (name);
316     }
317 }
318
319
320 /* Returns true if a variable of specified size should go on the stack.  */
321
322 int
323 gfc_can_put_var_on_stack (tree size)
324 {
325   unsigned HOST_WIDE_INT low;
326
327   if (!INTEGER_CST_P (size))
328     return 0;
329
330   if (gfc_option.flag_max_stack_var_size < 0)
331     return 1;
332
333   if (TREE_INT_CST_HIGH (size) != 0)
334     return 0;
335
336   low = TREE_INT_CST_LOW (size);
337   if (low > (unsigned HOST_WIDE_INT) gfc_option.flag_max_stack_var_size)
338     return 0;
339
340 /* TODO: Set a per-function stack size limit.  */
341
342   return 1;
343 }
344
345
346 /* Finish processing of a declaration and install its initial value.  */
347
348 static void
349 gfc_finish_decl (tree decl, tree init)
350 {
351   if (TREE_CODE (decl) == PARM_DECL)
352     gcc_assert (init == NULL_TREE);
353   /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se
354      -- it overlaps DECL_ARG_TYPE.  */
355   else if (init == NULL_TREE)
356     gcc_assert (DECL_INITIAL (decl) == NULL_TREE);
357   else
358     gcc_assert (DECL_INITIAL (decl) == error_mark_node);
359
360   if (init != NULL_TREE)
361     {
362       if (TREE_CODE (decl) != TYPE_DECL)
363         DECL_INITIAL (decl) = init;
364       else
365         {
366           /* typedef foo = bar; store the type of bar as the type of foo.  */
367           TREE_TYPE (decl) = TREE_TYPE (init);
368           DECL_INITIAL (decl) = init = 0;
369         }
370     }
371
372   if (TREE_CODE (decl) == VAR_DECL)
373     {
374       if (DECL_SIZE (decl) == NULL_TREE
375           && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
376         layout_decl (decl, 0);
377
378       /* A static variable with an incomplete type is an error if it is
379          initialized. Also if it is not file scope. Otherwise, let it
380          through, but if it is not `extern' then it may cause an error
381          message later.  */
382       /* An automatic variable with an incomplete type is an error.  */
383       if (DECL_SIZE (decl) == NULL_TREE
384           && (TREE_STATIC (decl) ? (DECL_INITIAL (decl) != 0
385                                     || DECL_CONTEXT (decl) != 0)
386                                  : !DECL_EXTERNAL (decl)))
387         {
388           gfc_fatal_error ("storage size not known");
389         }
390
391       if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
392           && (DECL_SIZE (decl) != 0)
393           && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
394         {
395           gfc_fatal_error ("storage size not constant");
396         }
397     }
398
399 }
400
401
402 /* Apply symbol attributes to a variable, and add it to the function scope.  */
403
404 static void
405 gfc_finish_var_decl (tree decl, gfc_symbol * sym)
406 {
407   /* TREE_ADDRESSABLE means the address of this variable is actually needed.
408      This is the equivalent of the TARGET variables.
409      We also need to set this if the variable is passed by reference in a
410      CALL statement.  */
411   if (sym->attr.target)
412     TREE_ADDRESSABLE (decl) = 1;
413   /* If it wasn't used we wouldn't be getting it.  */
414   TREE_USED (decl) = 1;
415
416   /* Chain this decl to the pending declarations.  Don't do pushdecl()
417      because this would add them to the current scope rather than the
418      function scope.  */
419   if (current_function_decl != NULL_TREE)
420     {
421       if (sym->ns->proc_name->backend_decl == current_function_decl)
422         gfc_add_decl_to_function (decl);
423       else
424         gfc_add_decl_to_parent_function (decl);
425     }
426
427   /* If a variable is USE associated, it's always external.  */
428   if (sym->attr.use_assoc)
429     {
430       DECL_EXTERNAL (decl) = 1;
431       TREE_PUBLIC (decl) = 1;
432     }
433   else if (sym->module && !sym->attr.result && !sym->attr.dummy)
434     {
435       /* TODO: Don't set sym->module for result or dummy variables.  */
436       gcc_assert (current_function_decl == NULL_TREE);
437       /* This is the declaration of a module variable.  */
438       TREE_PUBLIC (decl) = 1;
439       TREE_STATIC (decl) = 1;
440     }
441
442   if ((sym->attr.save || sym->attr.data || sym->value)
443       && !sym->attr.use_assoc)
444     TREE_STATIC (decl) = 1;
445   
446   /* Keep variables larger than max-stack-var-size off stack.  */
447   if (!sym->ns->proc_name->attr.recursive
448       && INTEGER_CST_P (DECL_SIZE_UNIT (decl))
449       && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl)))
450     TREE_STATIC (decl) = 1;
451 }
452
453
454 /* Allocate the lang-specific part of a decl.  */
455
456 void
457 gfc_allocate_lang_decl (tree decl)
458 {
459   DECL_LANG_SPECIFIC (decl) = (struct lang_decl *)
460     ggc_alloc_cleared (sizeof (struct lang_decl));
461 }
462
463 /* Remember a symbol to generate initialization/cleanup code at function
464    entry/exit.  */
465
466 static void
467 gfc_defer_symbol_init (gfc_symbol * sym)
468 {
469   gfc_symbol *p;
470   gfc_symbol *last;
471   gfc_symbol *head;
472
473   /* Don't add a symbol twice.  */
474   if (sym->tlink)
475     return;
476
477   last = head = sym->ns->proc_name;
478   p = last->tlink;
479
480   /* Make sure that setup code for dummy variables which are used in the
481      setup of other variables is generated first.  */
482   if (sym->attr.dummy)
483     {
484       /* Find the first dummy arg seen after us, or the first non-dummy arg.
485          This is a circular list, so don't go past the head.  */
486       while (p != head
487              && (!p->attr.dummy || p->dummy_order > sym->dummy_order))
488         {
489           last = p;
490           p = p->tlink;
491         }
492     }
493   /* Insert in between last and p.  */
494   last->tlink = sym;
495   sym->tlink = p;
496 }
497
498
499 /* Create an array index type variable with function scope.  */
500
501 static tree
502 create_index_var (const char * pfx, int nest)
503 {
504   tree decl;
505
506   decl = gfc_create_var_np (gfc_array_index_type, pfx);
507   if (nest)
508     gfc_add_decl_to_parent_function (decl);
509   else
510     gfc_add_decl_to_function (decl);
511   return decl;
512 }
513
514
515 /* Create variables to hold all the non-constant bits of info for a
516    descriptorless array.  Remember these in the lang-specific part of the
517    type.  */
518
519 static void
520 gfc_build_qualified_array (tree decl, gfc_symbol * sym)
521 {
522   tree type;
523   int dim;
524   int nest;
525
526   type = TREE_TYPE (decl);
527
528   /* We just use the descriptor, if there is one.  */
529   if (GFC_DESCRIPTOR_TYPE_P (type))
530     return;
531
532   gcc_assert (GFC_ARRAY_TYPE_P (type));
533   nest = (sym->ns->proc_name->backend_decl != current_function_decl)
534          && !sym->attr.contained;
535
536   for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)
537     {
538       if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
539         GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
540       /* Don't try to use the unknown bound for assumed shape arrays.  */
541       if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
542           && (sym->as->type != AS_ASSUMED_SIZE
543               || dim < GFC_TYPE_ARRAY_RANK (type) - 1))
544         GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
545
546       if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE)
547         GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest);
548     }
549   if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)
550     {
551       GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,
552                                                         "offset");
553       if (nest)
554         gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type));
555       else
556         gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));
557     }
558 }
559
560
561 /* For some dummy arguments we don't use the actual argument directly.
562    Instead we create a local decl and use that.  This allows us to perform
563    initialization, and construct full type information.  */
564
565 static tree
566 gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
567 {
568   tree decl;
569   tree type;
570   gfc_array_spec *as;
571   char *name;
572   int packed;
573   int n;
574   bool known_size;
575
576   if (sym->attr.pointer || sym->attr.allocatable)
577     return dummy;
578
579   /* Add to list of variables if not a fake result variable.  */
580   if (sym->attr.result || sym->attr.dummy)
581     gfc_defer_symbol_init (sym);
582
583   type = TREE_TYPE (dummy);
584   gcc_assert (TREE_CODE (dummy) == PARM_DECL
585           && POINTER_TYPE_P (type));
586
587   /* Do we know the element size?  */
588   known_size = sym->ts.type != BT_CHARACTER
589           || INTEGER_CST_P (sym->ts.cl->backend_decl);
590   
591   if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
592     {
593       /* For descriptorless arrays with known element size the actual
594          argument is sufficient.  */
595       gcc_assert (GFC_ARRAY_TYPE_P (type));
596       gfc_build_qualified_array (dummy, sym);
597       return dummy;
598     }
599
600   type = TREE_TYPE (type);
601   if (GFC_DESCRIPTOR_TYPE_P (type))
602     {
603       /* Create a decriptorless array pointer.  */
604       as = sym->as;
605       packed = 0;
606       if (!gfc_option.flag_repack_arrays)
607         {
608           if (as->type == AS_ASSUMED_SIZE)
609             packed = 2;
610         }
611       else
612         {
613           if (as->type == AS_EXPLICIT)
614             {
615               packed = 2;
616               for (n = 0; n < as->rank; n++)
617                 {
618                   if (!(as->upper[n]
619                         && as->lower[n]
620                         && as->upper[n]->expr_type == EXPR_CONSTANT
621                         && as->lower[n]->expr_type == EXPR_CONSTANT))
622                     packed = 1;
623                 }
624             }
625           else
626             packed = 1;
627         }
628
629       type = gfc_typenode_for_spec (&sym->ts);
630       type = gfc_get_nodesc_array_type (type, sym->as, packed);
631     }
632   else
633     {
634       /* We now have an expression for the element size, so create a fully
635          qualified type.  Reset sym->backend decl or this will just return the
636          old type.  */
637       sym->backend_decl = NULL_TREE;
638       type = gfc_sym_type (sym);
639       packed = 2;
640     }
641
642   ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);
643   decl = build_decl (VAR_DECL, get_identifier (name), type);
644
645   DECL_ARTIFICIAL (decl) = 1;
646   TREE_PUBLIC (decl) = 0;
647   TREE_STATIC (decl) = 0;
648   DECL_EXTERNAL (decl) = 0;
649
650   /* We should never get deferred shape arrays here.  We used to because of
651      frontend bugs.  */
652   gcc_assert (sym->as->type != AS_DEFERRED);
653
654   switch (packed)
655     {
656     case 1:
657       GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;
658       break;
659
660     case 2:
661       GFC_DECL_PACKED_ARRAY (decl) = 1;
662       break;
663     }
664
665   gfc_build_qualified_array (decl, sym);
666
667   if (DECL_LANG_SPECIFIC (dummy))
668     DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (dummy);
669   else
670     gfc_allocate_lang_decl (decl);
671
672   GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy;
673
674   if (sym->ns->proc_name->backend_decl == current_function_decl
675       || sym->attr.contained)
676     gfc_add_decl_to_function (decl);
677   else
678     gfc_add_decl_to_parent_function (decl);
679
680   return decl;
681 }
682
683
684 /* Return a constant or a variable to use as a string length.  Does not
685    add the decl to the current scope.  */
686
687 static tree
688 gfc_create_string_length (gfc_symbol * sym)
689 {
690   tree length;
691
692   gcc_assert (sym->ts.cl);
693   gfc_conv_const_charlen (sym->ts.cl);
694   
695   if (sym->ts.cl->backend_decl == NULL_TREE)
696     {
697       char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
698
699       /* Also prefix the mangled name.  */
700       strcpy (&name[1], sym->name);
701       name[0] = '.';
702       length = build_decl (VAR_DECL, get_identifier (name),
703                            gfc_charlen_type_node);
704       DECL_ARTIFICIAL (length) = 1;
705       TREE_USED (length) = 1;
706       gfc_defer_symbol_init (sym);
707       sym->ts.cl->backend_decl = length;
708     }
709
710   return sym->ts.cl->backend_decl;
711 }
712
713
714 /* Return the decl for a gfc_symbol, create it if it doesn't already
715    exist.  */
716
717 tree
718 gfc_get_symbol_decl (gfc_symbol * sym)
719 {
720   tree decl;
721   tree length = NULL_TREE;
722   int byref;
723
724   gcc_assert (sym->attr.referenced);
725
726   if (sym->ns && sym->ns->proc_name->attr.function)
727     byref = gfc_return_by_reference (sym->ns->proc_name);
728   else
729     byref = 0;
730
731   if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
732     {
733       /* Return via extra parameter.  */
734       if (sym->attr.result && byref
735           && !sym->backend_decl)
736         {
737           sym->backend_decl =
738             DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);
739           /* For entry master function skip over the __entry
740              argument.  */
741           if (sym->ns->proc_name->attr.entry_master)
742             sym->backend_decl = TREE_CHAIN (sym->backend_decl);
743         }
744
745       /* Dummy variables should already have been created.  */
746       gcc_assert (sym->backend_decl);
747
748       /* Create a character length variable.  */
749       if (sym->ts.type == BT_CHARACTER)
750         {
751           if (sym->ts.cl->backend_decl == NULL_TREE)
752             {
753               length = gfc_create_string_length (sym);
754               if (TREE_CODE (length) != INTEGER_CST)
755                 {
756                   gfc_finish_var_decl (length, sym);
757                   gfc_defer_symbol_init (sym);
758                 }
759             }
760         }
761
762       /* Use a copy of the descriptor for dummy arrays.  */
763       if (sym->attr.dimension && !TREE_USED (sym->backend_decl))
764         {
765           sym->backend_decl =
766             gfc_build_dummy_array_decl (sym, sym->backend_decl);
767         }
768
769       TREE_USED (sym->backend_decl) = 1;
770       return sym->backend_decl;
771     }
772
773   if (sym->backend_decl)
774     return sym->backend_decl;
775
776   /* Catch function declarations.  Only used for actual parameters.  */
777   if (sym->attr.flavor == FL_PROCEDURE)
778     {
779       decl = gfc_get_extern_function_decl (sym);
780       return decl;
781     }
782
783   if (sym->attr.intrinsic)
784     internal_error ("intrinsic variable which isn't a procedure");
785
786   /* Create string length decl first so that they can be used in the
787      type declaration.  */
788   if (sym->ts.type == BT_CHARACTER)
789     length = gfc_create_string_length (sym);
790
791   /* Create the decl for the variable.  */
792   decl = build_decl (VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
793
794   gfc_set_decl_location (decl, &sym->declared_at);
795
796   /* Symbols from modules should have their assembler names mangled.
797      This is done here rather than in gfc_finish_var_decl because it
798      is different for string length variables.  */
799   if (sym->module)
800     SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_identifier (sym));
801
802   if (sym->attr.dimension)
803     {
804       /* Create variables to hold the non-constant bits of array info.  */
805       gfc_build_qualified_array (decl, sym);
806
807       /* Remember this variable for allocation/cleanup.  */
808       gfc_defer_symbol_init (sym);
809
810       if ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer)
811         GFC_DECL_PACKED_ARRAY (decl) = 1;
812     }
813
814   gfc_finish_var_decl (decl, sym);
815
816   if (sym->attr.assign)
817     {
818       gfc_allocate_lang_decl (decl);
819       GFC_DECL_ASSIGN (decl) = 1;
820       length = gfc_create_var (gfc_charlen_type_node, sym->name);
821       GFC_DECL_STRING_LEN (decl) = length;
822       GFC_DECL_ASSIGN_ADDR (decl) = gfc_create_var (pvoid_type_node, sym->name);
823       /* TODO: Need to check we don't change TREE_STATIC (decl) later.  */
824       TREE_STATIC (length) = TREE_STATIC (decl);
825       /*  STRING_LENGTH is also used as flag. Less than -1 means that
826           ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
827           target label's address. Other value is the length of format string
828           and ASSIGN_ADDR is the address of format string.  */
829       DECL_INITIAL (length) = build_int_cst (NULL_TREE, -2);
830     }
831
832   if (sym->ts.type == BT_CHARACTER)
833     {
834       /* Character variables need special handling.  */
835       gfc_allocate_lang_decl (decl);
836
837       if (TREE_CODE (length) != INTEGER_CST)
838         {
839           char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
840
841           if (sym->module)
842             {
843               /* Also prefix the mangled name for symbols from modules.  */
844               strcpy (&name[1], sym->name);
845               name[0] = '.';
846               strcpy (&name[1],
847                       IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length)));
848               SET_DECL_ASSEMBLER_NAME (decl, get_identifier (name));
849             }
850           gfc_finish_var_decl (length, sym);
851           gcc_assert (!sym->value);
852         }
853     }
854   sym->backend_decl = decl;
855
856   if (TREE_STATIC (decl) && !sym->attr.use_assoc)
857     {
858       /* Add static initializer.  */
859       DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
860           TREE_TYPE (decl), sym->attr.dimension,
861           sym->attr.pointer || sym->attr.allocatable);
862     }
863
864   return decl;
865 }
866
867
868 /* Substitute a temporary variable in place of the real one.  */
869
870 void
871 gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
872 {
873   save->attr = sym->attr;
874   save->decl = sym->backend_decl;
875
876   gfc_clear_attr (&sym->attr);
877   sym->attr.referenced = 1;
878   sym->attr.flavor = FL_VARIABLE;
879
880   sym->backend_decl = decl;
881 }
882
883
884 /* Restore the original variable.  */
885
886 void
887 gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
888 {
889   sym->attr = save->attr;
890   sym->backend_decl = save->decl;
891 }
892
893
894 /* Get a basic decl for an external function.  */
895
896 tree
897 gfc_get_extern_function_decl (gfc_symbol * sym)
898 {
899   tree type;
900   tree fndecl;
901   gfc_expr e;
902   gfc_intrinsic_sym *isym;
903   gfc_expr argexpr;
904   char s[GFC_MAX_SYMBOL_LEN + 13]; /* "f2c_specific" and '\0'.  */
905   tree name;
906   tree mangled_name;
907
908   if (sym->backend_decl)
909     return sym->backend_decl;
910
911   /* We should never be creating external decls for alternate entry points.
912      The procedure may be an alternate entry point, but we don't want/need
913      to know that.  */
914   gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
915
916   if (sym->attr.intrinsic)
917     {
918       /* Call the resolution function to get the actual name.  This is
919          a nasty hack which relies on the resolution functions only looking
920          at the first argument.  We pass NULL for the second argument
921          otherwise things like AINT get confused.  */
922       isym = gfc_find_function (sym->name);
923       gcc_assert (isym->resolve.f0 != NULL);
924
925       memset (&e, 0, sizeof (e));
926       e.expr_type = EXPR_FUNCTION;
927
928       memset (&argexpr, 0, sizeof (argexpr));
929       gcc_assert (isym->formal);
930       argexpr.ts = isym->formal->ts;
931
932       if (isym->formal->next == NULL)
933         isym->resolve.f1 (&e, &argexpr);
934       else
935         {
936           /* All specific intrinsics take one or two arguments.  */
937           gcc_assert (isym->formal->next->next == NULL);
938           isym->resolve.f2 (&e, &argexpr, NULL);
939         }
940
941       if (gfc_option.flag_f2c
942           && ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)
943               || e.ts.type == BT_COMPLEX))
944         {
945           /* Specific which needs a different implementation if f2c
946              calling conventions are used.  */
947           sprintf (s, "f2c_specific%s", e.value.function.name);
948         }
949       else
950         sprintf (s, "specific%s", e.value.function.name);
951
952       name = get_identifier (s);
953       mangled_name = name;
954     }
955   else
956     {
957       name = gfc_sym_identifier (sym);
958       mangled_name = gfc_sym_mangled_function_id (sym);
959     }
960
961   type = gfc_get_function_type (sym);
962   fndecl = build_decl (FUNCTION_DECL, name, type);
963
964   SET_DECL_ASSEMBLER_NAME (fndecl, mangled_name);
965   /* If the return type is a pointer, avoid alias issues by setting
966      DECL_IS_MALLOC to nonzero. This means that the function should be
967      treated as if it were a malloc, meaning it returns a pointer that
968      is not an alias.  */
969   if (POINTER_TYPE_P (type))
970     DECL_IS_MALLOC (fndecl) = 1;
971
972   /* Set the context of this decl.  */
973   if (0 && sym->ns && sym->ns->proc_name)
974     {
975       /* TODO: Add external decls to the appropriate scope.  */
976       DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
977     }
978   else
979     {
980       /* Global declaration, e.g. intrinsic subroutine.  */
981       DECL_CONTEXT (fndecl) = NULL_TREE;
982     }
983
984   DECL_EXTERNAL (fndecl) = 1;
985
986   /* This specifies if a function is globally addressable, i.e. it is
987      the opposite of declaring static in C.  */
988   TREE_PUBLIC (fndecl) = 1;
989
990   /* Set attributes for PURE functions. A call to PURE function in the
991      Fortran 95 sense is both pure and without side effects in the C
992      sense.  */
993   if (sym->attr.pure || sym->attr.elemental)
994     {
995       if (sym->attr.function)
996         DECL_IS_PURE (fndecl) = 1;
997       /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
998          parameters and don't use alternate returns (is this
999          allowed?). In that case, calls to them are meaningless, and
1000          can be optimized away. See also in build_function_decl().  */
1001       TREE_SIDE_EFFECTS (fndecl) = 0;
1002     }
1003
1004   sym->backend_decl = fndecl;
1005
1006   if (DECL_CONTEXT (fndecl) == NULL_TREE)
1007     pushdecl_top_level (fndecl);
1008
1009   return fndecl;
1010 }
1011
1012
1013 /* Create a declaration for a procedure.  For external functions (in the C
1014    sense) use gfc_get_extern_function_decl.  HAS_ENTRIES is true if this is
1015    a master function with alternate entry points.  */
1016
1017 static void
1018 build_function_decl (gfc_symbol * sym)
1019 {
1020   tree fndecl, type;
1021   symbol_attribute attr;
1022   tree result_decl;
1023   gfc_formal_arglist *f;
1024
1025   gcc_assert (!sym->backend_decl);
1026   gcc_assert (!sym->attr.external);
1027
1028   /* Set the line and filename.  sym->declared_at seems to point to the
1029      last statement for subroutines, but it'll do for now.  */
1030   gfc_set_backend_locus (&sym->declared_at);
1031
1032   /* Allow only one nesting level.  Allow public declarations.  */
1033   gcc_assert (current_function_decl == NULL_TREE
1034           || DECL_CONTEXT (current_function_decl) == NULL_TREE);
1035
1036   type = gfc_get_function_type (sym);
1037   fndecl = build_decl (FUNCTION_DECL, gfc_sym_identifier (sym), type);
1038
1039   /* Perform name mangling if this is a top level or module procedure.  */
1040   if (current_function_decl == NULL_TREE)
1041     SET_DECL_ASSEMBLER_NAME (fndecl, gfc_sym_mangled_function_id (sym));
1042
1043   /* Figure out the return type of the declared function, and build a
1044      RESULT_DECL for it.  If this is a subroutine with alternate
1045      returns, build a RESULT_DECL for it.  */
1046   attr = sym->attr;
1047
1048   result_decl = NULL_TREE;
1049   /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)).  */
1050   if (attr.function)
1051     {
1052       if (gfc_return_by_reference (sym))
1053         type = void_type_node;
1054       else
1055         {
1056           if (sym->result != sym)
1057             result_decl = gfc_sym_identifier (sym->result);
1058
1059           type = TREE_TYPE (TREE_TYPE (fndecl));
1060         }
1061     }
1062   else
1063     {
1064       /* Look for alternate return placeholders.  */
1065       int has_alternate_returns = 0;
1066       for (f = sym->formal; f; f = f->next)
1067         {
1068           if (f->sym == NULL)
1069             {
1070               has_alternate_returns = 1;
1071               break;
1072             }
1073         }
1074
1075       if (has_alternate_returns)
1076         type = integer_type_node;
1077       else
1078         type = void_type_node;
1079     }
1080
1081   result_decl = build_decl (RESULT_DECL, result_decl, type);
1082   DECL_ARTIFICIAL (result_decl) = 1;
1083   DECL_IGNORED_P (result_decl) = 1;
1084   DECL_CONTEXT (result_decl) = fndecl;
1085   DECL_RESULT (fndecl) = result_decl;
1086
1087   /* Don't call layout_decl for a RESULT_DECL.
1088      layout_decl (result_decl, 0);  */
1089
1090   /* If the return type is a pointer, avoid alias issues by setting
1091      DECL_IS_MALLOC to nonzero. This means that the function should be
1092      treated as if it were a malloc, meaning it returns a pointer that
1093      is not an alias.  */
1094   if (POINTER_TYPE_P (type))
1095     DECL_IS_MALLOC (fndecl) = 1;
1096
1097   /* Set up all attributes for the function.  */
1098   DECL_CONTEXT (fndecl) = current_function_decl;
1099   DECL_EXTERNAL (fndecl) = 0;
1100
1101   /* This specifies if a function is globally visible, i.e. it is
1102      the opposite of declaring static in C.  */
1103   if (DECL_CONTEXT (fndecl) == NULL_TREE
1104       && !sym->attr.entry_master)
1105     TREE_PUBLIC (fndecl) = 1;
1106
1107   /* TREE_STATIC means the function body is defined here.  */
1108   TREE_STATIC (fndecl) = 1;
1109
1110   /* Set attributes for PURE functions. A call to a PURE function in the
1111      Fortran 95 sense is both pure and without side effects in the C
1112      sense.  */
1113   if (attr.pure || attr.elemental)
1114     {
1115       /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
1116          including a alternate return. In that case it can also be
1117          marked as PURE. See also in gfc_get_extern_function_decl().  */
1118       if (attr.function)
1119         DECL_IS_PURE (fndecl) = 1;
1120       TREE_SIDE_EFFECTS (fndecl) = 0;
1121     }
1122
1123   /* Layout the function declaration and put it in the binding level
1124      of the current function.  */
1125   pushdecl (fndecl);
1126
1127   sym->backend_decl = fndecl;
1128 }
1129
1130
1131 /* Create the DECL_ARGUMENTS for a procedure.  */
1132
1133 static void
1134 create_function_arglist (gfc_symbol * sym)
1135 {
1136   tree fndecl;
1137   gfc_formal_arglist *f;
1138   tree typelist;
1139   tree arglist;
1140   tree length;
1141   tree type;
1142   tree parm;
1143
1144   fndecl = sym->backend_decl;
1145
1146   /* Build formal argument list. Make sure that their TREE_CONTEXT is
1147      the new FUNCTION_DECL node.  */
1148   arglist = NULL_TREE;
1149   typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
1150
1151   if (sym->attr.entry_master)
1152     {
1153       type = TREE_VALUE (typelist);
1154       parm = build_decl (PARM_DECL, get_identifier ("__entry"), type);
1155       
1156       DECL_CONTEXT (parm) = fndecl;
1157       DECL_ARG_TYPE (parm) = type;
1158       TREE_READONLY (parm) = 1;
1159       gfc_finish_decl (parm, NULL_TREE);
1160
1161       arglist = chainon (arglist, parm);
1162       typelist = TREE_CHAIN (typelist);
1163     }
1164
1165   if (gfc_return_by_reference (sym))
1166     {
1167       type = TREE_VALUE (typelist);
1168       parm = build_decl (PARM_DECL, get_identifier ("__result"), type);
1169
1170       DECL_CONTEXT (parm) = fndecl;
1171       DECL_ARG_TYPE (parm) = type;
1172       TREE_READONLY (parm) = 1;
1173       DECL_ARTIFICIAL (parm) = 1;
1174       gfc_finish_decl (parm, NULL_TREE);
1175
1176       arglist = chainon (arglist, parm);
1177       typelist = TREE_CHAIN (typelist);
1178
1179       if (sym->ts.type == BT_CHARACTER)
1180         {
1181           gfc_allocate_lang_decl (parm);
1182
1183           /* Length of character result.  */
1184           type = TREE_VALUE (typelist);
1185           gcc_assert (type == gfc_charlen_type_node);
1186
1187           length = build_decl (PARM_DECL,
1188                                get_identifier (".__result"),
1189                                type);
1190           if (!sym->ts.cl->length)
1191             {
1192               sym->ts.cl->backend_decl = length;
1193               TREE_USED (length) = 1;
1194             }
1195           gcc_assert (TREE_CODE (length) == PARM_DECL);
1196           arglist = chainon (arglist, length);
1197           typelist = TREE_CHAIN (typelist);
1198           DECL_CONTEXT (length) = fndecl;
1199           DECL_ARG_TYPE (length) = type;
1200           TREE_READONLY (length) = 1;
1201           DECL_ARTIFICIAL (length) = 1;
1202           gfc_finish_decl (length, NULL_TREE);
1203         }
1204     }
1205
1206   for (f = sym->formal; f; f = f->next)
1207     {
1208       if (f->sym != NULL)       /* ignore alternate returns.  */
1209         {
1210           length = NULL_TREE;
1211
1212           type = TREE_VALUE (typelist);
1213
1214           /* Build a the argument declaration.  */
1215           parm = build_decl (PARM_DECL,
1216                              gfc_sym_identifier (f->sym), type);
1217
1218           /* Fill in arg stuff.  */
1219           DECL_CONTEXT (parm) = fndecl;
1220           DECL_ARG_TYPE (parm) = type;
1221           /* All implementation args are read-only.  */
1222           TREE_READONLY (parm) = 1;
1223
1224           gfc_finish_decl (parm, NULL_TREE);
1225
1226           f->sym->backend_decl = parm;
1227
1228           arglist = chainon (arglist, parm);
1229           typelist = TREE_CHAIN (typelist);
1230         }
1231     }
1232
1233   /* Add the hidden string length parameters.  */
1234   parm = arglist;
1235   for (f = sym->formal; f; f = f->next)
1236     {
1237       char name[GFC_MAX_SYMBOL_LEN + 2];
1238       /* Ignore alternate returns.  */
1239       if (f->sym == NULL)
1240         continue;
1241
1242       if (f->sym->ts.type != BT_CHARACTER)
1243         continue;
1244
1245       parm = f->sym->backend_decl;
1246       type = TREE_VALUE (typelist);
1247       gcc_assert (type == gfc_charlen_type_node);
1248
1249       strcpy (&name[1], f->sym->name);
1250       name[0] = '_';
1251       length = build_decl (PARM_DECL, get_identifier (name), type);
1252
1253       arglist = chainon (arglist, length);
1254       DECL_CONTEXT (length) = fndecl;
1255       DECL_ARTIFICIAL (length) = 1;
1256       DECL_ARG_TYPE (length) = type;
1257       TREE_READONLY (length) = 1;
1258       gfc_finish_decl (length, NULL_TREE);
1259
1260       /* TODO: Check string lengths when -fbounds-check.  */
1261
1262       /* Use the passed value for assumed length variables.  */
1263       if (!f->sym->ts.cl->length)
1264         {
1265           TREE_USED (length) = 1;
1266           if (!f->sym->ts.cl->backend_decl)
1267             f->sym->ts.cl->backend_decl = length;
1268           else
1269             {
1270               /* there is already another variable using this
1271                  gfc_charlen node, build a new one for this variable
1272                  and chain it into the list of gfc_charlens.
1273                  This happens for e.g. in the case
1274                  CHARACTER(*)::c1,c2
1275                  since CHARACTER declarations on the same line share
1276                  the same gfc_charlen node.  */
1277               gfc_charlen *cl;
1278               
1279               cl = gfc_get_charlen ();
1280               cl->backend_decl = length;
1281               cl->next = f->sym->ts.cl->next;
1282               f->sym->ts.cl->next = cl;
1283               f->sym->ts.cl = cl;
1284             }
1285         }
1286
1287       parm = TREE_CHAIN (parm);
1288       typelist = TREE_CHAIN (typelist);
1289     }
1290
1291   gcc_assert (TREE_VALUE (typelist) == void_type_node);
1292   DECL_ARGUMENTS (fndecl) = arglist;
1293 }
1294
1295 /* Convert FNDECL's code to GIMPLE and handle any nested functions.  */
1296
1297 static void
1298 gfc_gimplify_function (tree fndecl)
1299 {
1300   struct cgraph_node *cgn;
1301
1302   gimplify_function_tree (fndecl);
1303   dump_function (TDI_generic, fndecl);
1304
1305   /* Convert all nested functions to GIMPLE now.  We do things in this order
1306      so that items like VLA sizes are expanded properly in the context of the
1307      correct function.  */
1308   cgn = cgraph_node (fndecl);
1309   for (cgn = cgn->nested; cgn; cgn = cgn->next_nested)
1310     gfc_gimplify_function (cgn->decl);
1311 }
1312
1313
1314 /* Do the setup necessary before generating the body of a function.  */
1315
1316 static void
1317 trans_function_start (gfc_symbol * sym)
1318 {
1319   tree fndecl;
1320
1321   fndecl = sym->backend_decl;
1322
1323   /* Let GCC know the current scope is this function.  */
1324   current_function_decl = fndecl;
1325
1326   /* Let the world know what we're about to do.  */
1327   announce_function (fndecl);
1328
1329   if (DECL_CONTEXT (fndecl) == NULL_TREE)
1330     {
1331       /* Create RTL for function declaration.  */
1332       rest_of_decl_compilation (fndecl, 1, 0);
1333     }
1334
1335   /* Create RTL for function definition.  */
1336   make_decl_rtl (fndecl);
1337
1338   init_function_start (fndecl);
1339
1340   /* Even though we're inside a function body, we still don't want to
1341      call expand_expr to calculate the size of a variable-sized array.
1342      We haven't necessarily assigned RTL to all variables yet, so it's
1343      not safe to try to expand expressions involving them.  */
1344   cfun->x_dont_save_pending_sizes_p = 1;
1345
1346   /* function.c requires a push at the start of the function.  */
1347   pushlevel (0);
1348 }
1349
1350 /* Create thunks for alternate entry points.  */
1351
1352 static void
1353 build_entry_thunks (gfc_namespace * ns)
1354 {
1355   gfc_formal_arglist *formal;
1356   gfc_formal_arglist *thunk_formal;
1357   gfc_entry_list *el;
1358   gfc_symbol *thunk_sym;
1359   stmtblock_t body;
1360   tree thunk_fndecl;
1361   tree args;
1362   tree string_args;
1363   tree tmp;
1364   locus old_loc;
1365
1366   /* This should always be a toplevel function.  */
1367   gcc_assert (current_function_decl == NULL_TREE);
1368
1369   gfc_get_backend_locus (&old_loc);
1370   for (el = ns->entries; el; el = el->next)
1371     {
1372       thunk_sym = el->sym;
1373       
1374       build_function_decl (thunk_sym);
1375       create_function_arglist (thunk_sym);
1376
1377       trans_function_start (thunk_sym);
1378
1379       thunk_fndecl = thunk_sym->backend_decl;
1380
1381       gfc_start_block (&body);
1382
1383       /* Pass extra parameter identifying this entry point.  */
1384       tmp = build_int_cst (gfc_array_index_type, el->id);
1385       args = tree_cons (NULL_TREE, tmp, NULL_TREE);
1386       string_args = NULL_TREE;
1387
1388       if (thunk_sym->attr.function)
1389         {
1390           if (gfc_return_by_reference (ns->proc_name))
1391             {
1392               tree ref = DECL_ARGUMENTS (current_function_decl);
1393               args = tree_cons (NULL_TREE, ref, args);
1394               if (ns->proc_name->ts.type == BT_CHARACTER)
1395                 args = tree_cons (NULL_TREE, TREE_CHAIN (ref),
1396                                   args);
1397             }
1398         }
1399
1400       for (formal = ns->proc_name->formal; formal; formal = formal->next)
1401         {
1402           /* Ignore alternate returns.  */
1403           if (formal->sym == NULL)
1404             continue;
1405
1406           /* We don't have a clever way of identifying arguments, so resort to
1407              a brute-force search.  */
1408           for (thunk_formal = thunk_sym->formal;
1409                thunk_formal;
1410                thunk_formal = thunk_formal->next)
1411             {
1412               if (thunk_formal->sym == formal->sym)
1413                 break;
1414             }
1415
1416           if (thunk_formal)
1417             {
1418               /* Pass the argument.  */
1419               args = tree_cons (NULL_TREE, thunk_formal->sym->backend_decl,
1420                                 args);
1421               if (formal->sym->ts.type == BT_CHARACTER)
1422                 {
1423                   tmp = thunk_formal->sym->ts.cl->backend_decl;
1424                   string_args = tree_cons (NULL_TREE, tmp, string_args);
1425                 }
1426             }
1427           else
1428             {
1429               /* Pass NULL for a missing argument.  */
1430               args = tree_cons (NULL_TREE, null_pointer_node, args);
1431               if (formal->sym->ts.type == BT_CHARACTER)
1432                 {
1433                   tmp = convert (gfc_charlen_type_node, integer_zero_node);
1434                   string_args = tree_cons (NULL_TREE, tmp, string_args);
1435                 }
1436             }
1437         }
1438
1439       /* Call the master function.  */
1440       args = nreverse (args);
1441       args = chainon (args, nreverse (string_args));
1442       tmp = ns->proc_name->backend_decl;
1443       tmp = gfc_build_function_call (tmp, args);
1444       if (ns->proc_name->attr.mixed_entry_master)
1445         {
1446           tree union_decl, field;
1447           tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
1448
1449           union_decl = build_decl (VAR_DECL, get_identifier ("__result"),
1450                                    TREE_TYPE (master_type));
1451           DECL_ARTIFICIAL (union_decl) = 1;
1452           DECL_EXTERNAL (union_decl) = 0;
1453           TREE_PUBLIC (union_decl) = 0;
1454           TREE_USED (union_decl) = 1;
1455           layout_decl (union_decl, 0);
1456           pushdecl (union_decl);
1457
1458           DECL_CONTEXT (union_decl) = current_function_decl;
1459           tmp = build2 (MODIFY_EXPR,
1460                         TREE_TYPE (union_decl),
1461                         union_decl, tmp);
1462           gfc_add_expr_to_block (&body, tmp);
1463
1464           for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
1465                field; field = TREE_CHAIN (field))
1466             if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
1467                 thunk_sym->result->name) == 0)
1468               break;
1469           gcc_assert (field != NULL_TREE);
1470           tmp = build3 (COMPONENT_REF, TREE_TYPE (field), union_decl, field,
1471                         NULL_TREE);
1472           tmp = build2 (MODIFY_EXPR,
1473                         TREE_TYPE (DECL_RESULT (current_function_decl)),
1474                         DECL_RESULT (current_function_decl), tmp);
1475           tmp = build1_v (RETURN_EXPR, tmp);
1476         }
1477       else if (TREE_TYPE (DECL_RESULT (current_function_decl))
1478                != void_type_node)
1479         {
1480           tmp = build2 (MODIFY_EXPR,
1481                         TREE_TYPE (DECL_RESULT (current_function_decl)),
1482                         DECL_RESULT (current_function_decl), tmp);
1483           tmp = build1_v (RETURN_EXPR, tmp);
1484         }
1485       gfc_add_expr_to_block (&body, tmp);
1486
1487       /* Finish off this function and send it for code generation.  */
1488       DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
1489       poplevel (1, 0, 1);
1490       BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
1491
1492       /* Output the GENERIC tree.  */
1493       dump_function (TDI_original, thunk_fndecl);
1494
1495       /* Store the end of the function, so that we get good line number
1496          info for the epilogue.  */
1497       cfun->function_end_locus = input_location;
1498
1499       /* We're leaving the context of this function, so zap cfun.
1500          It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
1501          tree_rest_of_compilation.  */
1502       cfun = NULL;
1503
1504       current_function_decl = NULL_TREE;
1505
1506       gfc_gimplify_function (thunk_fndecl);
1507       cgraph_finalize_function (thunk_fndecl, false);
1508
1509       /* We share the symbols in the formal argument list with other entry
1510          points and the master function.  Clear them so that they are
1511          recreated for each function.  */
1512       for (formal = thunk_sym->formal; formal; formal = formal->next)
1513         if (formal->sym != NULL)  /* Ignore alternate returns.  */
1514           {
1515             formal->sym->backend_decl = NULL_TREE;
1516             if (formal->sym->ts.type == BT_CHARACTER)
1517               formal->sym->ts.cl->backend_decl = NULL_TREE;
1518           }
1519
1520       if (thunk_sym->attr.function)
1521         {
1522           if (thunk_sym->ts.type == BT_CHARACTER)
1523             thunk_sym->ts.cl->backend_decl = NULL_TREE;
1524           if (thunk_sym->result->ts.type == BT_CHARACTER)
1525             thunk_sym->result->ts.cl->backend_decl = NULL_TREE;
1526         }
1527     }
1528
1529   gfc_set_backend_locus (&old_loc);
1530 }
1531
1532
1533 /* Create a decl for a function, and create any thunks for alternate entry
1534    points.  */
1535
1536 void
1537 gfc_create_function_decl (gfc_namespace * ns)
1538 {
1539   /* Create a declaration for the master function.  */
1540   build_function_decl (ns->proc_name);
1541
1542   /* Compile the entry thunks.  */
1543   if (ns->entries)
1544     build_entry_thunks (ns);
1545
1546   /* Now create the read argument list.  */
1547   create_function_arglist (ns->proc_name);
1548 }
1549
1550 /* Return the decl used to hold the function return value.  */
1551
1552 tree
1553 gfc_get_fake_result_decl (gfc_symbol * sym)
1554 {
1555   tree decl;
1556   tree length;
1557
1558   char name[GFC_MAX_SYMBOL_LEN + 10];
1559
1560   if (sym
1561       && sym->ns->proc_name->backend_decl == current_function_decl
1562       && sym->ns->proc_name->attr.mixed_entry_master
1563       && sym != sym->ns->proc_name)
1564     {
1565       decl = gfc_get_fake_result_decl (sym->ns->proc_name);
1566       if (decl)
1567         {
1568           tree field;
1569
1570           for (field = TYPE_FIELDS (TREE_TYPE (decl));
1571                field; field = TREE_CHAIN (field))
1572             if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
1573                 sym->name) == 0)
1574               break;
1575
1576           gcc_assert (field != NULL_TREE);
1577           decl = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field,
1578                          NULL_TREE);
1579         }
1580       return decl;
1581     }
1582
1583   if (current_fake_result_decl != NULL_TREE)
1584     return current_fake_result_decl;
1585
1586   /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
1587      sym is NULL.  */
1588   if (!sym)
1589     return NULL_TREE;
1590
1591   if (sym->ts.type == BT_CHARACTER
1592       && !sym->ts.cl->backend_decl)
1593     {
1594       length = gfc_create_string_length (sym);
1595       gfc_finish_var_decl (length, sym);
1596     }
1597
1598   if (gfc_return_by_reference (sym))
1599     {
1600       decl = DECL_ARGUMENTS (current_function_decl);
1601
1602       if (sym->ns->proc_name->backend_decl == current_function_decl
1603           && sym->ns->proc_name->attr.entry_master)
1604         decl = TREE_CHAIN (decl);
1605
1606       TREE_USED (decl) = 1;
1607       if (sym->as)
1608         decl = gfc_build_dummy_array_decl (sym, decl);
1609     }
1610   else
1611     {
1612       sprintf (name, "__result_%.20s",
1613                IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
1614
1615       decl = build_decl (VAR_DECL, get_identifier (name),
1616                          TREE_TYPE (TREE_TYPE (current_function_decl)));
1617
1618       DECL_ARTIFICIAL (decl) = 1;
1619       DECL_EXTERNAL (decl) = 0;
1620       TREE_PUBLIC (decl) = 0;
1621       TREE_USED (decl) = 1;
1622
1623       layout_decl (decl, 0);
1624
1625       gfc_add_decl_to_function (decl);
1626     }
1627
1628   current_fake_result_decl = decl;
1629
1630   return decl;
1631 }
1632
1633
1634 /* Builds a function decl.  The remaining parameters are the types of the
1635    function arguments.  Negative nargs indicates a varargs function.  */
1636
1637 tree
1638 gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
1639 {
1640   tree arglist;
1641   tree argtype;
1642   tree fntype;
1643   tree fndecl;
1644   va_list p;
1645   int n;
1646
1647   /* Library functions must be declared with global scope.  */
1648   gcc_assert (current_function_decl == NULL_TREE);
1649
1650   va_start (p, nargs);
1651
1652
1653   /* Create a list of the argument types.  */
1654   for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
1655     {
1656       argtype = va_arg (p, tree);
1657       arglist = gfc_chainon_list (arglist, argtype);
1658     }
1659
1660   if (nargs >= 0)
1661     {
1662       /* Terminate the list.  */
1663       arglist = gfc_chainon_list (arglist, void_type_node);
1664     }
1665
1666   /* Build the function type and decl.  */
1667   fntype = build_function_type (rettype, arglist);
1668   fndecl = build_decl (FUNCTION_DECL, name, fntype);
1669
1670   /* Mark this decl as external.  */
1671   DECL_EXTERNAL (fndecl) = 1;
1672   TREE_PUBLIC (fndecl) = 1;
1673
1674   va_end (p);
1675
1676   pushdecl (fndecl);
1677
1678   rest_of_decl_compilation (fndecl, 1, 0);
1679
1680   return fndecl;
1681 }
1682
1683 static void
1684 gfc_build_intrinsic_function_decls (void)
1685 {
1686   tree gfc_int4_type_node = gfc_get_int_type (4);
1687   tree gfc_int8_type_node = gfc_get_int_type (8);
1688   tree gfc_logical4_type_node = gfc_get_logical_type (4);
1689   tree gfc_real4_type_node = gfc_get_real_type (4);
1690   tree gfc_real8_type_node = gfc_get_real_type (8);
1691   tree gfc_complex4_type_node = gfc_get_complex_type (4);
1692   tree gfc_complex8_type_node = gfc_get_complex_type (8);
1693
1694   /* String functions.  */
1695   gfor_fndecl_copy_string =
1696     gfc_build_library_function_decl (get_identifier (PREFIX("copy_string")),
1697                                      void_type_node,
1698                                      4,
1699                                      gfc_charlen_type_node, pchar_type_node,
1700                                      gfc_charlen_type_node, pchar_type_node);
1701
1702   gfor_fndecl_compare_string =
1703     gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),
1704                                      gfc_int4_type_node,
1705                                      4,
1706                                      gfc_charlen_type_node, pchar_type_node,
1707                                      gfc_charlen_type_node, pchar_type_node);
1708
1709   gfor_fndecl_concat_string =
1710     gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),
1711                                      void_type_node,
1712                                      6,
1713                                      gfc_charlen_type_node, pchar_type_node,
1714                                      gfc_charlen_type_node, pchar_type_node,
1715                                      gfc_charlen_type_node, pchar_type_node);
1716
1717   gfor_fndecl_string_len_trim =
1718     gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")),
1719                                      gfc_int4_type_node,
1720                                      2, gfc_charlen_type_node,
1721                                      pchar_type_node);
1722
1723   gfor_fndecl_string_index =
1724     gfc_build_library_function_decl (get_identifier (PREFIX("string_index")),
1725                                      gfc_int4_type_node,
1726                                      5, gfc_charlen_type_node, pchar_type_node,
1727                                      gfc_charlen_type_node, pchar_type_node,
1728                                      gfc_logical4_type_node);
1729
1730   gfor_fndecl_string_scan =
1731     gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")),
1732                                      gfc_int4_type_node,
1733                                      5, gfc_charlen_type_node, pchar_type_node,
1734                                      gfc_charlen_type_node, pchar_type_node,
1735                                      gfc_logical4_type_node);
1736
1737   gfor_fndecl_string_verify =
1738     gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")),
1739                                      gfc_int4_type_node,
1740                                      5, gfc_charlen_type_node, pchar_type_node,
1741                                      gfc_charlen_type_node, pchar_type_node,
1742                                      gfc_logical4_type_node);
1743
1744   gfor_fndecl_string_trim = 
1745     gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),
1746                                      void_type_node,
1747                                      4,
1748                                      build_pointer_type (gfc_charlen_type_node),
1749                                      ppvoid_type_node,
1750                                      gfc_charlen_type_node,
1751                                      pchar_type_node);
1752
1753   gfor_fndecl_string_repeat =
1754     gfc_build_library_function_decl (get_identifier (PREFIX("string_repeat")),
1755                                      void_type_node,
1756                                      4,
1757                                      pchar_type_node,
1758                                      gfc_charlen_type_node,
1759                                      pchar_type_node,
1760                                      gfc_int4_type_node);
1761
1762   gfor_fndecl_adjustl =
1763     gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),
1764                                      void_type_node,
1765                                      3,
1766                                      pchar_type_node,
1767                                      gfc_charlen_type_node, pchar_type_node);
1768
1769   gfor_fndecl_adjustr =
1770     gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")),
1771                                      void_type_node,
1772                                      3,
1773                                      pchar_type_node,
1774                                      gfc_charlen_type_node, pchar_type_node);
1775
1776   gfor_fndecl_si_kind =
1777     gfc_build_library_function_decl (get_identifier ("selected_int_kind"),
1778                                      gfc_int4_type_node,
1779                                      1,
1780                                      pvoid_type_node);
1781
1782   gfor_fndecl_sr_kind =
1783     gfc_build_library_function_decl (get_identifier ("selected_real_kind"),
1784                                      gfc_int4_type_node,
1785                                      2, pvoid_type_node,
1786                                      pvoid_type_node);
1787
1788   /* Power functions.  */
1789   {
1790     tree type;
1791     tree itype;
1792     int kind;
1793     int ikind;
1794     static int kinds[2] = {4, 8};
1795     char name[PREFIX_LEN + 10]; /* _gfortran_pow_?n_?n */
1796
1797     for (ikind=0; ikind < 2; ikind++)
1798       {
1799         itype = gfc_get_int_type (kinds[ikind]);
1800         for (kind = 0; kind < 2; kind ++)
1801           {
1802             type = gfc_get_int_type (kinds[kind]);
1803             sprintf(name, PREFIX("pow_i%d_i%d"), kinds[kind], kinds[ikind]);
1804             gfor_fndecl_math_powi[kind][ikind].integer =
1805               gfc_build_library_function_decl (get_identifier (name),
1806                   type, 2, type, itype);
1807
1808             type = gfc_get_real_type (kinds[kind]);
1809             sprintf(name, PREFIX("pow_r%d_i%d"), kinds[kind], kinds[ikind]);
1810             gfor_fndecl_math_powi[kind][ikind].real =
1811               gfc_build_library_function_decl (get_identifier (name),
1812                   type, 2, type, itype);
1813
1814             type = gfc_get_complex_type (kinds[kind]);
1815             sprintf(name, PREFIX("pow_c%d_i%d"), kinds[kind], kinds[ikind]);
1816             gfor_fndecl_math_powi[kind][ikind].cmplx =
1817               gfc_build_library_function_decl (get_identifier (name),
1818                   type, 2, type, itype);
1819           }
1820       }
1821   }
1822
1823   gfor_fndecl_math_cpowf =
1824     gfc_build_library_function_decl (get_identifier ("cpowf"),
1825                                      gfc_complex4_type_node,
1826                                      1, gfc_complex4_type_node);
1827   gfor_fndecl_math_cpow =
1828     gfc_build_library_function_decl (get_identifier ("cpow"),
1829                                      gfc_complex8_type_node,
1830                                      1, gfc_complex8_type_node);
1831   gfor_fndecl_math_ishftc4 =
1832     gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")),
1833                                      gfc_int4_type_node,
1834                                      3, gfc_int4_type_node,
1835                                      gfc_int4_type_node, gfc_int4_type_node);
1836   gfor_fndecl_math_ishftc8 =
1837     gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")),
1838                                      gfc_int8_type_node,
1839                                      3, gfc_int8_type_node,
1840                                      gfc_int8_type_node, gfc_int8_type_node);
1841   gfor_fndecl_math_exponent4 =
1842     gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r4")),
1843                                      gfc_int4_type_node,
1844                                      1, gfc_real4_type_node);
1845   gfor_fndecl_math_exponent8 =
1846     gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r8")),
1847                                      gfc_int4_type_node,
1848                                      1, gfc_real8_type_node);
1849
1850   /* Other functions.  */
1851   gfor_fndecl_size0 =
1852     gfc_build_library_function_decl (get_identifier (PREFIX("size0")),
1853                                      gfc_array_index_type,
1854                                      1, pvoid_type_node);
1855   gfor_fndecl_size1 =
1856     gfc_build_library_function_decl (get_identifier (PREFIX("size1")),
1857                                      gfc_array_index_type,
1858                                      2, pvoid_type_node,
1859                                      gfc_array_index_type);
1860
1861   gfor_fndecl_iargc =
1862     gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),
1863                                      gfc_int4_type_node,
1864                                      0);
1865 }
1866
1867
1868 /* Make prototypes for runtime library functions.  */
1869
1870 void
1871 gfc_build_builtin_function_decls (void)
1872 {
1873   tree gfc_int4_type_node = gfc_get_int_type (4);
1874   tree gfc_int8_type_node = gfc_get_int_type (8);
1875   tree gfc_logical4_type_node = gfc_get_logical_type (4);
1876   tree gfc_pint4_type_node = build_pointer_type (gfc_int4_type_node);
1877
1878   /* Treat these two internal malloc wrappers as malloc.  */
1879   gfor_fndecl_internal_malloc =
1880     gfc_build_library_function_decl (get_identifier (PREFIX("internal_malloc")),
1881                                      pvoid_type_node, 1, gfc_int4_type_node);
1882   DECL_IS_MALLOC (gfor_fndecl_internal_malloc) = 1;
1883
1884   gfor_fndecl_internal_malloc64 =
1885     gfc_build_library_function_decl (get_identifier
1886                                      (PREFIX("internal_malloc64")),
1887                                      pvoid_type_node, 1, gfc_int8_type_node);
1888   DECL_IS_MALLOC (gfor_fndecl_internal_malloc64) = 1;
1889
1890   gfor_fndecl_internal_free =
1891     gfc_build_library_function_decl (get_identifier (PREFIX("internal_free")),
1892                                      void_type_node, 1, pvoid_type_node);
1893
1894   gfor_fndecl_allocate =
1895     gfc_build_library_function_decl (get_identifier (PREFIX("allocate")),
1896                                      void_type_node, 2, ppvoid_type_node,
1897                                      gfc_int4_type_node);
1898
1899   gfor_fndecl_allocate64 =
1900     gfc_build_library_function_decl (get_identifier (PREFIX("allocate64")),
1901                                      void_type_node, 2, ppvoid_type_node,
1902                                      gfc_int8_type_node);
1903
1904   gfor_fndecl_deallocate =
1905     gfc_build_library_function_decl (get_identifier (PREFIX("deallocate")),
1906                                      void_type_node, 2, ppvoid_type_node,
1907                                      gfc_pint4_type_node);
1908
1909   gfor_fndecl_stop_numeric =
1910     gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
1911                                      void_type_node, 1, gfc_int4_type_node);
1912
1913   /* Stop doesn't return.  */
1914   TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
1915
1916   gfor_fndecl_stop_string =
1917     gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),
1918                                      void_type_node, 2, pchar_type_node,
1919                                      gfc_int4_type_node);
1920   /* Stop doesn't return.  */
1921   TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
1922
1923   gfor_fndecl_pause_numeric =
1924     gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
1925                                      void_type_node, 1, gfc_int4_type_node);
1926
1927   gfor_fndecl_pause_string =
1928     gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")),
1929                                      void_type_node, 2, pchar_type_node,
1930                                      gfc_int4_type_node);
1931
1932   gfor_fndecl_select_string =
1933     gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
1934                                      pvoid_type_node, 0);
1935
1936   gfor_fndecl_runtime_error =
1937     gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
1938                                      void_type_node,
1939                                      3,
1940                                      pchar_type_node, pchar_type_node,
1941                                      gfc_int4_type_node);
1942   /* The runtime_error function does not return.  */
1943   TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
1944
1945   gfor_fndecl_set_std =
1946     gfc_build_library_function_decl (get_identifier (PREFIX("set_std")),
1947                                     void_type_node,
1948                                     2,
1949                                     gfc_int4_type_node,
1950                                     gfc_int4_type_node);
1951
1952   gfor_fndecl_in_pack = gfc_build_library_function_decl (
1953         get_identifier (PREFIX("internal_pack")),
1954         pvoid_type_node, 1, pvoid_type_node);
1955
1956   gfor_fndecl_in_unpack = gfc_build_library_function_decl (
1957         get_identifier (PREFIX("internal_unpack")),
1958         pvoid_type_node, 1, pvoid_type_node);
1959
1960   gfor_fndecl_associated =
1961     gfc_build_library_function_decl (
1962                                      get_identifier (PREFIX("associated")),
1963                                      gfc_logical4_type_node,
1964                                      2,
1965                                      ppvoid_type_node,
1966                                      ppvoid_type_node);
1967
1968   gfc_build_intrinsic_function_decls ();
1969   gfc_build_intrinsic_lib_fndecls ();
1970   gfc_build_io_library_fndecls ();
1971 }
1972
1973
1974 /* Evaluate the length of dummy character variables.  */
1975
1976 static tree
1977 gfc_trans_dummy_character (gfc_charlen * cl, tree fnbody)
1978 {
1979   stmtblock_t body;
1980
1981   gfc_finish_decl (cl->backend_decl, NULL_TREE);
1982
1983   gfc_start_block (&body);
1984
1985   /* Evaluate the string length expression.  */
1986   gfc_trans_init_string_length (cl, &body);
1987   
1988   gfc_add_expr_to_block (&body, fnbody);
1989   return gfc_finish_block (&body);
1990 }
1991
1992
1993 /* Allocate and cleanup an automatic character variable.  */
1994
1995 static tree
1996 gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
1997 {
1998   stmtblock_t body;
1999   tree decl;
2000   tree tmp;
2001
2002   gcc_assert (sym->backend_decl);
2003   gcc_assert (sym->ts.cl && sym->ts.cl->length);
2004
2005   gfc_start_block (&body);
2006
2007   /* Evaluate the string length expression.  */
2008   gfc_trans_init_string_length (sym->ts.cl, &body);
2009
2010   decl = sym->backend_decl;
2011
2012   /* Emit a DECL_EXPR for this variable, which will cause the
2013      gimplifier to allocate storage, and all that good stuff.  */
2014   tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
2015   gfc_add_expr_to_block (&body, tmp);
2016
2017   gfc_add_expr_to_block (&body, fnbody);
2018   return gfc_finish_block (&body);
2019 }
2020
2021
2022 /* Generate function entry and exit code, and add it to the function body.
2023    This includes:
2024     Allocation and initialization of array variables.
2025     Allocation of character string variables.
2026     Initialization and possibly repacking of dummy arrays.  */
2027
2028 static tree
2029 gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
2030 {
2031   locus loc;
2032   gfc_symbol *sym;
2033
2034   /* Deal with implicit return variables.  Explicit return variables will
2035      already have been added.  */
2036   if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
2037     {
2038       if (!current_fake_result_decl)
2039         {
2040           gfc_entry_list *el = NULL;
2041           if (proc_sym->attr.entry_master)
2042             {
2043               for (el = proc_sym->ns->entries; el; el = el->next)
2044                 if (el->sym != el->sym->result)
2045                   break;
2046             }
2047           if (el == NULL)
2048             warning (0, "Function does not return a value");
2049         }
2050       else if (proc_sym->as)
2051         {
2052           fnbody = gfc_trans_dummy_array_bias (proc_sym,
2053                                                current_fake_result_decl,
2054                                                fnbody);
2055         }
2056       else if (proc_sym->ts.type == BT_CHARACTER)
2057         {
2058           if (TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
2059             fnbody = gfc_trans_dummy_character (proc_sym->ts.cl, fnbody);
2060         }
2061       else
2062         gcc_assert (gfc_option.flag_f2c
2063                     && proc_sym->ts.type == BT_COMPLEX);
2064     }
2065
2066   for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
2067     {
2068       if (sym->attr.dimension)
2069         {
2070           switch (sym->as->type)
2071             {
2072             case AS_EXPLICIT:
2073               if (sym->attr.dummy || sym->attr.result)
2074                 fnbody =
2075                   gfc_trans_dummy_array_bias (sym, sym->backend_decl, fnbody);
2076               else if (sym->attr.pointer || sym->attr.allocatable)
2077                 {
2078                   if (TREE_STATIC (sym->backend_decl))
2079                     gfc_trans_static_array_pointer (sym);
2080                   else
2081                     fnbody = gfc_trans_deferred_array (sym, fnbody);
2082                 }
2083               else
2084                 {
2085                   gfc_get_backend_locus (&loc);
2086                   gfc_set_backend_locus (&sym->declared_at);
2087                   fnbody = gfc_trans_auto_array_allocation (sym->backend_decl,
2088                       sym, fnbody);
2089                   gfc_set_backend_locus (&loc);
2090                 }
2091               break;
2092
2093             case AS_ASSUMED_SIZE:
2094               /* Must be a dummy parameter.  */
2095               gcc_assert (sym->attr.dummy);
2096
2097               /* We should always pass assumed size arrays the g77 way.  */
2098               fnbody = gfc_trans_g77_array (sym, fnbody);
2099               break;
2100
2101             case AS_ASSUMED_SHAPE:
2102               /* Must be a dummy parameter.  */
2103               gcc_assert (sym->attr.dummy);
2104
2105               fnbody = gfc_trans_dummy_array_bias (sym, sym->backend_decl,
2106                                                    fnbody);
2107               break;
2108
2109             case AS_DEFERRED:
2110               fnbody = gfc_trans_deferred_array (sym, fnbody);
2111               break;
2112
2113             default:
2114               gcc_unreachable ();
2115             }
2116         }
2117       else if (sym->ts.type == BT_CHARACTER)
2118         {
2119           gfc_get_backend_locus (&loc);
2120           gfc_set_backend_locus (&sym->declared_at);
2121           if (sym->attr.dummy || sym->attr.result)
2122             fnbody = gfc_trans_dummy_character (sym->ts.cl, fnbody);
2123           else
2124             fnbody = gfc_trans_auto_character_variable (sym, fnbody);
2125           gfc_set_backend_locus (&loc);
2126         }
2127       else
2128         gcc_unreachable ();
2129     }
2130
2131   return fnbody;
2132 }
2133
2134
2135 /* Output an initialized decl for a module variable.  */
2136
2137 static void
2138 gfc_create_module_variable (gfc_symbol * sym)
2139 {
2140   tree decl;
2141
2142   /* Only output symbols from this module.  */
2143   if (sym->ns != module_namespace)
2144     {
2145       /* I don't think this should ever happen.  */
2146       internal_error ("module symbol %s in wrong namespace", sym->name);
2147     }
2148
2149   /* Only output variables and array valued parameters.  */
2150   if (sym->attr.flavor != FL_VARIABLE
2151       && (sym->attr.flavor != FL_PARAMETER || sym->attr.dimension == 0))
2152     return;
2153
2154   /* Don't generate variables from other modules. Variables from
2155      COMMONs will already have been generated.  */
2156   if (sym->attr.use_assoc || sym->attr.in_common)
2157     return;
2158
2159   if (sym->backend_decl)
2160     internal_error ("backend decl for module variable %s already exists",
2161                     sym->name);
2162
2163   /* We always want module variables to be created.  */
2164   sym->attr.referenced = 1;
2165   /* Create the decl.  */
2166   decl = gfc_get_symbol_decl (sym);
2167
2168   /* Create the variable.  */
2169   pushdecl (decl);
2170   rest_of_decl_compilation (decl, 1, 0);
2171
2172   /* Also add length of strings.  */
2173   if (sym->ts.type == BT_CHARACTER)
2174     {
2175       tree length;
2176
2177       length = sym->ts.cl->backend_decl;
2178       if (!INTEGER_CST_P (length))
2179         {
2180           pushdecl (length);
2181           rest_of_decl_compilation (length, 1, 0);
2182         }
2183     }
2184 }
2185
2186
2187 /* Generate all the required code for module variables.  */
2188
2189 void
2190 gfc_generate_module_vars (gfc_namespace * ns)
2191 {
2192   module_namespace = ns;
2193
2194   /* Check if the frontend left the namespace in a reasonable state.  */
2195   gcc_assert (ns->proc_name && !ns->proc_name->tlink);
2196
2197   /* Generate COMMON blocks.  */
2198   gfc_trans_common (ns);
2199
2200   /* Create decls for all the module variables.  */
2201   gfc_traverse_ns (ns, gfc_create_module_variable);
2202 }
2203
2204 static void
2205 gfc_generate_contained_functions (gfc_namespace * parent)
2206 {
2207   gfc_namespace *ns;
2208
2209   /* We create all the prototypes before generating any code.  */
2210   for (ns = parent->contained; ns; ns = ns->sibling)
2211     {
2212       /* Skip namespaces from used modules.  */
2213       if (ns->parent != parent)
2214         continue;
2215
2216       gfc_create_function_decl (ns);
2217     }
2218
2219   for (ns = parent->contained; ns; ns = ns->sibling)
2220     {
2221       /* Skip namespaces from used modules.  */
2222       if (ns->parent != parent)
2223         continue;
2224
2225       gfc_generate_function_code (ns);
2226     }
2227 }
2228
2229
2230 /* Generate decls for all local variables.  We do this to ensure correct
2231    handling of expressions which only appear in the specification of
2232    other functions.  */
2233
2234 static void
2235 generate_local_decl (gfc_symbol * sym)
2236 {
2237   if (sym->attr.flavor == FL_VARIABLE)
2238     {
2239       if (sym->attr.referenced)
2240         gfc_get_symbol_decl (sym);
2241       else if (sym->attr.dummy && warn_unused_parameter)
2242             warning (0, "unused parameter %qs", sym->name);
2243       /* Warn for unused variables, but not if they're inside a common
2244          block or are use-associated.  */
2245       else if (warn_unused_variable
2246                && !(sym->attr.in_common || sym->attr.use_assoc))
2247         warning (0, "unused variable %qs", sym->name); 
2248     }
2249 }
2250
2251 static void
2252 generate_local_vars (gfc_namespace * ns)
2253 {
2254   gfc_traverse_ns (ns, generate_local_decl);
2255 }
2256
2257
2258 /* Generate a switch statement to jump to the correct entry point.  Also
2259    creates the label decls for the entry points.  */
2260
2261 static tree
2262 gfc_trans_entry_master_switch (gfc_entry_list * el)
2263 {
2264   stmtblock_t block;
2265   tree label;
2266   tree tmp;
2267   tree val;
2268
2269   gfc_init_block (&block);
2270   for (; el; el = el->next)
2271     {
2272       /* Add the case label.  */
2273       label = gfc_build_label_decl (NULL_TREE);
2274       val = build_int_cst (gfc_array_index_type, el->id);
2275       tmp = build3_v (CASE_LABEL_EXPR, val, NULL_TREE, label);
2276       gfc_add_expr_to_block (&block, tmp);
2277       
2278       /* And jump to the actual entry point.  */
2279       label = gfc_build_label_decl (NULL_TREE);
2280       tmp = build1_v (GOTO_EXPR, label);
2281       gfc_add_expr_to_block (&block, tmp);
2282
2283       /* Save the label decl.  */
2284       el->label = label;
2285     }
2286   tmp = gfc_finish_block (&block);
2287   /* The first argument selects the entry point.  */
2288   val = DECL_ARGUMENTS (current_function_decl);
2289   tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);
2290   return tmp;
2291 }
2292
2293
2294 /* Generate code for a function.  */
2295
2296 void
2297 gfc_generate_function_code (gfc_namespace * ns)
2298 {
2299   tree fndecl;
2300   tree old_context;
2301   tree decl;
2302   tree tmp;
2303   stmtblock_t block;
2304   stmtblock_t body;
2305   tree result;
2306   gfc_symbol *sym;
2307
2308   sym = ns->proc_name;
2309
2310   /* Check that the frontend isn't still using this.  */
2311   gcc_assert (sym->tlink == NULL);
2312   sym->tlink = sym;
2313
2314   /* Create the declaration for functions with global scope.  */
2315   if (!sym->backend_decl)
2316     gfc_create_function_decl (ns);
2317
2318   fndecl = sym->backend_decl;
2319   old_context = current_function_decl;
2320
2321   if (old_context)
2322     {
2323       push_function_context ();
2324       saved_parent_function_decls = saved_function_decls;
2325       saved_function_decls = NULL_TREE;
2326     }
2327
2328   trans_function_start (sym);
2329
2330   /* Will be created as needed.  */
2331   current_fake_result_decl = NULL_TREE;
2332
2333   gfc_start_block (&block);
2334
2335   gfc_generate_contained_functions (ns);
2336
2337   if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
2338     {
2339       /* Copy length backend_decls to all entry point result
2340          symbols.  */
2341       gfc_entry_list *el;
2342       tree backend_decl;
2343
2344       gfc_conv_const_charlen (ns->proc_name->ts.cl);
2345       backend_decl = ns->proc_name->result->ts.cl->backend_decl;
2346       for (el = ns->entries; el; el = el->next)
2347         el->sym->result->ts.cl->backend_decl = backend_decl;
2348     }
2349
2350   /* Translate COMMON blocks.  */
2351   gfc_trans_common (ns);
2352
2353   generate_local_vars (ns);
2354
2355   current_function_return_label = NULL;
2356
2357   /* Now generate the code for the body of this function.  */
2358   gfc_init_block (&body);
2359
2360   /* If this is the main program and we compile with -pedantic, add a call
2361      to set_std to set up the runtime library Fortran language standard
2362      parameters.  */
2363   if (sym->attr.is_main_program && pedantic)
2364     {
2365       tree arglist, gfc_int4_type_node;
2366
2367       gfc_int4_type_node = gfc_get_int_type (4);
2368       arglist = gfc_chainon_list (NULL_TREE,
2369                                   build_int_cst (gfc_int4_type_node,
2370                                                  gfc_option.warn_std));
2371       arglist = gfc_chainon_list (arglist,
2372                                   build_int_cst (gfc_int4_type_node,
2373                                                  gfc_option.allow_std));
2374       tmp = gfc_build_function_call (gfor_fndecl_set_std, arglist);
2375       gfc_add_expr_to_block (&body, tmp);
2376     }
2377
2378   if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
2379       && sym->attr.subroutine)
2380     {
2381       tree alternate_return;
2382       alternate_return = gfc_get_fake_result_decl (sym);
2383       gfc_add_modify_expr (&body, alternate_return, integer_zero_node);
2384     }
2385
2386   if (ns->entries)
2387     {
2388       /* Jump to the correct entry point.  */
2389       tmp = gfc_trans_entry_master_switch (ns->entries);
2390       gfc_add_expr_to_block (&body, tmp);
2391     }
2392
2393   tmp = gfc_trans_code (ns->code);
2394   gfc_add_expr_to_block (&body, tmp);
2395
2396   /* Add a return label if needed.  */
2397   if (current_function_return_label)
2398     {
2399       tmp = build1_v (LABEL_EXPR, current_function_return_label);
2400       gfc_add_expr_to_block (&body, tmp);
2401     }
2402
2403   tmp = gfc_finish_block (&body);
2404   /* Add code to create and cleanup arrays.  */
2405   tmp = gfc_trans_deferred_vars (sym, tmp);
2406   gfc_add_expr_to_block (&block, tmp);
2407
2408   if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
2409     {
2410       if (sym->attr.subroutine || sym == sym->result)
2411         {
2412           result = current_fake_result_decl;
2413           current_fake_result_decl = NULL_TREE;
2414         }
2415       else
2416         result = sym->result->backend_decl;
2417
2418       if (result == NULL_TREE)
2419         warning (0, "Function return value not set");
2420       else
2421         {
2422           /* Set the return value to the dummy result variable.  */
2423           tmp = build2 (MODIFY_EXPR, TREE_TYPE (result),
2424                         DECL_RESULT (fndecl), result);
2425           tmp = build1_v (RETURN_EXPR, tmp);
2426           gfc_add_expr_to_block (&block, tmp);
2427         }
2428     }
2429
2430   /* Add all the decls we created during processing.  */
2431   decl = saved_function_decls;
2432   while (decl)
2433     {
2434       tree next;
2435
2436       next = TREE_CHAIN (decl);
2437       TREE_CHAIN (decl) = NULL_TREE;
2438       pushdecl (decl);
2439       decl = next;
2440     }
2441   saved_function_decls = NULL_TREE;
2442
2443   DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);
2444
2445   /* Finish off this function and send it for code generation.  */
2446   poplevel (1, 0, 1);
2447   BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
2448
2449   /* Output the GENERIC tree.  */
2450   dump_function (TDI_original, fndecl);
2451
2452   /* Store the end of the function, so that we get good line number
2453      info for the epilogue.  */
2454   cfun->function_end_locus = input_location;
2455
2456   /* We're leaving the context of this function, so zap cfun.
2457      It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
2458      tree_rest_of_compilation.  */
2459   cfun = NULL;
2460
2461   if (old_context)
2462     {
2463       pop_function_context ();
2464       saved_function_decls = saved_parent_function_decls;
2465     }
2466   current_function_decl = old_context;
2467
2468   if (decl_function_context (fndecl))
2469     /* Register this function with cgraph just far enough to get it
2470        added to our parent's nested function list.  */
2471     (void) cgraph_node (fndecl);
2472   else
2473     {
2474       gfc_gimplify_function (fndecl);
2475       cgraph_finalize_function (fndecl, false);
2476     }
2477 }
2478
2479 void
2480 gfc_generate_constructors (void)
2481 {
2482   gcc_assert (gfc_static_ctors == NULL_TREE);
2483 #if 0
2484   tree fnname;
2485   tree type;
2486   tree fndecl;
2487   tree decl;
2488   tree tmp;
2489
2490   if (gfc_static_ctors == NULL_TREE)
2491     return;
2492
2493   fnname = get_file_function_name ('I');
2494   type = build_function_type (void_type_node,
2495                               gfc_chainon_list (NULL_TREE, void_type_node));
2496
2497   fndecl = build_decl (FUNCTION_DECL, fnname, type);
2498   TREE_PUBLIC (fndecl) = 1;
2499
2500   decl = build_decl (RESULT_DECL, NULL_TREE, void_type_node);
2501   DECL_ARTIFICIAL (decl) = 1;
2502   DECL_IGNORED_P (decl) = 1;
2503   DECL_CONTEXT (decl) = fndecl;
2504   DECL_RESULT (fndecl) = decl;
2505
2506   pushdecl (fndecl);
2507
2508   current_function_decl = fndecl;
2509
2510   rest_of_decl_compilation (fndecl, 1, 0);
2511
2512   make_decl_rtl (fndecl);
2513
2514   init_function_start (fndecl);
2515
2516   pushlevel (0);
2517
2518   for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
2519     {
2520       tmp =
2521         gfc_build_function_call (TREE_VALUE (gfc_static_ctors), NULL_TREE);
2522       DECL_SAVED_TREE (fndecl) = build_stmt (EXPR_STMT, tmp);
2523     }
2524
2525   poplevel (1, 0, 1);
2526
2527   BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
2528
2529   free_after_parsing (cfun);
2530   free_after_compilation (cfun);
2531
2532   tree_rest_of_compilation (fndecl);
2533
2534   current_function_decl = NULL_TREE;
2535 #endif
2536 }
2537
2538 /* Translates a BLOCK DATA program unit. This means emitting the
2539    commons contained therein plus their initializations. We also emit
2540    a globally visible symbol to make sure that each BLOCK DATA program
2541    unit remains unique.  */
2542
2543 void
2544 gfc_generate_block_data (gfc_namespace * ns)
2545 {
2546   tree decl;
2547   tree id;
2548
2549   /* Tell the backend the source location of the block data.  */
2550   if (ns->proc_name)
2551     gfc_set_backend_locus (&ns->proc_name->declared_at);
2552   else
2553     gfc_set_backend_locus (&gfc_current_locus);
2554
2555   /* Process the DATA statements.  */
2556   gfc_trans_common (ns);
2557
2558   /* Create a global symbol with the mane of the block data.  This is to
2559      generate linker errors if the same name is used twice.  It is never
2560      really used.  */
2561   if (ns->proc_name)
2562     id = gfc_sym_mangled_function_id (ns->proc_name);
2563   else
2564     id = get_identifier ("__BLOCK_DATA__");
2565
2566   decl = build_decl (VAR_DECL, id, gfc_array_index_type);
2567   TREE_PUBLIC (decl) = 1;
2568   TREE_STATIC (decl) = 1;
2569
2570   pushdecl (decl);
2571   rest_of_decl_compilation (decl, 1, 0);
2572 }
2573
2574 #include "gt-fortran-trans-decl.h"