OSDN Git Service

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