OSDN Git Service

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