OSDN Git Service

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