OSDN Git Service

* f95-lang.c (gfc_init_builtin_functions): Use vold_list_node.
[pf3gnuchains/gcc-fork.git] / gcc / fortran / trans-decl.c
1 /* Backend function setup
2    Copyright (C) 2002, 2003, 2004 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, 59 Temple Place - Suite 330, Boston, MA
20 02111-1307, 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 "errors.h"
36 #include "flags.h"
37 #include "cgraph.h"
38 #include <assert.h>
39 #include "gfortran.h"
40 #include "trans.h"
41 #include "trans-types.h"
42 #include "trans-array.h"
43 #include "trans-const.h"
44 /* Only for gfc_trans_code.  Shouldn't need to include this.  */
45 #include "trans-stmt.h"
46
47 #define MAX_LABEL_VALUE 99999
48
49
50 /* Holds the result of the function if no result variable specified.  */
51
52 static GTY(()) tree current_fake_result_decl;
53
54 static GTY(()) tree current_function_return_label;
55
56
57 /* Holds the variable DECLs for the current function.  */
58
59 static GTY(()) tree saved_function_decls = NULL_TREE;
60 static GTY(()) tree saved_parent_function_decls = NULL_TREE;
61
62
63 /* The namespace of the module we're currently generating.  Only used while
64    outputting decls for module variables.  Do not rely on this being set.  */
65
66 static gfc_namespace *module_namespace;
67
68
69 /* List of static constructor functions.  */
70
71 tree gfc_static_ctors;
72
73
74 /* Function declarations for builtin library functions.  */
75
76 tree gfor_fndecl_internal_malloc;
77 tree gfor_fndecl_internal_malloc64;
78 tree gfor_fndecl_internal_free;
79 tree gfor_fndecl_allocate;
80 tree gfor_fndecl_allocate64;
81 tree gfor_fndecl_deallocate;
82 tree gfor_fndecl_pause_numeric;
83 tree gfor_fndecl_pause_string;
84 tree gfor_fndecl_stop_numeric;
85 tree gfor_fndecl_stop_string;
86 tree gfor_fndecl_select_string;
87 tree gfor_fndecl_runtime_error;
88 tree gfor_fndecl_in_pack;
89 tree gfor_fndecl_in_unpack;
90 tree gfor_fndecl_associated;
91
92
93 /* Math functions.  Many other math functions are handled in
94    trans-intrinsic.c.  */
95
96 gfc_powdecl_list gfor_fndecl_math_powi[3][2];
97 tree gfor_fndecl_math_cpowf;
98 tree gfor_fndecl_math_cpow;
99 tree gfor_fndecl_math_cabsf;
100 tree gfor_fndecl_math_cabs;
101 tree gfor_fndecl_math_sign4;
102 tree gfor_fndecl_math_sign8;
103 tree gfor_fndecl_math_ishftc4;
104 tree gfor_fndecl_math_ishftc8;
105 tree gfor_fndecl_math_exponent4;
106 tree gfor_fndecl_math_exponent8;
107
108
109 /* String functions.  */
110
111 tree gfor_fndecl_copy_string;
112 tree gfor_fndecl_compare_string;
113 tree gfor_fndecl_concat_string;
114 tree gfor_fndecl_string_len_trim;
115 tree gfor_fndecl_string_index;
116 tree gfor_fndecl_string_scan;
117 tree gfor_fndecl_string_verify;
118 tree gfor_fndecl_string_trim;
119 tree gfor_fndecl_string_repeat;
120 tree gfor_fndecl_adjustl;
121 tree gfor_fndecl_adjustr;
122
123
124 /* Other misc. runtime library functions.  */
125
126 tree gfor_fndecl_size0;
127 tree gfor_fndecl_size1;
128
129 /* Intrinsic functions implemented in FORTRAN.  */
130 tree gfor_fndecl_si_kind;
131 tree gfor_fndecl_sr_kind;
132
133
134 static void
135 gfc_add_decl_to_parent_function (tree decl)
136 {
137   assert (decl);
138   DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl);
139   DECL_NONLOCAL (decl) = 1;
140   TREE_CHAIN (decl) = saved_parent_function_decls;
141   saved_parent_function_decls = decl;
142 }
143
144 void
145 gfc_add_decl_to_function (tree decl)
146 {
147   assert (decl);
148   TREE_USED (decl) = 1;
149   DECL_CONTEXT (decl) = current_function_decl;
150   TREE_CHAIN (decl) = saved_function_decls;
151   saved_function_decls = decl;
152 }
153
154
155 /* Build a  backend label declaration.
156    Set TREE_USED for named lables.  For artificial labels it's up to the
157    caller to mark the label as used.  */
158
159 tree
160 gfc_build_label_decl (tree label_id)
161 {
162   /* 2^32 temporaries should be enough.  */
163   static unsigned int tmp_num = 1;
164   tree label_decl;
165   char *label_name;
166
167   if (label_id == NULL_TREE)
168     {
169       /* Build an internal label name.  */
170       ASM_FORMAT_PRIVATE_NAME (label_name, "L", tmp_num++);
171       label_id = get_identifier (label_name);
172     }
173   else
174     label_name = NULL;
175
176   /* Build the LABEL_DECL node. Labels have no type.  */
177   label_decl = build_decl (LABEL_DECL, label_id, void_type_node);
178   DECL_CONTEXT (label_decl) = current_function_decl;
179   DECL_MODE (label_decl) = VOIDmode;
180
181   if (label_name)
182     {
183       DECL_ARTIFICIAL (label_decl) = 1;
184     }
185   else
186     {
187       /* We always define the label as used, even if the original source
188          file never references the label.  We don't want all kinds of
189          spurious warnings for old-style Fortran code with too many
190          labels.  */
191       TREE_USED (label_decl) = 1;
192     }
193
194   return label_decl;
195 }
196
197
198 /* Returns the return label for the current function.  */
199
200 tree
201 gfc_get_return_label (void)
202 {
203   char name[GFC_MAX_SYMBOL_LEN + 10];
204
205   if (current_function_return_label)
206     return current_function_return_label;
207
208   sprintf (name, "__return_%s",
209            IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
210
211   current_function_return_label =
212     gfc_build_label_decl (get_identifier (name));
213
214   DECL_ARTIFICIAL (current_function_return_label) = 1;
215
216   return current_function_return_label;
217 }
218
219
220 /* Return the backend label declaration for a given label structure,
221    or create it if it doesn't exist yet.  */
222
223 tree
224 gfc_get_label_decl (gfc_st_label * lp)
225 {
226
227   if (lp->backend_decl)
228     return lp->backend_decl;
229   else
230     {
231       char label_name[GFC_MAX_SYMBOL_LEN + 1];
232       tree label_decl;
233
234       /* Validate the label declaration from the front end.  */
235       assert (lp != NULL && lp->value <= MAX_LABEL_VALUE);
236
237       /* Build a mangled name for the label.  */
238       sprintf (label_name, "__label_%.6d", lp->value);
239
240       /* Build the LABEL_DECL node.  */
241       label_decl = gfc_build_label_decl (get_identifier (label_name));
242
243       /* Tell the debugger where the label came from.  */
244       if (lp->value <= MAX_LABEL_VALUE) /* An internal label */
245         {
246           DECL_SOURCE_LINE (label_decl) = lp->where.lb->linenum;
247           DECL_SOURCE_FILE (label_decl) = lp->where.lb->file->filename;
248         }
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[0] == 0)
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[0] == 0 || sym->attr.proc == PROC_EXTERNAL
294       || (sym->module[0] != 0 && 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 /* Finish processing of a declaration and install its initial value.  */
321
322 static void
323 gfc_finish_decl (tree decl, tree init)
324 {
325   if (TREE_CODE (decl) == PARM_DECL)
326     assert (init == NULL_TREE);
327   /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se
328      -- it overlaps DECL_ARG_TYPE.  */
329   else if (init == NULL_TREE)
330     assert (DECL_INITIAL (decl) == NULL_TREE);
331   else
332     assert (DECL_INITIAL (decl) == error_mark_node);
333
334   if (init != NULL_TREE)
335     {
336       if (TREE_CODE (decl) != TYPE_DECL)
337         DECL_INITIAL (decl) = init;
338       else
339         {
340           /* typedef foo = bar; store the type of bar as the type of foo.  */
341           TREE_TYPE (decl) = TREE_TYPE (init);
342           DECL_INITIAL (decl) = init = 0;
343         }
344     }
345
346   if (TREE_CODE (decl) == VAR_DECL)
347     {
348       if (DECL_SIZE (decl) == NULL_TREE
349           && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
350         layout_decl (decl, 0);
351
352       /* A static variable with an incomplete type is an error if it is
353          initialized. Also if it is not file scope. Otherwise, let it
354          through, but if it is not `extern' then it may cause an error
355          message later.  */
356       /* An automatic variable with an incomplete type is an error.  */
357       if (DECL_SIZE (decl) == NULL_TREE
358           && (TREE_STATIC (decl) ? (DECL_INITIAL (decl) != 0
359                                     || DECL_CONTEXT (decl) != 0)
360                                  : !DECL_EXTERNAL (decl)))
361         {
362           gfc_fatal_error ("storage size not known");
363         }
364
365       if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
366           && (DECL_SIZE (decl) != 0)
367           && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
368         {
369           gfc_fatal_error ("storage size not constant");
370         }
371     }
372
373 }
374
375
376 /* Apply symbol attributes to a variable, and add it to the function scope.  */
377
378 static void
379 gfc_finish_var_decl (tree decl, gfc_symbol * sym)
380 {
381   /* TREE_ADDRESSABLE means the address of this variable is acualy needed.
382      This is the equivalent of the TARGET variables.
383      We also need to set this if the variable is passed by reference in a
384      CALL statement.  */
385   if (sym->attr.target)
386     TREE_ADDRESSABLE (decl) = 1;
387   /* If it wasn't used we wouldn't be getting it.  */
388   TREE_USED (decl) = 1;
389
390   /* Chain this decl to the pending declarations.  Don't do pushdecl()
391      because this would add them to the current scope rather than the
392      function scope.  */
393   if (current_function_decl != NULL_TREE)
394     {
395       if (sym->ns->proc_name->backend_decl == current_function_decl)
396         gfc_add_decl_to_function (decl);
397       else
398         gfc_add_decl_to_parent_function (decl);
399     }
400
401   /* If a variable is USE associated, it's always external.  */
402   if (sym->attr.use_assoc)
403     {
404       DECL_EXTERNAL (decl) = 1;
405       TREE_PUBLIC (decl) = 1;
406     }
407   else if (sym->module[0] && !sym->attr.result)
408     {
409       /* TODO: Don't set sym->module for result variables.  */
410       assert (current_function_decl == NULL_TREE);
411       /* This is the declaration of a module variable.  */
412       TREE_PUBLIC (decl) = 1;
413       TREE_STATIC (decl) = 1;
414     }
415
416   if ((sym->attr.save || sym->attr.data || sym->value)
417       && !sym->attr.use_assoc)
418     TREE_STATIC (decl) = 1;
419   
420   /* Keep variables larger than max-stack-var-size off stack.  */
421   if (!sym->ns->proc_name->attr.recursive
422       && INTEGER_CST_P (DECL_SIZE_UNIT (decl))
423       && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl)))
424     TREE_STATIC (decl) = 1;
425 }
426
427
428 /* Allocate the lang-specific part of a decl.  */
429
430 void
431 gfc_allocate_lang_decl (tree decl)
432 {
433   DECL_LANG_SPECIFIC (decl) = (struct lang_decl *)
434     ggc_alloc_cleared (sizeof (struct lang_decl));
435 }
436
437 /* Remember a symbol to generate initialization/cleanup code at function
438    entry/exit.  */
439
440 static void
441 gfc_defer_symbol_init (gfc_symbol * sym)
442 {
443   gfc_symbol *p;
444   gfc_symbol *last;
445   gfc_symbol *head;
446
447   /* Don't add a symbol twice.  */
448   if (sym->tlink)
449     return;
450
451   last = head = sym->ns->proc_name;
452   p = last->tlink;
453
454   /* Make sure that setup code for dummy variables which are used in the
455      setup of other variables is generated first.  */
456   if (sym->attr.dummy)
457     {
458       /* Find the first dummy arg seen after us, or the first non-dummy arg.
459          This is a circular list, so don't go past the head.  */
460       while (p != head
461              && (!p->attr.dummy || p->dummy_order > sym->dummy_order))
462         {
463           last = p;
464           p = p->tlink;
465         }
466     }
467   /* Insert in between last and p.  */
468   last->tlink = sym;
469   sym->tlink = p;
470 }
471
472
473 /* Create an array index type variable with function scope.  */
474
475 static tree
476 create_index_var (const char * pfx, int nest)
477 {
478   tree decl;
479
480   decl = gfc_create_var_np (gfc_array_index_type, pfx);
481   if (nest)
482     gfc_add_decl_to_parent_function (decl);
483   else
484     gfc_add_decl_to_function (decl);
485   return decl;
486 }
487
488
489 /* Create variables to hold all the non-constant bits of info for a
490    descriptorless array.  Remember these in the lang-specific part of the
491    type.  */
492
493 static void
494 gfc_build_qualified_array (tree decl, gfc_symbol * sym)
495 {
496   tree type;
497   int dim;
498   int nest;
499
500   type = TREE_TYPE (decl);
501
502   /* We just use the descriptor, if there is one.  */
503   if (GFC_DESCRIPTOR_TYPE_P (type))
504     return;
505
506   assert (GFC_ARRAY_TYPE_P (type));
507   nest = (sym->ns->proc_name->backend_decl != current_function_decl)
508          && !sym->attr.contained;
509
510   for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)
511     {
512       if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
513         GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
514       /* Don't try to use the unkown bound for assumed shape arrays.  */
515       if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
516           && (sym->as->type != AS_ASSUMED_SIZE
517               || dim < GFC_TYPE_ARRAY_RANK (type) - 1))
518         GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
519
520       if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE)
521         GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest);
522     }
523   if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)
524     {
525       GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,
526                                                         "offset");
527       if (nest)
528         gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type));
529       else
530         gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));
531     }
532 }
533
534
535 /* For some dummy arguments we don't use the actual argument directly.
536    Instead we create a local decl and use that.  This allows us to preform
537    initialization, and construct full type information.  */
538
539 static tree
540 gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
541 {
542   tree decl;
543   tree type;
544   gfc_array_spec *as;
545   char *name;
546   int packed;
547   int n;
548   bool known_size;
549
550   if (sym->attr.pointer || sym->attr.allocatable)
551     return dummy;
552
553   /* Add to list of variables if not a fake result variable.  */
554   if (sym->attr.result || sym->attr.dummy)
555     gfc_defer_symbol_init (sym);
556
557   type = TREE_TYPE (dummy);
558   assert (TREE_CODE (dummy) == PARM_DECL
559           && POINTER_TYPE_P (type));
560
561   /* Do we know the element size. */
562   known_size = sym->ts.type != BT_CHARACTER
563           || INTEGER_CST_P (sym->ts.cl->backend_decl);
564   
565   if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
566     {
567       /* For descriptorless arrays with known element size the actual
568          argument is sufficient.  */
569       assert (GFC_ARRAY_TYPE_P (type));
570       gfc_build_qualified_array (dummy, sym);
571       return dummy;
572     }
573
574   type = TREE_TYPE (type);
575   if (GFC_DESCRIPTOR_TYPE_P (type))
576     {
577       /* Create a decriptorless array pointer.  */
578       as = sym->as;
579       packed = 0;
580       if (!gfc_option.flag_repack_arrays)
581         {
582           if (as->type == AS_ASSUMED_SIZE)
583             packed = 2;
584         }
585       else
586         {
587           if (as->type == AS_EXPLICIT)
588             {
589               packed = 2;
590               for (n = 0; n < as->rank; n++)
591                 {
592                   if (!(as->upper[n]
593                         && as->lower[n]
594                         && as->upper[n]->expr_type == EXPR_CONSTANT
595                         && as->lower[n]->expr_type == EXPR_CONSTANT))
596                     packed = 1;
597                 }
598             }
599           else
600             packed = 1;
601         }
602
603       type = gfc_typenode_for_spec (&sym->ts);
604       type = gfc_get_nodesc_array_type (type, sym->as, packed);
605     }
606   else
607     {
608       /* We now have an expression for the element size, so create a fully
609          qualified type.  Reset sym->backend decl or this will just return the
610          old type.  */
611       sym->backend_decl = NULL_TREE;
612       type = gfc_sym_type (sym);
613       packed = 2;
614     }
615
616   ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);
617   decl = build_decl (VAR_DECL, get_identifier (name), type);
618
619   DECL_ARTIFICIAL (decl) = 1;
620   TREE_PUBLIC (decl) = 0;
621   TREE_STATIC (decl) = 0;
622   DECL_EXTERNAL (decl) = 0;
623
624   /* We should never get deferred shape arrays here.  We used to because of
625      frontend bugs.  */
626   assert (sym->as->type != AS_DEFERRED);
627
628   switch (packed)
629     {
630     case 1:
631       GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;
632       break;
633
634     case 2:
635       GFC_DECL_PACKED_ARRAY (decl) = 1;
636       break;
637     }
638
639   gfc_build_qualified_array (decl, sym);
640
641   if (DECL_LANG_SPECIFIC (dummy))
642     DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (dummy);
643   else
644     gfc_allocate_lang_decl (decl);
645
646   GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy;
647
648   if (sym->ns->proc_name->backend_decl == current_function_decl
649       || sym->attr.contained)
650     gfc_add_decl_to_function (decl);
651   else
652     gfc_add_decl_to_parent_function (decl);
653
654   return decl;
655 }
656
657
658 /* Return a constant or a variable to use as a string length.  Does not
659    add the decl to the current scope.  */
660
661 static tree
662 gfc_create_string_length (gfc_symbol * sym)
663 {
664   tree length;
665
666   assert (sym->ts.cl);
667   gfc_conv_const_charlen (sym->ts.cl);
668   
669   if (sym->ts.cl->backend_decl == NULL_TREE)
670     {
671       char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
672
673       /* Also prefix the mangled name.  */
674       strcpy (&name[1], sym->name);
675       name[0] = '.';
676       length = build_decl (VAR_DECL, get_identifier (name),
677                            gfc_strlen_type_node);
678       DECL_ARTIFICIAL (length) = 1;
679       TREE_USED (length) = 1;
680       gfc_defer_symbol_init (sym);
681       sym->ts.cl->backend_decl = length;
682     }
683
684   return sym->ts.cl->backend_decl;
685 }
686
687
688 /* Return the decl for a gfc_symbol, create it if it doesn't already
689    exist.  */
690
691 tree
692 gfc_get_symbol_decl (gfc_symbol * sym)
693 {
694   tree decl;
695   tree length = NULL_TREE;
696   gfc_se se;
697   int byref;
698
699   assert (sym->attr.referenced);
700
701   if (sym->ns && sym->ns->proc_name->attr.function)
702     byref = gfc_return_by_reference (sym->ns->proc_name);
703   else
704     byref = 0;
705
706   if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
707     {
708       /* Return via extra parameter.  */
709       if (sym->attr.result && byref
710           && !sym->backend_decl)
711         {
712           sym->backend_decl =
713             DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);
714         }
715
716       /* Dummy variables should already have been created.  */
717       assert (sym->backend_decl);
718
719       /* Create a character length variable.  */
720       if (sym->ts.type == BT_CHARACTER)
721         {
722           if (sym->ts.cl->backend_decl == NULL_TREE)
723             {
724               length = gfc_create_string_length (sym);
725               if (TREE_CODE (length) != INTEGER_CST)
726                 {
727                   gfc_finish_var_decl (length, sym);
728                   gfc_defer_symbol_init (sym);
729                 }
730             }
731         }
732
733       /* Use a copy of the descriptor for dummy arrays.  */
734       if (sym->attr.dimension && !TREE_USED (sym->backend_decl))
735         {
736           sym->backend_decl =
737             gfc_build_dummy_array_decl (sym, sym->backend_decl);
738         }
739
740       TREE_USED (sym->backend_decl) = 1;
741       return sym->backend_decl;
742     }
743
744   if (sym->backend_decl)
745     return sym->backend_decl;
746
747   if (sym->attr.entry)
748     gfc_todo_error ("alternate entry");
749
750   /* Catch function declarations.  Only used for actual parameters.  */
751   if (sym->attr.flavor == FL_PROCEDURE)
752     {
753       decl = gfc_get_extern_function_decl (sym);
754       return decl;
755     }
756
757   if (sym->attr.intrinsic)
758     internal_error ("intrinsic variable which isn't a procedure");
759
760   /* Create string length decl first so that they can be used in the
761      type declaration.  */
762   if (sym->ts.type == BT_CHARACTER)
763     length = gfc_create_string_length (sym);
764
765   /* Create the decl for the variable.  */
766   decl = build_decl (VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
767
768   /* Symbols from modules have its assembler name should be mangled.
769      This is done here rather than in gfc_finish_var_decl because it
770      is different for string length variables.  */
771   if (sym->module[0])
772     SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_identifier (sym));
773
774   if (sym->attr.dimension)
775     {
776       /* Create variables to hold the non-constant bits of array info.  */
777       gfc_build_qualified_array (decl, sym);
778
779       /* Remember this variable for allocation/cleanup.  */
780       gfc_defer_symbol_init (sym);
781
782       if ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer)
783         GFC_DECL_PACKED_ARRAY (decl) = 1;
784     }
785
786   gfc_finish_var_decl (decl, sym);
787
788   if (sym->attr.assign)
789     {
790       gfc_allocate_lang_decl (decl);
791       GFC_DECL_ASSIGN (decl) = 1;
792       length = gfc_create_var (gfc_strlen_type_node, sym->name);
793       GFC_DECL_STRING_LEN (decl) = length;
794       GFC_DECL_ASSIGN_ADDR (decl) = gfc_create_var (pvoid_type_node, sym->name);
795       /* TODO: Need to check we don't change TREE_STATIC (decl) later.  */
796       TREE_STATIC (length) = TREE_STATIC (decl);
797       /*  STRING_LENGTH is also used as flag. Less than -1 means that
798           ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
799           target label's address. Other value is the length of format string
800           and ASSIGN_ADDR is the address of format string.  */
801       DECL_INITIAL (length) = build_int_2 (-2, -1);
802     }
803
804   /* TODO: Initialization of pointer variables.  */
805   switch (sym->ts.type)
806     {
807     case BT_CHARACTER:
808       /* Character variables need special handling.  */
809       gfc_allocate_lang_decl (decl);
810
811       if (TREE_CODE (length) == INTEGER_CST)
812         {
813           /* Static initializer for string scalars.
814              Initialization of string arrays is handled elsewhere. */
815           if (sym->value && sym->attr.dimension == 0)
816             {
817               assert (TREE_STATIC (decl));
818               if (sym->attr.pointer)
819                 gfc_todo_error ("initialization of character pointers");
820               DECL_INITIAL (decl) = gfc_conv_string_init (length, sym->value);
821             }
822         }
823       else
824         {
825           char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
826
827           if (sym->module[0])
828             {
829               /* Also prefix the mangled name for symbols from modules.  */
830               strcpy (&name[1], sym->name);
831               name[0] = '.';
832               strcpy (&name[1],
833                       IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length)));
834               SET_DECL_ASSEMBLER_NAME (decl, get_identifier (name));
835             }
836           gfc_finish_var_decl (length, sym);
837           assert (!sym->value);
838         }
839       break;
840
841     case BT_DERIVED:
842       if (sym->value && ! (sym->attr.use_assoc || sym->attr.dimension))
843         {
844           gfc_init_se (&se, NULL);
845           gfc_conv_structure (&se, sym->value, 1);
846           DECL_INITIAL (decl) = se.expr;
847         }
848       break;
849
850     default:
851       /* Static initializers for SAVEd variables.  Arrays have already been
852          remembered.  Module variables are initialized when the module is
853          loaded.  */
854       if (sym->value && ! (sym->attr.use_assoc || sym->attr.dimension))
855         {
856           assert (TREE_STATIC (decl));
857           gfc_init_se (&se, NULL);
858           gfc_conv_constant (&se, sym->value);
859           DECL_INITIAL (decl) = se.expr;
860         }
861       break;
862     }
863   sym->backend_decl = decl;
864
865   return decl;
866 }
867
868
869 /* Get a basic decl for an external function.  */
870
871 tree
872 gfc_get_extern_function_decl (gfc_symbol * sym)
873 {
874   tree type;
875   tree fndecl;
876   gfc_expr e;
877   gfc_intrinsic_sym *isym;
878   gfc_expr argexpr;
879   char s[GFC_MAX_SYMBOL_LEN];
880   tree name;
881   tree mangled_name;
882
883   if (sym->backend_decl)
884     return sym->backend_decl;
885
886   if (sym->attr.intrinsic)
887     {
888       /* Call the resolution function to get the actual name.  This is
889          a nasty hack which relies on the resolution functions only looking
890          at the first argument.  We pass NULL for the second argument
891          otherwise things like AINT get confused.  */
892       isym = gfc_find_function (sym->name);
893       assert (isym->resolve.f0 != NULL);
894
895       memset (&e, 0, sizeof (e));
896       e.expr_type = EXPR_FUNCTION;
897
898       memset (&argexpr, 0, sizeof (argexpr));
899       assert (isym->formal);
900       argexpr.ts = isym->formal->ts;
901
902       if (isym->formal->next == NULL)
903         isym->resolve.f1 (&e, &argexpr);
904       else
905         {
906           /* All specific intrinsics take one or two arguments.  */
907           assert (isym->formal->next->next == NULL);
908           isym->resolve.f2 (&e, &argexpr, NULL);
909         }
910       sprintf (s, "specific%s", e.value.function.name);
911       name = get_identifier (s);
912       mangled_name = name;
913     }
914   else
915     {
916       name = gfc_sym_identifier (sym);
917       mangled_name = gfc_sym_mangled_function_id (sym);
918     }
919
920   type = gfc_get_function_type (sym);
921   fndecl = build_decl (FUNCTION_DECL, name, type);
922
923   SET_DECL_ASSEMBLER_NAME (fndecl, mangled_name);
924   /* If the return type is a pointer, avoid alias issues by setting
925      DECL_IS_MALLOC to nonzero. This means that the function should be
926      treated as if it were a malloc, meaning it returns a pointer that
927      is not an alias.  */
928   if (POINTER_TYPE_P (type))
929     DECL_IS_MALLOC (fndecl) = 1;
930
931   /* Set the context of this decl.  */
932   if (0 && sym->ns && sym->ns->proc_name)
933     {
934       /* TODO: Add external decls to the appropriate scope.  */
935       DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
936     }
937   else
938     {
939       /* Global declaration, eg. intrinsic subroutine.  */
940       DECL_CONTEXT (fndecl) = NULL_TREE;
941     }
942
943   DECL_EXTERNAL (fndecl) = 1;
944
945   /* This specifies if a function is globaly addressable, ie. it is
946      the opposite of declaring static in C.  */
947   TREE_PUBLIC (fndecl) = 1;
948
949   /* Set attributes for PURE functions. A call to PURE function in the
950      Fortran 95 sense is both pure and without side effects in the C
951      sense.  */
952   if (sym->attr.pure || sym->attr.elemental)
953     {
954       DECL_IS_PURE (fndecl) = 1;
955 /* TODO: check if pure/elemental procedures can have INTENT(OUT) parameters.
956       TREE_SIDE_EFFECTS (fndecl) = 0;*/
957     }
958
959   sym->backend_decl = fndecl;
960
961   if (DECL_CONTEXT (fndecl) == NULL_TREE)
962     pushdecl_top_level (fndecl);
963
964   return fndecl;
965 }
966
967
968 /* Create a declaration for a procedure.  For external functions (in the C
969    sense) use gfc_get_extern_function_decl.  */
970
971 void
972 gfc_build_function_decl (gfc_symbol * sym)
973 {
974   tree fndecl, type, result_decl, typelist, arglist;
975   tree length;
976   symbol_attribute attr;
977   gfc_formal_arglist *f;
978
979   assert (!sym->backend_decl);
980   assert (!sym->attr.external);
981
982   /* Allow only one nesting level.  Allow public declarations.  */
983   assert (current_function_decl == NULL_TREE
984           || DECL_CONTEXT (current_function_decl) == NULL_TREE);
985
986   type = gfc_get_function_type (sym);
987   fndecl = build_decl (FUNCTION_DECL, gfc_sym_identifier (sym), type);
988
989   /* Perform name mangling if this is a top level or module procedure.  */
990   if (current_function_decl == NULL_TREE)
991     SET_DECL_ASSEMBLER_NAME (fndecl, gfc_sym_mangled_function_id (sym));
992
993   /* Figure out the return type of the declared function, and build a
994      RESULT_DECL for it.  If this is subroutine with alternate
995      returns, build a RESULT_DECL for it.  */
996   attr = sym->attr;
997
998   result_decl = NULL_TREE;
999   /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)).  */
1000   if (attr.function)
1001     {
1002       if (gfc_return_by_reference (sym))
1003         type = void_type_node;
1004       else
1005         {
1006           if (sym->result != sym)
1007             result_decl = gfc_sym_identifier (sym->result);
1008
1009           type = TREE_TYPE (TREE_TYPE (fndecl));
1010         }
1011     }
1012   else
1013     {
1014       /* Look for alternate return placeholders.  */
1015       int has_alternate_returns = 0;
1016       for (f = sym->formal; f; f = f->next)
1017         {
1018           if (f->sym == NULL)
1019             {
1020               has_alternate_returns = 1;
1021               break;
1022             }
1023         }
1024
1025       if (has_alternate_returns)
1026         type = integer_type_node;
1027       else
1028         type = void_type_node;
1029     }
1030
1031   result_decl = build_decl (RESULT_DECL, result_decl, type);
1032   DECL_CONTEXT (result_decl) = fndecl;
1033   DECL_RESULT (fndecl) = result_decl;
1034
1035   /* Don't call layout_decl for a RESULT_DECL.
1036      layout_decl (result_decl, 0); */
1037
1038   /* If the return type is a pointer, avoid alias issues by setting
1039      DECL_IS_MALLOC to nonzero. This means that the function should be
1040      treated as if it were a malloc, meaning it returns a pointer that
1041      is not an alias.  */
1042   if (POINTER_TYPE_P (type))
1043     DECL_IS_MALLOC (fndecl) = 1;
1044
1045   /* Set up all attributes for the function.  */
1046   DECL_CONTEXT (fndecl) = current_function_decl;
1047   DECL_EXTERNAL (fndecl) = 0;
1048
1049   /* This specifies if a function is globaly addressable, ie. it is
1050      the opposite of declaring static in C.  */
1051   if (DECL_CONTEXT (fndecl) == NULL_TREE || attr.external)
1052     TREE_PUBLIC (fndecl) = 1;
1053
1054   /* TREE_STATIC means the function body is defined here.  */
1055   if (!attr.external)
1056     TREE_STATIC (fndecl) = 1;
1057
1058   /* Set attributes for PURE functions. A call to PURE function in the
1059      Fortran 95 sense is both pure and without side effects in the C
1060      sense.  */
1061   if (attr.pure || attr.elemental)
1062     {
1063       DECL_IS_PURE (fndecl) = 1;
1064       TREE_SIDE_EFFECTS (fndecl) = 0;
1065     }
1066
1067   /* Layout the function declaration and put it in the binding level
1068      of the current function.  */
1069   if (!attr.external)
1070     {
1071       tree parm;
1072
1073       pushdecl (fndecl);
1074       /* Build formal argument list. Make sure that their TREE_CONTEXT is
1075          the new FUNCTION_DECL node.  */
1076       current_function_decl = fndecl;
1077       arglist = NULL_TREE;
1078       typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
1079       if (gfc_return_by_reference (sym))
1080         {
1081           type = TREE_VALUE (typelist);
1082           parm = build_decl (PARM_DECL, get_identifier ("__result"), type);
1083
1084           DECL_CONTEXT (parm) = fndecl;
1085           DECL_ARG_TYPE (parm) = type;
1086           TREE_READONLY (parm) = 1;
1087           gfc_finish_decl (parm, NULL_TREE);
1088
1089           arglist = chainon (arglist, parm);
1090           typelist = TREE_CHAIN (typelist);
1091
1092           if (sym->ts.type == BT_CHARACTER)
1093             {
1094               gfc_allocate_lang_decl (parm);
1095
1096               /* Length of character result.  */
1097               type = TREE_VALUE (typelist);
1098               assert (type == gfc_strlen_type_node);
1099
1100               length = build_decl (PARM_DECL,
1101                                    get_identifier (".__result"),
1102                                    type);
1103               if (!sym->ts.cl->length)
1104                 {
1105                   sym->ts.cl->backend_decl = length;
1106                   TREE_USED (length) = 1;
1107                 }
1108               assert (TREE_CODE (length) == PARM_DECL);
1109               arglist = chainon (arglist, length);
1110               typelist = TREE_CHAIN (typelist);
1111               DECL_CONTEXT (length) = fndecl;
1112               DECL_ARG_TYPE (length) = type;
1113               TREE_READONLY (length) = 1;
1114               gfc_finish_decl (length, NULL_TREE);
1115             }
1116         }
1117
1118       for (f = sym->formal; f; f = f->next)
1119         {
1120           if (f->sym != NULL)   /* ignore alternate returns. */
1121             {
1122               length = NULL_TREE;
1123
1124               type = TREE_VALUE (typelist);
1125
1126               /* Build a the argument declaration.  */
1127               parm = build_decl (PARM_DECL,
1128                                  gfc_sym_identifier (f->sym), type);
1129
1130               /* Fill in arg stuff.  */
1131               DECL_CONTEXT (parm) = fndecl;
1132               DECL_ARG_TYPE (parm) = type;
1133               DECL_ARG_TYPE_AS_WRITTEN (parm) = type;
1134               /* All implementation args are read-only.  */
1135               TREE_READONLY (parm) = 1;
1136
1137               gfc_finish_decl (parm, NULL_TREE);
1138
1139               f->sym->backend_decl = parm;
1140
1141               arglist = chainon (arglist, parm);
1142               typelist = TREE_CHAIN (typelist);
1143             }
1144         }
1145
1146       /* Add the hidden string length parameters.  */
1147       parm = arglist;
1148       for (f = sym->formal; f; f = f->next)
1149         {
1150           char name[GFC_MAX_SYMBOL_LEN + 2];
1151           /* Ignore alternate returns.  */
1152           if (f->sym == NULL)
1153             continue;
1154
1155           if (f->sym->ts.type != BT_CHARACTER)
1156             continue;
1157
1158           parm = f->sym->backend_decl;
1159           type = TREE_VALUE (typelist);
1160           assert (type == gfc_strlen_type_node);
1161
1162           strcpy (&name[1], f->sym->name);
1163           name[0] = '_';
1164           length = build_decl (PARM_DECL, get_identifier (name), type);
1165
1166           arglist = chainon (arglist, length);
1167           DECL_CONTEXT (length) = fndecl;
1168           DECL_ARG_TYPE (length) = type;
1169           TREE_READONLY (length) = 1;
1170           gfc_finish_decl (length, NULL_TREE);
1171
1172           /* TODO: Check string lengths when -fbounds-check.  */
1173
1174           /* Use the passed value for assumed length variables.  */
1175           if (!f->sym->ts.cl->length)
1176             {
1177               TREE_USED (length) = 1;
1178               f->sym->ts.cl->backend_decl = length;
1179             }
1180
1181           parm = TREE_CHAIN (parm);
1182           typelist = TREE_CHAIN (typelist);
1183         }
1184
1185       assert (TREE_VALUE (typelist) == void_type_node);
1186       DECL_ARGUMENTS (fndecl) = arglist;
1187
1188       /* Restore the old context.  */
1189       current_function_decl = DECL_CONTEXT (fndecl);
1190     }
1191   sym->backend_decl = fndecl;
1192 }
1193
1194
1195 /* Return the decl used to hold the function return value.  */
1196
1197 tree
1198 gfc_get_fake_result_decl (gfc_symbol * sym)
1199 {
1200   tree decl;
1201   tree length;
1202
1203   char name[GFC_MAX_SYMBOL_LEN + 10];
1204
1205   if (current_fake_result_decl != NULL_TREE)
1206     return current_fake_result_decl;
1207
1208   /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
1209      sym is NULL.  */
1210   if (!sym)
1211     return NULL_TREE;
1212
1213   if (sym->ts.type == BT_CHARACTER
1214       && !sym->ts.cl->backend_decl)
1215     {
1216       length = gfc_create_string_length (sym);
1217       gfc_finish_var_decl (length, sym);
1218     }
1219
1220   if (gfc_return_by_reference (sym))
1221     {
1222       decl = DECL_ARGUMENTS (sym->backend_decl);
1223
1224       TREE_USED (decl) = 1;
1225       if (sym->as)
1226         decl = gfc_build_dummy_array_decl (sym, decl);
1227     }
1228   else
1229     {
1230       sprintf (name, "__result_%.20s",
1231                IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
1232
1233       decl = build_decl (VAR_DECL, get_identifier (name),
1234                          TREE_TYPE (TREE_TYPE (current_function_decl)));
1235
1236       DECL_ARTIFICIAL (decl) = 1;
1237       DECL_EXTERNAL (decl) = 0;
1238       TREE_PUBLIC (decl) = 0;
1239       TREE_USED (decl) = 1;
1240
1241       layout_decl (decl, 0);
1242
1243       gfc_add_decl_to_function (decl);
1244     }
1245
1246   current_fake_result_decl = decl;
1247
1248   return decl;
1249 }
1250
1251
1252 /* Builds a function decl.  The remaining parameters are the types of the
1253    function arguments.  Negative nargs indicates a varargs function.  */
1254
1255 tree
1256 gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
1257 {
1258   tree arglist;
1259   tree argtype;
1260   tree fntype;
1261   tree fndecl;
1262   va_list p;
1263   int n;
1264
1265   /* Library functions must be declared with global scope.  */
1266   assert (current_function_decl == NULL_TREE);
1267
1268   va_start (p, nargs);
1269
1270
1271   /* Create a list of the argument types.  */
1272   for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
1273     {
1274       argtype = va_arg (p, tree);
1275       arglist = gfc_chainon_list (arglist, argtype);
1276     }
1277
1278   if (nargs >= 0)
1279     {
1280       /* Terminate the list.  */
1281       arglist = gfc_chainon_list (arglist, void_type_node);
1282     }
1283
1284   /* Build the function type and decl.  */
1285   fntype = build_function_type (rettype, arglist);
1286   fndecl = build_decl (FUNCTION_DECL, name, fntype);
1287
1288   /* Mark this decl as external.  */
1289   DECL_EXTERNAL (fndecl) = 1;
1290   TREE_PUBLIC (fndecl) = 1;
1291
1292   va_end (p);
1293
1294   pushdecl (fndecl);
1295
1296   rest_of_decl_compilation (fndecl, NULL, 1, 0);
1297
1298   return fndecl;
1299 }
1300
1301 static void
1302 gfc_build_intrinsic_function_decls (void)
1303 {
1304   /* String functions.  */
1305   gfor_fndecl_copy_string =
1306     gfc_build_library_function_decl (get_identifier (PREFIX("copy_string")),
1307                                      void_type_node,
1308                                      4,
1309                                      gfc_strlen_type_node, pchar_type_node,
1310                                      gfc_strlen_type_node, pchar_type_node);
1311
1312   gfor_fndecl_compare_string =
1313     gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),
1314                                      gfc_int4_type_node,
1315                                      4,
1316                                      gfc_strlen_type_node, pchar_type_node,
1317                                      gfc_strlen_type_node, pchar_type_node);
1318
1319   gfor_fndecl_concat_string =
1320     gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),
1321                                      void_type_node,
1322                                      6,
1323                                      gfc_strlen_type_node, pchar_type_node,
1324                                      gfc_strlen_type_node, pchar_type_node,
1325                                      gfc_strlen_type_node, pchar_type_node);
1326
1327   gfor_fndecl_string_len_trim =
1328     gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")),
1329                                      gfc_int4_type_node,
1330                                      2, gfc_strlen_type_node,
1331                                      pchar_type_node);
1332
1333   gfor_fndecl_string_index =
1334     gfc_build_library_function_decl (get_identifier (PREFIX("string_index")),
1335                                      gfc_int4_type_node,
1336                                      5, gfc_strlen_type_node, pchar_type_node,
1337                                      gfc_strlen_type_node, pchar_type_node,
1338                                      gfc_logical4_type_node);
1339
1340   gfor_fndecl_string_scan =
1341     gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")),
1342                                      gfc_int4_type_node,
1343                                      5, gfc_strlen_type_node, pchar_type_node,
1344                                      gfc_strlen_type_node, pchar_type_node,
1345                                      gfc_logical4_type_node);
1346
1347   gfor_fndecl_string_verify =
1348     gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")),
1349                                      gfc_int4_type_node,
1350                                      5, gfc_strlen_type_node, pchar_type_node,
1351                                      gfc_strlen_type_node, pchar_type_node,
1352                                      gfc_logical4_type_node);
1353
1354   gfor_fndecl_string_trim = 
1355     gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),
1356                                      void_type_node,
1357                                      4,
1358                                      build_pointer_type (gfc_strlen_type_node),
1359                                      ppvoid_type_node,
1360                                      gfc_strlen_type_node,
1361                                      pchar_type_node);
1362
1363   gfor_fndecl_string_repeat =
1364     gfc_build_library_function_decl (get_identifier (PREFIX("string_repeat")),
1365                                      void_type_node,
1366                                      4,
1367                                      pchar_type_node,
1368                                      gfc_strlen_type_node,
1369                                      pchar_type_node,
1370                                      gfc_int4_type_node);
1371
1372   gfor_fndecl_adjustl =
1373     gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),
1374                                      void_type_node,
1375                                      3,
1376                                      pchar_type_node,
1377                                      gfc_strlen_type_node, pchar_type_node);
1378
1379   gfor_fndecl_adjustr =
1380     gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")),
1381                                      void_type_node,
1382                                      3,
1383                                      pchar_type_node,
1384                                      gfc_strlen_type_node, pchar_type_node);
1385
1386   gfor_fndecl_si_kind =
1387     gfc_build_library_function_decl (get_identifier ("selected_int_kind"),
1388                                      gfc_int4_type_node,
1389                                      1,
1390                                      pvoid_type_node);
1391
1392   gfor_fndecl_sr_kind =
1393     gfc_build_library_function_decl (get_identifier ("selected_real_kind"),
1394                                      gfc_int4_type_node,
1395                                      2, pvoid_type_node,
1396                                      pvoid_type_node);
1397
1398
1399   /* Power functions.  */
1400   {
1401     tree type;
1402     tree itype;
1403     int kind;
1404     int ikind;
1405     static int kinds[2] = {4, 8};
1406     char name[PREFIX_LEN + 10]; /* _gfortran_pow_?n_?n */
1407
1408     for (ikind=0; ikind < 2; ikind++)
1409       {
1410         itype = gfc_get_int_type (kinds[ikind]);
1411         for (kind = 0; kind < 2; kind ++)
1412           {
1413             type = gfc_get_int_type (kinds[kind]);
1414             sprintf(name, PREFIX("pow_i%d_i%d"), kinds[kind], kinds[ikind]);
1415             gfor_fndecl_math_powi[kind][ikind].integer =
1416               gfc_build_library_function_decl (get_identifier (name),
1417                   type, 2, type, itype);
1418
1419             type = gfc_get_real_type (kinds[kind]);
1420             sprintf(name, PREFIX("pow_r%d_i%d"), kinds[kind], kinds[ikind]);
1421             gfor_fndecl_math_powi[kind][ikind].real =
1422               gfc_build_library_function_decl (get_identifier (name),
1423                   type, 2, type, itype);
1424
1425             type = gfc_get_complex_type (kinds[kind]);
1426             sprintf(name, PREFIX("pow_c%d_i%d"), kinds[kind], kinds[ikind]);
1427             gfor_fndecl_math_powi[kind][ikind].cmplx =
1428               gfc_build_library_function_decl (get_identifier (name),
1429                   type, 2, type, itype);
1430           }
1431       }
1432   }
1433
1434   gfor_fndecl_math_cpowf =
1435     gfc_build_library_function_decl (get_identifier ("cpowf"),
1436                                      gfc_complex4_type_node,
1437                                      1, gfc_complex4_type_node);
1438   gfor_fndecl_math_cpow =
1439     gfc_build_library_function_decl (get_identifier ("cpow"),
1440                                      gfc_complex8_type_node,
1441                                      1, gfc_complex8_type_node);
1442   gfor_fndecl_math_cabsf =
1443     gfc_build_library_function_decl (get_identifier ("cabsf"),
1444                                      gfc_real4_type_node,
1445                                      1, gfc_complex4_type_node);
1446   gfor_fndecl_math_cabs =
1447     gfc_build_library_function_decl (get_identifier ("cabs"),
1448                                      gfc_real8_type_node,
1449                                      1, gfc_complex8_type_node);
1450   gfor_fndecl_math_sign4 =
1451     gfc_build_library_function_decl (get_identifier ("copysignf"),
1452                                      gfc_real4_type_node,
1453                                      1, gfc_real4_type_node);
1454   gfor_fndecl_math_sign8 =
1455     gfc_build_library_function_decl (get_identifier ("copysign"),
1456                                      gfc_real8_type_node,
1457                                      1, gfc_real8_type_node);
1458   gfor_fndecl_math_ishftc4 =
1459     gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")),
1460                                      gfc_int4_type_node,
1461                                      3, gfc_int4_type_node,
1462                                      gfc_int4_type_node, gfc_int4_type_node);
1463   gfor_fndecl_math_ishftc8 =
1464     gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")),
1465                                      gfc_int8_type_node,
1466                                      3, gfc_int8_type_node,
1467                                      gfc_int8_type_node, gfc_int8_type_node);
1468   gfor_fndecl_math_exponent4 =
1469     gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r4")),
1470                                      gfc_int4_type_node,
1471                                      1, gfc_real4_type_node);
1472   gfor_fndecl_math_exponent8 =
1473     gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r8")),
1474                                      gfc_int4_type_node,
1475                                      1, gfc_real8_type_node);
1476
1477   /* Other functions.  */
1478   gfor_fndecl_size0 =
1479     gfc_build_library_function_decl (get_identifier (PREFIX("size0")),
1480                                      gfc_array_index_type,
1481                                      1, pvoid_type_node);
1482   gfor_fndecl_size1 =
1483     gfc_build_library_function_decl (get_identifier (PREFIX("size1")),
1484                                      gfc_array_index_type,
1485                                      2, pvoid_type_node,
1486                                      gfc_array_index_type);
1487 }
1488
1489
1490 /* Make prototypes for runtime library functions.  */
1491
1492 void
1493 gfc_build_builtin_function_decls (void)
1494 {
1495   gfor_fndecl_internal_malloc =
1496     gfc_build_library_function_decl (get_identifier (PREFIX("internal_malloc")),
1497                                      pvoid_type_node, 1, gfc_int4_type_node);
1498
1499   gfor_fndecl_internal_malloc64 =
1500     gfc_build_library_function_decl (get_identifier
1501                                      (PREFIX("internal_malloc64")),
1502                                      pvoid_type_node, 1, gfc_int8_type_node);
1503
1504   gfor_fndecl_internal_free =
1505     gfc_build_library_function_decl (get_identifier (PREFIX("internal_free")),
1506                                      void_type_node, 1, pvoid_type_node);
1507
1508   gfor_fndecl_allocate =
1509     gfc_build_library_function_decl (get_identifier (PREFIX("allocate")),
1510                                      void_type_node, 2, ppvoid_type_node,
1511                                      gfc_int4_type_node);
1512
1513   gfor_fndecl_allocate64 =
1514     gfc_build_library_function_decl (get_identifier (PREFIX("allocate64")),
1515                                      void_type_node, 2, ppvoid_type_node,
1516                                      gfc_int8_type_node);
1517
1518   gfor_fndecl_deallocate =
1519     gfc_build_library_function_decl (get_identifier (PREFIX("deallocate")),
1520                                      void_type_node, 1, ppvoid_type_node);
1521
1522   gfor_fndecl_stop_numeric =
1523     gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
1524                                      void_type_node, 1, gfc_int4_type_node);
1525
1526   gfor_fndecl_stop_string =
1527     gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),
1528                                      void_type_node, 2, pchar_type_node,
1529                                      gfc_int4_type_node);
1530
1531   gfor_fndecl_pause_numeric =
1532     gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
1533                                      void_type_node, 1, gfc_int4_type_node);
1534
1535   gfor_fndecl_pause_string =
1536     gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")),
1537                                      void_type_node, 2, pchar_type_node,
1538                                      gfc_int4_type_node);
1539
1540   gfor_fndecl_select_string =
1541     gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
1542                                      pvoid_type_node, 0);
1543
1544   gfor_fndecl_runtime_error =
1545     gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
1546                                      void_type_node,
1547                                      3,
1548                                      pchar_type_node, pchar_type_node,
1549                                      gfc_int4_type_node);
1550
1551   gfor_fndecl_in_pack = gfc_build_library_function_decl (
1552         get_identifier (PREFIX("internal_pack")),
1553         pvoid_type_node, 1, pvoid_type_node);
1554
1555   gfor_fndecl_in_unpack = gfc_build_library_function_decl (
1556         get_identifier (PREFIX("internal_unpack")),
1557         pvoid_type_node, 1, pvoid_type_node);
1558
1559   gfor_fndecl_associated =
1560     gfc_build_library_function_decl (
1561                                      get_identifier (PREFIX("associated")),
1562                                      gfc_logical4_type_node,
1563                                      2,
1564                                      ppvoid_type_node,
1565                                      ppvoid_type_node);
1566
1567   gfc_build_intrinsic_function_decls ();
1568   gfc_build_intrinsic_lib_fndecls ();
1569   gfc_build_io_library_fndecls ();
1570 }
1571
1572
1573 /* Exaluate the length of dummy character variables.  */
1574
1575 static tree
1576 gfc_trans_dummy_character (gfc_charlen * cl, tree fnbody)
1577 {
1578   stmtblock_t body;
1579
1580   gfc_finish_decl (cl->backend_decl, NULL_TREE);
1581
1582   gfc_start_block (&body);
1583
1584   /* Evaluate the string length expression.  */
1585   gfc_trans_init_string_length (cl, &body);
1586   
1587   gfc_add_expr_to_block (&body, fnbody);
1588   return gfc_finish_block (&body);
1589 }
1590
1591
1592 /* Allocate and cleanup an automatic character variable.  */
1593
1594 static tree
1595 gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
1596 {
1597   stmtblock_t body;
1598   tree decl;
1599   tree args;
1600   tree tmp;
1601
1602   assert (sym->backend_decl);
1603   assert (sym->ts.cl && sym->ts.cl->length);
1604
1605   gfc_start_block (&body);
1606
1607   /* Evaluate the string length expression.  */
1608   gfc_trans_init_string_length (sym->ts.cl, &body);
1609
1610   decl = sym->backend_decl;
1611
1612   DECL_DEFER_OUTPUT (decl) = 1;
1613
1614   /* Generate code to allocate the automatic variable.  It will be freed
1615      automatically.  */
1616   tmp = gfc_build_addr_expr (NULL, decl);
1617   args = gfc_chainon_list (NULL_TREE, tmp);
1618   args = gfc_chainon_list (args, sym->ts.cl->backend_decl);
1619   tmp = gfc_build_function_call (built_in_decls[BUILT_IN_STACK_ALLOC], args);
1620   gfc_add_expr_to_block (&body, tmp);
1621   gfc_add_expr_to_block (&body, fnbody);
1622   return gfc_finish_block (&body);
1623 }
1624
1625
1626 /* Generate function entry and exit code, and add it to the function body.
1627    This includes:
1628     Allocation and initialisation of array variables.
1629     Allocation of character string variables.
1630     Initialization and possibly repacking of dummy arrays.  */
1631
1632 static tree
1633 gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
1634 {
1635   locus loc;
1636   gfc_symbol *sym;
1637
1638   /* Deal with implicit return variables.  Explicit return variables will
1639      already have been added.  */
1640   if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
1641     {
1642       if (!current_fake_result_decl)
1643         {
1644           warning ("Function does not return a value");
1645           return fnbody;
1646         }
1647
1648       if (proc_sym->as)
1649         {
1650           fnbody = gfc_trans_dummy_array_bias (proc_sym,
1651                                                current_fake_result_decl,
1652                                                fnbody);
1653         }
1654       else if (proc_sym->ts.type == BT_CHARACTER)
1655         {
1656           if (TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
1657             fnbody = gfc_trans_dummy_character (proc_sym->ts.cl, fnbody);
1658         }
1659       else
1660         gfc_todo_error ("Deferred non-array return by reference");
1661     }
1662
1663   for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
1664     {
1665       if (sym->attr.dimension)
1666         {
1667           switch (sym->as->type)
1668             {
1669             case AS_EXPLICIT:
1670               if (sym->attr.dummy || sym->attr.result)
1671                 fnbody =
1672                   gfc_trans_dummy_array_bias (sym, sym->backend_decl, fnbody);
1673               else if (sym->attr.pointer || sym->attr.allocatable)
1674                 {
1675                   if (TREE_STATIC (sym->backend_decl))
1676                     gfc_trans_static_array_pointer (sym);
1677                   else
1678                     fnbody = gfc_trans_deferred_array (sym, fnbody);
1679                 }
1680               else
1681                 {
1682                   gfc_get_backend_locus (&loc);
1683                   gfc_set_backend_locus (&sym->declared_at);
1684                   fnbody = gfc_trans_auto_array_allocation (sym->backend_decl,
1685                       sym, fnbody);
1686                   gfc_set_backend_locus (&loc);
1687                 }
1688               break;
1689
1690             case AS_ASSUMED_SIZE:
1691               /* Must be a dummy parameter.  */
1692               assert (sym->attr.dummy);
1693
1694               /* We should always pass assumed size arrays the g77 way.  */
1695               assert (TREE_CODE (sym->backend_decl) == PARM_DECL);
1696               fnbody = gfc_trans_g77_array (sym, fnbody);
1697               break;
1698
1699             case AS_ASSUMED_SHAPE:
1700               /* Must be a dummy parameter.  */
1701               assert (sym->attr.dummy);
1702
1703               fnbody = gfc_trans_dummy_array_bias (sym, sym->backend_decl,
1704                                                    fnbody);
1705               break;
1706
1707             case AS_DEFERRED:
1708               fnbody = gfc_trans_deferred_array (sym, fnbody);
1709               break;
1710
1711             default:
1712               abort ();
1713             }
1714         }
1715       else if (sym->ts.type == BT_CHARACTER)
1716         {
1717           gfc_get_backend_locus (&loc);
1718           gfc_set_backend_locus (&sym->declared_at);
1719           if (sym->attr.dummy || sym->attr.result)
1720             fnbody = gfc_trans_dummy_character (sym->ts.cl, fnbody);
1721           else
1722             fnbody = gfc_trans_auto_character_variable (sym, fnbody);
1723           gfc_set_backend_locus (&loc);
1724         }
1725       else
1726         abort ();
1727     }
1728
1729   return fnbody;
1730 }
1731
1732
1733 /* Output an initialized decl for a module variable.  */
1734
1735 static void
1736 gfc_create_module_variable (gfc_symbol * sym)
1737 {
1738   tree decl;
1739   gfc_se se;
1740
1741   /* Only output symbols from this module.  */
1742   if (sym->ns != module_namespace)
1743     {
1744       /* I don't think this should ever happen.  */
1745       internal_error ("module symbol %s in wrong namespace", sym->name);
1746     }
1747
1748   /* Don't ouptut symbols from common blocks.  */
1749   if (sym->attr.common)
1750     return;
1751
1752   /* Only output variables and array valued parametes.  */
1753   if (sym->attr.flavor != FL_VARIABLE
1754       && (sym->attr.flavor != FL_PARAMETER || sym->attr.dimension == 0))
1755     return;
1756
1757   /* Don't generate variables from other modules.  */
1758   if (sym->attr.use_assoc)
1759     return;
1760
1761   if (sym->backend_decl)
1762     internal_error ("backend decl for module variable %s already exists",
1763                     sym->name);
1764
1765   /* We always want module variables to be created.  */
1766   sym->attr.referenced = 1;
1767   /* Create the decl.  */
1768   decl = gfc_get_symbol_decl (sym);
1769
1770   /* We want to allocate storage for this variable.  */
1771   TREE_STATIC (decl) = 1;
1772
1773   if (sym->attr.dimension)
1774     {
1775       assert (sym->attr.pointer || sym->attr.allocatable
1776               || GFC_ARRAY_TYPE_P (TREE_TYPE (sym->backend_decl)));
1777       if (sym->attr.pointer || sym->attr.allocatable)
1778         gfc_trans_static_array_pointer (sym);
1779       else
1780         gfc_trans_auto_array_allocation (sym->backend_decl, sym, NULL_TREE);
1781     }
1782   else if (sym->ts.type == BT_DERIVED)
1783     {
1784       if (sym->value)
1785         gfc_todo_error ("Initialization of derived type module variables");
1786     }
1787   else
1788     {
1789       if (sym->value)
1790         {
1791           gfc_init_se (&se, NULL);
1792           gfc_conv_constant (&se, sym->value);
1793           DECL_INITIAL (decl) = se.expr;
1794         }
1795     }
1796
1797   /* Create the variable.  */
1798   pushdecl (decl);
1799   rest_of_decl_compilation (decl, NULL, 1, 0);
1800
1801   /* Also add length of strings.  */
1802   if (sym->ts.type == BT_CHARACTER)
1803     {
1804       tree length;
1805
1806       length = sym->ts.cl->backend_decl;
1807       if (!INTEGER_CST_P (length))
1808         {
1809           pushdecl (length);
1810           rest_of_decl_compilation (length, NULL, 1, 0);
1811         }
1812     }
1813 }
1814
1815
1816 /* Generate all the required code for module variables.  */
1817
1818 void
1819 gfc_generate_module_vars (gfc_namespace * ns)
1820 {
1821   module_namespace = ns;
1822
1823   /* Check if the frontend left the namespace in a reasonable state.  */
1824   assert (ns->proc_name && !ns->proc_name->tlink);
1825
1826   /* Create decls for all the module variables.  */
1827   gfc_traverse_ns (ns, gfc_create_module_variable);
1828 }
1829
1830 static void
1831 gfc_generate_contained_functions (gfc_namespace * parent)
1832 {
1833   gfc_namespace *ns;
1834
1835   /* We create all the prototypes before generating any code.  */
1836   for (ns = parent->contained; ns; ns = ns->sibling)
1837     {
1838       /* Skip namespaces from used modules.  */
1839       if (ns->parent != parent)
1840         continue;
1841
1842       gfc_build_function_decl (ns->proc_name);
1843     }
1844
1845   for (ns = parent->contained; ns; ns = ns->sibling)
1846     {
1847       /* Skip namespaces from used modules.  */
1848       if (ns->parent != parent)
1849         continue;
1850
1851       gfc_generate_function_code (ns);
1852     }
1853 }
1854
1855
1856 /* Generate decls for all local variables.  We do this to ensure correct
1857    handling of expressions which only appear in the specification of
1858    other functions.  */
1859
1860 static void
1861 generate_local_decl (gfc_symbol * sym)
1862 {
1863   if (sym->attr.flavor == FL_VARIABLE)
1864     {
1865       /* TODO: The frontend sometimes creates symbols for things which don't
1866          actually exist.  E.g. common block names and the names of formal
1867          arguments.  The latter are created while attempting to parse
1868          the argument list as a substring reference.
1869
1870          The proper fix is to avoid adding these symbols in the first place.
1871          For now we hack round it by ignoring anything with an unknown type.
1872        */
1873       if (sym->ts.type == BT_UNKNOWN)
1874         return;
1875
1876       if (sym->attr.referenced)
1877         gfc_get_symbol_decl (sym);
1878       else if (sym->attr.dummy)
1879         {
1880           if (warn_unused_parameter)
1881             warning ("unused parameter `%s'", sym->name);
1882         }
1883       /* warn for unused variables, but not if they're inside a common
1884          block.  */
1885       else if (warn_unused_variable && !sym->attr.in_common)
1886         warning ("unused variable `%s'", sym->name);
1887     }
1888 }
1889
1890 static void
1891 generate_local_vars (gfc_namespace * ns)
1892 {
1893   gfc_traverse_ns (ns, generate_local_decl);
1894 }
1895
1896
1897 /* Finalize DECL and all nested functions with cgraph.  */
1898
1899 static void
1900 gfc_finalize (tree decl)
1901 {
1902   struct cgraph_node *cgn;
1903
1904   cgn = cgraph_node (decl);
1905   for (cgn = cgn->nested; cgn ; cgn = cgn->next_nested)
1906     gfc_finalize (cgn->decl);
1907
1908   cgraph_finalize_function (decl, false);
1909 }
1910
1911 /* Generate code for a function.  */
1912
1913 void
1914 gfc_generate_function_code (gfc_namespace * ns)
1915 {
1916   tree fndecl;
1917   tree old_context;
1918   tree decl;
1919   tree tmp;
1920   stmtblock_t block;
1921   stmtblock_t body;
1922   tree result;
1923   gfc_symbol *sym;
1924
1925   sym = ns->proc_name;
1926   /* Check that the frontend isn't still using this.  */
1927   assert (sym->tlink == NULL);
1928
1929   sym->tlink = sym;
1930
1931   /* Create the declaration for functions with global scope.  */
1932   if (!sym->backend_decl)
1933     gfc_build_function_decl (ns->proc_name);
1934
1935   fndecl = sym->backend_decl;
1936   old_context = current_function_decl;
1937
1938   if (old_context)
1939     {
1940       push_function_context ();
1941       saved_parent_function_decls = saved_function_decls;
1942       saved_function_decls = NULL_TREE;
1943     }
1944
1945   /* let GCC know the current scope is this function */
1946   current_function_decl = fndecl;
1947
1948   /* print function name on the console at compile time
1949      (unless this feature was switched of by command line option "-quiet" */
1950   announce_function (fndecl);
1951
1952   if (DECL_CONTEXT (fndecl) == NULL_TREE)
1953     {
1954       /* create RTL for function declaration */
1955       rest_of_decl_compilation (fndecl, NULL, 1, 0);
1956     }
1957
1958   /* create RTL for function definition */
1959   make_decl_rtl (fndecl, NULL);
1960
1961   /* Set the line and filename.  sym->decalred_at seems to point to the last
1962      statement for subroutines, but it'll do for now.  */
1963   gfc_set_backend_locus (&sym->declared_at);
1964
1965   /* line and file should not be 0 */
1966   init_function_start (fndecl);
1967
1968   /* We're in function-at-a-time mode. */
1969   cfun->x_whole_function_mode_p = 1;
1970
1971   /* Even though we're inside a function body, we still don't want to
1972      call expand_expr to calculate the size of a variable-sized array.
1973      We haven't necessarily assigned RTL to all variables yet, so it's
1974      not safe to try to expand expressions involving them.  */
1975   immediate_size_expand = 0;
1976   cfun->x_dont_save_pending_sizes_p = 1;
1977
1978   /* Will be created as needed.  */
1979   current_fake_result_decl = NULL_TREE;
1980
1981   /* function.c requires a push at the start of the function */
1982   pushlevel (0);
1983
1984   gfc_start_block (&block);
1985
1986   gfc_generate_contained_functions (ns);
1987
1988   /* Translate COMMON blocks.  */
1989   gfc_trans_common (ns);
1990
1991   generate_local_vars (ns);
1992
1993   current_function_return_label = NULL;
1994
1995   /* Now generate the code for the body of this function.  */
1996   gfc_init_block (&body);
1997
1998   if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
1999       && sym->attr.subroutine)
2000     {
2001       tree alternate_return;
2002       alternate_return = gfc_get_fake_result_decl (sym);
2003       gfc_add_modify_expr (&body, alternate_return, integer_zero_node);
2004     }
2005
2006   tmp = gfc_trans_code (ns->code);
2007   gfc_add_expr_to_block (&body, tmp);
2008
2009   /* Add a return label if needed.  */
2010   if (current_function_return_label)
2011     {
2012       tmp = build1_v (LABEL_EXPR, current_function_return_label);
2013       gfc_add_expr_to_block (&body, tmp);
2014     }
2015
2016   tmp = gfc_finish_block (&body);
2017   /* Add code to create and cleanup arrays.  */
2018   tmp = gfc_trans_deferred_vars (sym, tmp);
2019   gfc_add_expr_to_block (&block, tmp);
2020
2021   if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
2022     {
2023       if (sym->attr.subroutine ||sym == sym->result)
2024         {
2025           result = current_fake_result_decl;
2026           current_fake_result_decl = NULL_TREE;
2027         }
2028       else
2029         result = sym->result->backend_decl;
2030
2031       if (result == NULL_TREE)
2032         warning ("Function return value not set");
2033       else
2034         {
2035           /* Set the return value to the the dummy result variable.  */
2036           tmp = build (MODIFY_EXPR, TREE_TYPE (result),
2037                        DECL_RESULT (fndecl), result);
2038           tmp = build_v (RETURN_EXPR, tmp);
2039           gfc_add_expr_to_block (&block, tmp);
2040         }
2041     }
2042
2043   /* Add all the decls we created during processing.  */
2044   decl = saved_function_decls;
2045   while (decl)
2046     {
2047       tree next;
2048
2049       next = TREE_CHAIN (decl);
2050       TREE_CHAIN (decl) = NULL_TREE;
2051       pushdecl (decl);
2052       decl = next;
2053     }
2054   saved_function_decls = NULL_TREE;
2055
2056   DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);
2057
2058   /* Finish off this function and send it for code generation.  */
2059   poplevel (1, 0, 1);
2060   BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
2061
2062   /* Output the GENERIC tree.  */
2063   dump_function (TDI_original, fndecl);
2064
2065   /* Store the end of the function, so that we get good line number
2066      info for the epilogue.  */
2067   cfun->function_end_locus = input_location;
2068
2069   /* We're leaving the context of this function, so zap cfun.
2070      It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
2071      tree_rest_of_compilation.  */
2072   cfun = NULL;
2073
2074   if (old_context)
2075     {
2076       pop_function_context ();
2077       saved_function_decls = saved_parent_function_decls;
2078     }
2079   current_function_decl = old_context;
2080
2081   if (decl_function_context (fndecl))
2082     {
2083       /* Register this function with cgraph just far enough to get it
2084          added to our parent's nested function list.  */
2085       (void) cgraph_node (fndecl);
2086
2087       /* Lowering nested functions requires gimple input.  */
2088       gimplify_function_tree (fndecl);
2089     }
2090   else
2091     {
2092       if (cgraph_node (fndecl)->nested)
2093         {
2094           gimplify_function_tree (fndecl);
2095           lower_nested_functions (fndecl);
2096         }
2097       gfc_finalize (fndecl);
2098     }
2099 }
2100
2101
2102 void
2103 gfc_generate_constructors (void)
2104 {
2105   if (gfc_static_ctors != NULL_TREE)
2106     abort ();
2107 #if 0
2108   tree fnname;
2109   tree type;
2110   tree fndecl;
2111   tree decl;
2112   tree tmp;
2113
2114   if (gfc_static_ctors == NULL_TREE)
2115     return;
2116
2117   fnname = get_file_function_name ('I');
2118   type = build_function_type (void_type_node,
2119                               gfc_chainon_list (NULL_TREE, void_type_node));
2120
2121   fndecl = build_decl (FUNCTION_DECL, fnname, type);
2122   TREE_PUBLIC (fndecl) = 1;
2123
2124   decl = build_decl (RESULT_DECL, NULL_TREE, void_type_node);
2125   DECL_CONTEXT (decl) = fndecl;
2126   DECL_RESULT (fndecl) = decl;
2127
2128   pushdecl (fndecl);
2129
2130   current_function_decl = fndecl;
2131
2132   rest_of_decl_compilation (fndecl, NULL, 1, 0);
2133
2134   make_decl_rtl (fndecl, NULL);
2135
2136   init_function_start (fndecl, input_filename, input_line);
2137
2138   cfun->x_whole_function_mode_p = 1;
2139
2140   immediate_size_expand = 0;
2141
2142   pushlevel (0);
2143
2144   for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
2145     {
2146       tmp =
2147         gfc_build_function_call (TREE_VALUE (gfc_static_ctors), NULL_TREE);
2148       DECL_SAVED_TREE (fndecl) = build_stmt (EXPR_STMT, tmp);
2149     }
2150
2151   poplevel (1, 0, 1);
2152
2153   BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
2154
2155   free_after_parsing (cfun);
2156   free_after_compilation (cfun);
2157
2158   tree_rest_of_compilation (fndecl, 0);
2159
2160   current_function_decl = NULL_TREE;
2161 #endif
2162 }
2163
2164 #include "gt-fortran-trans-decl.h"