OSDN Git Service

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