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