]> 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
PR fortran/16336
[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;
697 gfc_se se;
698 int byref;
699
700 assert (sym->attr.referenced);
701
702 if (sym->ns && sym->ns->proc_name->attr.function)
703 byref = gfc_return_by_reference (sym->ns->proc_name);
704 else
705 byref = 0;
706
707 if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
708 {
709 /* Return via extra parameter. */
710 if (sym->attr.result && byref
711 && !sym->backend_decl)
712 {
713 sym->backend_decl =
714 DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);
715 }
716
717 /* Dummy variables should already have been created. */
718 assert (sym->backend_decl);
719
720 /* Create a character length variable. */
721 if (sym->ts.type == BT_CHARACTER)
722 {
723 if (sym->ts.cl->backend_decl == NULL_TREE)
724 {
725 length = gfc_create_string_length (sym);
726 if (TREE_CODE (length) != INTEGER_CST)
727 {
728 gfc_finish_var_decl (length, sym);
729 gfc_defer_symbol_init (sym);
730 }
731 }
732 }
733
734 /* Use a copy of the descriptor for dummy arrays. */
735 if (sym->attr.dimension && !TREE_USED (sym->backend_decl))
736 {
737 sym->backend_decl =
738 gfc_build_dummy_array_decl (sym, sym->backend_decl);
739 }
740
741 TREE_USED (sym->backend_decl) = 1;
742 return sym->backend_decl;
743 }
744
745 if (sym->backend_decl)
746 return sym->backend_decl;
747
748 if (sym->attr.entry)
749 gfc_todo_error ("alternate entry");
750
751 /* Catch function declarations. Only used for actual parameters. */
752 if (sym->attr.flavor == FL_PROCEDURE)
753 {
754 decl = gfc_get_extern_function_decl (sym);
755 return decl;
756 }
757
758 if (sym->attr.intrinsic)
759 internal_error ("intrinsic variable which isn't a procedure");
760
761 /* Create string length decl first so that they can be used in the
762 type declaration. */
763 if (sym->ts.type == BT_CHARACTER)
764 length = gfc_create_string_length (sym);
765
766 /* Create the decl for the variable. */
767 decl = build_decl (VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
768
769 /* Symbols from modules have its assembler name should be mangled.
770 This is done here rather than in gfc_finish_var_decl because it
771 is different for string length variables. */
772 if (sym->module[0])
773 SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_identifier (sym));
774
775 if (sym->attr.dimension)
776 {
777 /* Create variables to hold the non-constant bits of array info. */
778 gfc_build_qualified_array (decl, sym);
779
780 /* Remember this variable for allocation/cleanup. */
781 gfc_defer_symbol_init (sym);
782
783 if ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer)
784 GFC_DECL_PACKED_ARRAY (decl) = 1;
785 }
786
787 gfc_finish_var_decl (decl, sym);
788
789 if (sym->attr.assign)
790 {
791 gfc_allocate_lang_decl (decl);
792 GFC_DECL_ASSIGN (decl) = 1;
793 length = gfc_create_var (gfc_strlen_type_node, sym->name);
794 GFC_DECL_STRING_LEN (decl) = length;
795 GFC_DECL_ASSIGN_ADDR (decl) = gfc_create_var (pvoid_type_node, sym->name);
796 /* TODO: Need to check we don't change TREE_STATIC (decl) later. */
797 TREE_STATIC (length) = TREE_STATIC (decl);
798 /* STRING_LENGTH is also used as flag. Less than -1 means that
799 ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
800 target label's address. Other value is the length of format string
801 and ASSIGN_ADDR is the address of format string. */
802 DECL_INITIAL (length) = build_int_2 (-2, -1);
803 }
804
805 /* TODO: Initialization of pointer variables. */
806 switch (sym->ts.type)
807 {
808 case BT_CHARACTER:
809 /* Character variables need special handling. */
810 gfc_allocate_lang_decl (decl);
811
812 if (TREE_CODE (length) == INTEGER_CST)
813 {
814 /* Static initializer for string scalars.
815 Initialization of string arrays is handled elsewhere. */
816 if (sym->value && sym->attr.dimension == 0)
817 {
818 assert (TREE_STATIC (decl));
819 if (sym->attr.pointer)
820 gfc_todo_error ("initialization of character pointers");
821 DECL_INITIAL (decl) = gfc_conv_string_init (length, sym->value);
822 }
823 }
824 else
825 {
826 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
827
828 if (sym->module[0])
829 {
830 /* Also prefix the mangled name for symbols from modules. */
831 strcpy (&name[1], sym->name);
832 name[0] = '.';
833 strcpy (&name[1],
834 IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length)));
835 SET_DECL_ASSEMBLER_NAME (decl, get_identifier (name));
836 }
837 gfc_finish_var_decl (length, sym);
838 assert (!sym->value);
839 }
840 break;
841
842 case BT_DERIVED:
843 if (sym->value && ! (sym->attr.use_assoc || sym->attr.dimension))
844 {
845 gfc_init_se (&se, NULL);
846 gfc_conv_structure (&se, sym->value, 1);
847 DECL_INITIAL (decl) = se.expr;
848 }
849 break;
850
851 default:
852 /* Static initializers for SAVEd variables. Arrays have already been
853 remembered. Module variables are initialized when the module is
854 loaded. */
855 if (sym->value && ! (sym->attr.use_assoc || sym->attr.dimension))
856 {
857 assert (TREE_STATIC (decl));
858 gfc_init_se (&se, NULL);
859 gfc_conv_constant (&se, sym->value);
860 DECL_INITIAL (decl) = se.expr;
861 }
862 break;
863 }
864 sym->backend_decl = decl;
865
866 return decl;
867}
868
869
dbe60343 870/* Substitute a temporary variable in place of the real one. */
871
872void
873gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
874{
875 save->attr = sym->attr;
876 save->decl = sym->backend_decl;
877
878 gfc_clear_attr (&sym->attr);
879 sym->attr.referenced = 1;
880 sym->attr.flavor = FL_VARIABLE;
881
882 sym->backend_decl = decl;
883}
884
885
886/* Restore the original variable. */
887
888void
889gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
890{
891 sym->attr = save->attr;
892 sym->backend_decl = save->decl;
893}
894
895
4ee9c684 896/* Get a basic decl for an external function. */
897
898tree
899gfc_get_extern_function_decl (gfc_symbol * sym)
900{
901 tree type;
902 tree fndecl;
903 gfc_expr e;
904 gfc_intrinsic_sym *isym;
905 gfc_expr argexpr;
906 char s[GFC_MAX_SYMBOL_LEN];
907 tree name;
908 tree mangled_name;
909
910 if (sym->backend_decl)
911 return sym->backend_decl;
912
913 if (sym->attr.intrinsic)
914 {
915 /* Call the resolution function to get the actual name. This is
916 a nasty hack which relies on the resolution functions only looking
917 at the first argument. We pass NULL for the second argument
918 otherwise things like AINT get confused. */
919 isym = gfc_find_function (sym->name);
920 assert (isym->resolve.f0 != NULL);
921
922 memset (&e, 0, sizeof (e));
923 e.expr_type = EXPR_FUNCTION;
924
925 memset (&argexpr, 0, sizeof (argexpr));
926 assert (isym->formal);
927 argexpr.ts = isym->formal->ts;
928
929 if (isym->formal->next == NULL)
930 isym->resolve.f1 (&e, &argexpr);
931 else
932 {
933 /* All specific intrinsics take one or two arguments. */
934 assert (isym->formal->next->next == NULL);
935 isym->resolve.f2 (&e, &argexpr, NULL);
936 }
937 sprintf (s, "specific%s", e.value.function.name);
938 name = get_identifier (s);
939 mangled_name = name;
940 }
941 else
942 {
943 name = gfc_sym_identifier (sym);
944 mangled_name = gfc_sym_mangled_function_id (sym);
945 }
946
947 type = gfc_get_function_type (sym);
948 fndecl = build_decl (FUNCTION_DECL, name, type);
949
950 SET_DECL_ASSEMBLER_NAME (fndecl, mangled_name);
951 /* If the return type is a pointer, avoid alias issues by setting
952 DECL_IS_MALLOC to nonzero. This means that the function should be
953 treated as if it were a malloc, meaning it returns a pointer that
954 is not an alias. */
955 if (POINTER_TYPE_P (type))
956 DECL_IS_MALLOC (fndecl) = 1;
957
958 /* Set the context of this decl. */
959 if (0 && sym->ns && sym->ns->proc_name)
960 {
961 /* TODO: Add external decls to the appropriate scope. */
962 DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
963 }
964 else
965 {
966 /* Global declaration, eg. intrinsic subroutine. */
967 DECL_CONTEXT (fndecl) = NULL_TREE;
968 }
969
970 DECL_EXTERNAL (fndecl) = 1;
971
972 /* This specifies if a function is globaly addressable, ie. it is
973 the opposite of declaring static in C. */
974 TREE_PUBLIC (fndecl) = 1;
975
976 /* Set attributes for PURE functions. A call to PURE function in the
977 Fortran 95 sense is both pure and without side effects in the C
978 sense. */
979 if (sym->attr.pure || sym->attr.elemental)
980 {
be393645 981 if (sym->attr.function)
982 DECL_IS_PURE (fndecl) = 1;
983 /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
984 parameters and don't use alternate returns (is this
985 allowed?). In that case, calls to them are meaningless, and
986 can be optimized away. See also in gfc_build_function_decl(). */
987 TREE_SIDE_EFFECTS (fndecl) = 0;
4ee9c684 988 }
989
990 sym->backend_decl = fndecl;
991
992 if (DECL_CONTEXT (fndecl) == NULL_TREE)
993 pushdecl_top_level (fndecl);
994
995 return fndecl;
996}
997
998
999/* Create a declaration for a procedure. For external functions (in the C
1000 sense) use gfc_get_extern_function_decl. */
1001
1002void
1003gfc_build_function_decl (gfc_symbol * sym)
1004{
1005 tree fndecl, type, result_decl, typelist, arglist;
1006 tree length;
1007 symbol_attribute attr;
1008 gfc_formal_arglist *f;
1009
1010 assert (!sym->backend_decl);
1011 assert (!sym->attr.external);
1012
1013 /* Allow only one nesting level. Allow public declarations. */
1014 assert (current_function_decl == NULL_TREE
1015 || DECL_CONTEXT (current_function_decl) == NULL_TREE);
1016
1017 type = gfc_get_function_type (sym);
1018 fndecl = build_decl (FUNCTION_DECL, gfc_sym_identifier (sym), type);
1019
1020 /* Perform name mangling if this is a top level or module procedure. */
1021 if (current_function_decl == NULL_TREE)
1022 SET_DECL_ASSEMBLER_NAME (fndecl, gfc_sym_mangled_function_id (sym));
1023
1024 /* Figure out the return type of the declared function, and build a
1025 RESULT_DECL for it. If this is subroutine with alternate
1026 returns, build a RESULT_DECL for it. */
1027 attr = sym->attr;
1028
1029 result_decl = NULL_TREE;
1030 /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
1031 if (attr.function)
1032 {
1033 if (gfc_return_by_reference (sym))
1034 type = void_type_node;
1035 else
1036 {
1037 if (sym->result != sym)
1038 result_decl = gfc_sym_identifier (sym->result);
1039
1040 type = TREE_TYPE (TREE_TYPE (fndecl));
1041 }
1042 }
1043 else
1044 {
1045 /* Look for alternate return placeholders. */
1046 int has_alternate_returns = 0;
1047 for (f = sym->formal; f; f = f->next)
1048 {
1049 if (f->sym == NULL)
1050 {
1051 has_alternate_returns = 1;
1052 break;
1053 }
1054 }
1055
1056 if (has_alternate_returns)
1057 type = integer_type_node;
1058 else
1059 type = void_type_node;
1060 }
1061
1062 result_decl = build_decl (RESULT_DECL, result_decl, type);
1063 DECL_CONTEXT (result_decl) = fndecl;
1064 DECL_RESULT (fndecl) = result_decl;
1065
1066 /* Don't call layout_decl for a RESULT_DECL.
1067 layout_decl (result_decl, 0); */
1068
1069 /* If the return type is a pointer, avoid alias issues by setting
1070 DECL_IS_MALLOC to nonzero. This means that the function should be
1071 treated as if it were a malloc, meaning it returns a pointer that
1072 is not an alias. */
1073 if (POINTER_TYPE_P (type))
1074 DECL_IS_MALLOC (fndecl) = 1;
1075
1076 /* Set up all attributes for the function. */
1077 DECL_CONTEXT (fndecl) = current_function_decl;
1078 DECL_EXTERNAL (fndecl) = 0;
1079
1080 /* This specifies if a function is globaly addressable, ie. it is
dfc222eb 1081 the opposite of declaring static in C. */
4ee9c684 1082 if (DECL_CONTEXT (fndecl) == NULL_TREE || attr.external)
1083 TREE_PUBLIC (fndecl) = 1;
1084
1085 /* TREE_STATIC means the function body is defined here. */
1086 if (!attr.external)
1087 TREE_STATIC (fndecl) = 1;
1088
1089 /* Set attributes for PURE functions. A call to PURE function in the
1090 Fortran 95 sense is both pure and without side effects in the C
1091 sense. */
1092 if (attr.pure || attr.elemental)
1093 {
be393645 1094 /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
1095 including a alternate return. In that case it can also be
1096 marked as PURE. See also in gfc_get_extern_fucntion_decl(). */
1097 if (attr.function)
1098 DECL_IS_PURE (fndecl) = 1;
4ee9c684 1099 TREE_SIDE_EFFECTS (fndecl) = 0;
1100 }
1101
1102 /* Layout the function declaration and put it in the binding level
1103 of the current function. */
1104 if (!attr.external)
1105 {
1106 tree parm;
1107
1108 pushdecl (fndecl);
1109 /* Build formal argument list. Make sure that their TREE_CONTEXT is
1110 the new FUNCTION_DECL node. */
1111 current_function_decl = fndecl;
1112 arglist = NULL_TREE;
1113 typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
1114 if (gfc_return_by_reference (sym))
1115 {
1116 type = TREE_VALUE (typelist);
1117 parm = build_decl (PARM_DECL, get_identifier ("__result"), type);
1118
1119 DECL_CONTEXT (parm) = fndecl;
1120 DECL_ARG_TYPE (parm) = type;
1121 TREE_READONLY (parm) = 1;
1122 gfc_finish_decl (parm, NULL_TREE);
1123
1124 arglist = chainon (arglist, parm);
1125 typelist = TREE_CHAIN (typelist);
1126
1127 if (sym->ts.type == BT_CHARACTER)
1128 {
1129 gfc_allocate_lang_decl (parm);
1130
dfc222eb 1131 /* Length of character result. */
4ee9c684 1132 type = TREE_VALUE (typelist);
1133 assert (type == gfc_strlen_type_node);
1134
1135 length = build_decl (PARM_DECL,
1136 get_identifier (".__result"),
1137 type);
1138 if (!sym->ts.cl->length)
1139 {
1140 sym->ts.cl->backend_decl = length;
1141 TREE_USED (length) = 1;
1142 }
1143 assert (TREE_CODE (length) == PARM_DECL);
1144 arglist = chainon (arglist, length);
1145 typelist = TREE_CHAIN (typelist);
1146 DECL_CONTEXT (length) = fndecl;
1147 DECL_ARG_TYPE (length) = type;
1148 TREE_READONLY (length) = 1;
1149 gfc_finish_decl (length, NULL_TREE);
1150 }
1151 }
1152
1153 for (f = sym->formal; f; f = f->next)
1154 {
1155 if (f->sym != NULL) /* ignore alternate returns. */
1156 {
1157 length = NULL_TREE;
1158
1159 type = TREE_VALUE (typelist);
1160
1161 /* Build a the argument declaration. */
1162 parm = build_decl (PARM_DECL,
1163 gfc_sym_identifier (f->sym), type);
1164
1165 /* Fill in arg stuff. */
1166 DECL_CONTEXT (parm) = fndecl;
1167 DECL_ARG_TYPE (parm) = type;
1168 DECL_ARG_TYPE_AS_WRITTEN (parm) = type;
1169 /* All implementation args are read-only. */
1170 TREE_READONLY (parm) = 1;
1171
1172 gfc_finish_decl (parm, NULL_TREE);
1173
1174 f->sym->backend_decl = parm;
1175
1176 arglist = chainon (arglist, parm);
1177 typelist = TREE_CHAIN (typelist);
1178 }
1179 }
1180
1181 /* Add the hidden string length parameters. */
1182 parm = arglist;
1183 for (f = sym->formal; f; f = f->next)
1184 {
1185 char name[GFC_MAX_SYMBOL_LEN + 2];
1186 /* Ignore alternate returns. */
1187 if (f->sym == NULL)
1188 continue;
1189
1190 if (f->sym->ts.type != BT_CHARACTER)
1191 continue;
1192
1193 parm = f->sym->backend_decl;
1194 type = TREE_VALUE (typelist);
1195 assert (type == gfc_strlen_type_node);
1196
1197 strcpy (&name[1], f->sym->name);
1198 name[0] = '_';
1199 length = build_decl (PARM_DECL, get_identifier (name), type);
1200
1201 arglist = chainon (arglist, length);
1202 DECL_CONTEXT (length) = fndecl;
1203 DECL_ARG_TYPE (length) = type;
1204 TREE_READONLY (length) = 1;
1205 gfc_finish_decl (length, NULL_TREE);
1206
1207 /* TODO: Check string lengths when -fbounds-check. */
1208
1209 /* Use the passed value for assumed length variables. */
1210 if (!f->sym->ts.cl->length)
1211 {
1212 TREE_USED (length) = 1;
1213 f->sym->ts.cl->backend_decl = length;
1214 }
1215
1216 parm = TREE_CHAIN (parm);
1217 typelist = TREE_CHAIN (typelist);
1218 }
1219
1220 assert (TREE_VALUE (typelist) == void_type_node);
1221 DECL_ARGUMENTS (fndecl) = arglist;
1222
1223 /* Restore the old context. */
1224 current_function_decl = DECL_CONTEXT (fndecl);
1225 }
1226 sym->backend_decl = fndecl;
1227}
1228
1229
1230/* Return the decl used to hold the function return value. */
1231
1232tree
1233gfc_get_fake_result_decl (gfc_symbol * sym)
1234{
1235 tree decl;
1236 tree length;
1237
1238 char name[GFC_MAX_SYMBOL_LEN + 10];
1239
1240 if (current_fake_result_decl != NULL_TREE)
1241 return current_fake_result_decl;
1242
1243 /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
1244 sym is NULL. */
1245 if (!sym)
1246 return NULL_TREE;
1247
1248 if (sym->ts.type == BT_CHARACTER
1249 && !sym->ts.cl->backend_decl)
1250 {
1251 length = gfc_create_string_length (sym);
1252 gfc_finish_var_decl (length, sym);
1253 }
1254
1255 if (gfc_return_by_reference (sym))
1256 {
1257 decl = DECL_ARGUMENTS (sym->backend_decl);
1258
1259 TREE_USED (decl) = 1;
1260 if (sym->as)
1261 decl = gfc_build_dummy_array_decl (sym, decl);
1262 }
1263 else
1264 {
1265 sprintf (name, "__result_%.20s",
1266 IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
1267
1268 decl = build_decl (VAR_DECL, get_identifier (name),
1269 TREE_TYPE (TREE_TYPE (current_function_decl)));
1270
1271 DECL_ARTIFICIAL (decl) = 1;
1272 DECL_EXTERNAL (decl) = 0;
1273 TREE_PUBLIC (decl) = 0;
1274 TREE_USED (decl) = 1;
1275
1276 layout_decl (decl, 0);
1277
1278 gfc_add_decl_to_function (decl);
1279 }
1280
1281 current_fake_result_decl = decl;
1282
1283 return decl;
1284}
1285
1286
1287/* Builds a function decl. The remaining parameters are the types of the
1288 function arguments. Negative nargs indicates a varargs function. */
1289
1290tree
1291gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
1292{
1293 tree arglist;
1294 tree argtype;
1295 tree fntype;
1296 tree fndecl;
1297 va_list p;
1298 int n;
1299
1300 /* Library functions must be declared with global scope. */
1301 assert (current_function_decl == NULL_TREE);
1302
1303 va_start (p, nargs);
1304
1305
1306 /* Create a list of the argument types. */
1307 for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
1308 {
1309 argtype = va_arg (p, tree);
1310 arglist = gfc_chainon_list (arglist, argtype);
1311 }
1312
1313 if (nargs >= 0)
1314 {
1315 /* Terminate the list. */
1316 arglist = gfc_chainon_list (arglist, void_type_node);
1317 }
1318
1319 /* Build the function type and decl. */
1320 fntype = build_function_type (rettype, arglist);
1321 fndecl = build_decl (FUNCTION_DECL, name, fntype);
1322
1323 /* Mark this decl as external. */
1324 DECL_EXTERNAL (fndecl) = 1;
1325 TREE_PUBLIC (fndecl) = 1;
1326
1327 va_end (p);
1328
1329 pushdecl (fndecl);
1330
1331 rest_of_decl_compilation (fndecl, NULL, 1, 0);
1332
1333 return fndecl;
1334}
1335
1336static void
1337gfc_build_intrinsic_function_decls (void)
1338{
1339 /* String functions. */
1340 gfor_fndecl_copy_string =
1341 gfc_build_library_function_decl (get_identifier (PREFIX("copy_string")),
1342 void_type_node,
1343 4,
1344 gfc_strlen_type_node, pchar_type_node,
1345 gfc_strlen_type_node, pchar_type_node);
1346
1347 gfor_fndecl_compare_string =
1348 gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),
1349 gfc_int4_type_node,
1350 4,
1351 gfc_strlen_type_node, pchar_type_node,
1352 gfc_strlen_type_node, pchar_type_node);
1353
1354 gfor_fndecl_concat_string =
1355 gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),
1356 void_type_node,
1357 6,
1358 gfc_strlen_type_node, pchar_type_node,
1359 gfc_strlen_type_node, pchar_type_node,
1360 gfc_strlen_type_node, pchar_type_node);
1361
1362 gfor_fndecl_string_len_trim =
1363 gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")),
1364 gfc_int4_type_node,
1365 2, gfc_strlen_type_node,
1366 pchar_type_node);
1367
1368 gfor_fndecl_string_index =
1369 gfc_build_library_function_decl (get_identifier (PREFIX("string_index")),
1370 gfc_int4_type_node,
1371 5, gfc_strlen_type_node, pchar_type_node,
1372 gfc_strlen_type_node, pchar_type_node,
1373 gfc_logical4_type_node);
1374
1375 gfor_fndecl_string_scan =
1376 gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")),
1377 gfc_int4_type_node,
1378 5, gfc_strlen_type_node, pchar_type_node,
1379 gfc_strlen_type_node, pchar_type_node,
1380 gfc_logical4_type_node);
1381
1382 gfor_fndecl_string_verify =
1383 gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")),
1384 gfc_int4_type_node,
1385 5, gfc_strlen_type_node, pchar_type_node,
1386 gfc_strlen_type_node, pchar_type_node,
1387 gfc_logical4_type_node);
1388
1389 gfor_fndecl_string_trim =
1390 gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),
1391 void_type_node,
1392 4,
1393 build_pointer_type (gfc_strlen_type_node),
1394 ppvoid_type_node,
1395 gfc_strlen_type_node,
1396 pchar_type_node);
1397
1398 gfor_fndecl_string_repeat =
1399 gfc_build_library_function_decl (get_identifier (PREFIX("string_repeat")),
1400 void_type_node,
1401 4,
1402 pchar_type_node,
1403 gfc_strlen_type_node,
1404 pchar_type_node,
1405 gfc_int4_type_node);
1406
1407 gfor_fndecl_adjustl =
1408 gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),
1409 void_type_node,
1410 3,
1411 pchar_type_node,
1412 gfc_strlen_type_node, pchar_type_node);
1413
1414 gfor_fndecl_adjustr =
1415 gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")),
1416 void_type_node,
1417 3,
1418 pchar_type_node,
1419 gfc_strlen_type_node, pchar_type_node);
1420
1421 gfor_fndecl_si_kind =
1422 gfc_build_library_function_decl (get_identifier ("selected_int_kind"),
1423 gfc_int4_type_node,
1424 1,
1425 pvoid_type_node);
1426
1427 gfor_fndecl_sr_kind =
1428 gfc_build_library_function_decl (get_identifier ("selected_real_kind"),
1429 gfc_int4_type_node,
1430 2, pvoid_type_node,
1431 pvoid_type_node);
1432
1433
1434 /* Power functions. */
76834664 1435 {
1436 tree type;
1437 tree itype;
1438 int kind;
1439 int ikind;
1440 static int kinds[2] = {4, 8};
1441 char name[PREFIX_LEN + 10]; /* _gfortran_pow_?n_?n */
1442
1443 for (ikind=0; ikind < 2; ikind++)
1444 {
1445 itype = gfc_get_int_type (kinds[ikind]);
1446 for (kind = 0; kind < 2; kind ++)
1447 {
1448 type = gfc_get_int_type (kinds[kind]);
1449 sprintf(name, PREFIX("pow_i%d_i%d"), kinds[kind], kinds[ikind]);
1450 gfor_fndecl_math_powi[kind][ikind].integer =
1451 gfc_build_library_function_decl (get_identifier (name),
1452 type, 2, type, itype);
1453
1454 type = gfc_get_real_type (kinds[kind]);
1455 sprintf(name, PREFIX("pow_r%d_i%d"), kinds[kind], kinds[ikind]);
1456 gfor_fndecl_math_powi[kind][ikind].real =
1457 gfc_build_library_function_decl (get_identifier (name),
1458 type, 2, type, itype);
1459
1460 type = gfc_get_complex_type (kinds[kind]);
1461 sprintf(name, PREFIX("pow_c%d_i%d"), kinds[kind], kinds[ikind]);
1462 gfor_fndecl_math_powi[kind][ikind].cmplx =
1463 gfc_build_library_function_decl (get_identifier (name),
1464 type, 2, type, itype);
1465 }
1466 }
1467 }
1468
4ee9c684 1469 gfor_fndecl_math_cpowf =
1470 gfc_build_library_function_decl (get_identifier ("cpowf"),
1471 gfc_complex4_type_node,
1472 1, gfc_complex4_type_node);
1473 gfor_fndecl_math_cpow =
1474 gfc_build_library_function_decl (get_identifier ("cpow"),
1475 gfc_complex8_type_node,
1476 1, gfc_complex8_type_node);
1477 gfor_fndecl_math_cabsf =
1478 gfc_build_library_function_decl (get_identifier ("cabsf"),
1479 gfc_real4_type_node,
1480 1, gfc_complex4_type_node);
1481 gfor_fndecl_math_cabs =
1482 gfc_build_library_function_decl (get_identifier ("cabs"),
1483 gfc_real8_type_node,
1484 1, gfc_complex8_type_node);
1485 gfor_fndecl_math_sign4 =
1486 gfc_build_library_function_decl (get_identifier ("copysignf"),
1487 gfc_real4_type_node,
1488 1, gfc_real4_type_node);
1489 gfor_fndecl_math_sign8 =
1490 gfc_build_library_function_decl (get_identifier ("copysign"),
1491 gfc_real8_type_node,
1492 1, gfc_real8_type_node);
1493 gfor_fndecl_math_ishftc4 =
1494 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")),
1495 gfc_int4_type_node,
1496 3, gfc_int4_type_node,
1497 gfc_int4_type_node, gfc_int4_type_node);
1498 gfor_fndecl_math_ishftc8 =
1499 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")),
1500 gfc_int8_type_node,
1501 3, gfc_int8_type_node,
1502 gfc_int8_type_node, gfc_int8_type_node);
1503 gfor_fndecl_math_exponent4 =
1504 gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r4")),
1505 gfc_int4_type_node,
1506 1, gfc_real4_type_node);
1507 gfor_fndecl_math_exponent8 =
1508 gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r8")),
1509 gfc_int4_type_node,
1510 1, gfc_real8_type_node);
1511
1512 /* Other functions. */
1513 gfor_fndecl_size0 =
1514 gfc_build_library_function_decl (get_identifier (PREFIX("size0")),
1515 gfc_array_index_type,
1516 1, pvoid_type_node);
1517 gfor_fndecl_size1 =
1518 gfc_build_library_function_decl (get_identifier (PREFIX("size1")),
1519 gfc_array_index_type,
1520 2, pvoid_type_node,
1521 gfc_array_index_type);
9b057c29 1522
1523 gfor_fndecl_iargc =
1524 gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),
1525 gfc_int4_type_node,
1526 0);
4ee9c684 1527}
1528
1529
1530/* Make prototypes for runtime library functions. */
1531
1532void
1533gfc_build_builtin_function_decls (void)
1534{
1535 gfor_fndecl_internal_malloc =
1536 gfc_build_library_function_decl (get_identifier (PREFIX("internal_malloc")),
1537 pvoid_type_node, 1, gfc_int4_type_node);
1538
1539 gfor_fndecl_internal_malloc64 =
1540 gfc_build_library_function_decl (get_identifier
1541 (PREFIX("internal_malloc64")),
1542 pvoid_type_node, 1, gfc_int8_type_node);
1543
1544 gfor_fndecl_internal_free =
1545 gfc_build_library_function_decl (get_identifier (PREFIX("internal_free")),
1546 void_type_node, 1, pvoid_type_node);
1547
1548 gfor_fndecl_allocate =
1549 gfc_build_library_function_decl (get_identifier (PREFIX("allocate")),
1550 void_type_node, 2, ppvoid_type_node,
1551 gfc_int4_type_node);
1552
1553 gfor_fndecl_allocate64 =
1554 gfc_build_library_function_decl (get_identifier (PREFIX("allocate64")),
1555 void_type_node, 2, ppvoid_type_node,
1556 gfc_int8_type_node);
1557
1558 gfor_fndecl_deallocate =
1559 gfc_build_library_function_decl (get_identifier (PREFIX("deallocate")),
1560 void_type_node, 1, ppvoid_type_node);
1561
1562 gfor_fndecl_stop_numeric =
1563 gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
1564 void_type_node, 1, gfc_int4_type_node);
1565
1566 gfor_fndecl_stop_string =
1567 gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),
1568 void_type_node, 2, pchar_type_node,
1569 gfc_int4_type_node);
1570
1571 gfor_fndecl_pause_numeric =
1572 gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
1573 void_type_node, 1, gfc_int4_type_node);
1574
1575 gfor_fndecl_pause_string =
1576 gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")),
1577 void_type_node, 2, pchar_type_node,
1578 gfc_int4_type_node);
1579
1580 gfor_fndecl_select_string =
1581 gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
1582 pvoid_type_node, 0);
1583
1584 gfor_fndecl_runtime_error =
1585 gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
1586 void_type_node,
1587 3,
1588 pchar_type_node, pchar_type_node,
1589 gfc_int4_type_node);
1590
1591 gfor_fndecl_in_pack = gfc_build_library_function_decl (
1592 get_identifier (PREFIX("internal_pack")),
1593 pvoid_type_node, 1, pvoid_type_node);
1594
1595 gfor_fndecl_in_unpack = gfc_build_library_function_decl (
1596 get_identifier (PREFIX("internal_unpack")),
1597 pvoid_type_node, 1, pvoid_type_node);
1598
1599 gfor_fndecl_associated =
1600 gfc_build_library_function_decl (
1601 get_identifier (PREFIX("associated")),
1602 gfc_logical4_type_node,
1603 2,
1604 ppvoid_type_node,
1605 ppvoid_type_node);
1606
1607 gfc_build_intrinsic_function_decls ();
1608 gfc_build_intrinsic_lib_fndecls ();
1609 gfc_build_io_library_fndecls ();
1610}
1611
1612
1613/* Exaluate the length of dummy character variables. */
1614
1615static tree
1616gfc_trans_dummy_character (gfc_charlen * cl, tree fnbody)
1617{
1618 stmtblock_t body;
1619
1620 gfc_finish_decl (cl->backend_decl, NULL_TREE);
1621
1622 gfc_start_block (&body);
1623
1624 /* Evaluate the string length expression. */
1625 gfc_trans_init_string_length (cl, &body);
1626
1627 gfc_add_expr_to_block (&body, fnbody);
1628 return gfc_finish_block (&body);
1629}
1630
1631
1632/* Allocate and cleanup an automatic character variable. */
1633
1634static tree
1635gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
1636{
1637 stmtblock_t body;
1638 tree decl;
1639 tree args;
1640 tree tmp;
1641
1642 assert (sym->backend_decl);
1643 assert (sym->ts.cl && sym->ts.cl->length);
1644
1645 gfc_start_block (&body);
1646
1647 /* Evaluate the string length expression. */
1648 gfc_trans_init_string_length (sym->ts.cl, &body);
1649
1650 decl = sym->backend_decl;
1651
1652 DECL_DEFER_OUTPUT (decl) = 1;
1653
6374121b 1654 /* Since we don't use a DECL_STMT or equivalent, we have to deal
1655 with getting these gimplified. But we can't gimplify it yet since
1656 we're still generating statements.
1657
1658 ??? This should be cleaned up and handled like other front ends. */
1659 gfc_add_expr_to_block (&body, save_expr (DECL_SIZE (decl)));
1660 gfc_add_expr_to_block (&body, save_expr (DECL_SIZE_UNIT (decl)));
1661
4ee9c684 1662 /* Generate code to allocate the automatic variable. It will be freed
1663 automatically. */
1664 tmp = gfc_build_addr_expr (NULL, decl);
1665 args = gfc_chainon_list (NULL_TREE, tmp);
1666 args = gfc_chainon_list (args, sym->ts.cl->backend_decl);
1667 tmp = gfc_build_function_call (built_in_decls[BUILT_IN_STACK_ALLOC], args);
1668 gfc_add_expr_to_block (&body, tmp);
1669 gfc_add_expr_to_block (&body, fnbody);
1670 return gfc_finish_block (&body);
1671}
1672
1673
1674/* Generate function entry and exit code, and add it to the function body.
1675 This includes:
1676 Allocation and initialisation of array variables.
1677 Allocation of character string variables.
1678 Initialization and possibly repacking of dummy arrays. */
1679
1680static tree
1681gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
1682{
1683 locus loc;
1684 gfc_symbol *sym;
1685
1686 /* Deal with implicit return variables. Explicit return variables will
1687 already have been added. */
1688 if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
1689 {
1690 if (!current_fake_result_decl)
1691 {
1692 warning ("Function does not return a value");
1693 return fnbody;
1694 }
1695
1696 if (proc_sym->as)
1697 {
1698 fnbody = gfc_trans_dummy_array_bias (proc_sym,
1699 current_fake_result_decl,
1700 fnbody);
1701 }
1702 else if (proc_sym->ts.type == BT_CHARACTER)
1703 {
1704 if (TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
1705 fnbody = gfc_trans_dummy_character (proc_sym->ts.cl, fnbody);
1706 }
1707 else
1708 gfc_todo_error ("Deferred non-array return by reference");
1709 }
1710
1711 for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
1712 {
1713 if (sym->attr.dimension)
1714 {
1715 switch (sym->as->type)
1716 {
1717 case AS_EXPLICIT:
1718 if (sym->attr.dummy || sym->attr.result)
1719 fnbody =
1720 gfc_trans_dummy_array_bias (sym, sym->backend_decl, fnbody);
1721 else if (sym->attr.pointer || sym->attr.allocatable)
1722 {
1723 if (TREE_STATIC (sym->backend_decl))
1724 gfc_trans_static_array_pointer (sym);
1725 else
1726 fnbody = gfc_trans_deferred_array (sym, fnbody);
1727 }
1728 else
1729 {
1730 gfc_get_backend_locus (&loc);
1731 gfc_set_backend_locus (&sym->declared_at);
1732 fnbody = gfc_trans_auto_array_allocation (sym->backend_decl,
1733 sym, fnbody);
1734 gfc_set_backend_locus (&loc);
1735 }
1736 break;
1737
1738 case AS_ASSUMED_SIZE:
1739 /* Must be a dummy parameter. */
1740 assert (sym->attr.dummy);
1741
1742 /* We should always pass assumed size arrays the g77 way. */
1743 assert (TREE_CODE (sym->backend_decl) == PARM_DECL);
1744 fnbody = gfc_trans_g77_array (sym, fnbody);
1745 break;
1746
1747 case AS_ASSUMED_SHAPE:
1748 /* Must be a dummy parameter. */
1749 assert (sym->attr.dummy);
1750
1751 fnbody = gfc_trans_dummy_array_bias (sym, sym->backend_decl,
1752 fnbody);
1753 break;
1754
1755 case AS_DEFERRED:
1756 fnbody = gfc_trans_deferred_array (sym, fnbody);
1757 break;
1758
1759 default:
1760 abort ();
1761 }
1762 }
1763 else if (sym->ts.type == BT_CHARACTER)
1764 {
1765 gfc_get_backend_locus (&loc);
1766 gfc_set_backend_locus (&sym->declared_at);
1767 if (sym->attr.dummy || sym->attr.result)
1768 fnbody = gfc_trans_dummy_character (sym->ts.cl, fnbody);
1769 else
1770 fnbody = gfc_trans_auto_character_variable (sym, fnbody);
1771 gfc_set_backend_locus (&loc);
1772 }
1773 else
1774 abort ();
1775 }
1776
1777 return fnbody;
1778}
1779
1780
1781/* Output an initialized decl for a module variable. */
1782
1783static void
1784gfc_create_module_variable (gfc_symbol * sym)
1785{
1786 tree decl;
1787 gfc_se se;
1788
1789 /* Only output symbols from this module. */
1790 if (sym->ns != module_namespace)
1791 {
1792 /* I don't think this should ever happen. */
1793 internal_error ("module symbol %s in wrong namespace", sym->name);
1794 }
1795
4ee9c684 1796 /* Only output variables and array valued parametes. */
1797 if (sym->attr.flavor != FL_VARIABLE
1798 && (sym->attr.flavor != FL_PARAMETER || sym->attr.dimension == 0))
1799 return;
1800
1801 /* Don't generate variables from other modules. */
1802 if (sym->attr.use_assoc)
1803 return;
1804
1805 if (sym->backend_decl)
1806 internal_error ("backend decl for module variable %s already exists",
1807 sym->name);
1808
1809 /* We always want module variables to be created. */
1810 sym->attr.referenced = 1;
1811 /* Create the decl. */
1812 decl = gfc_get_symbol_decl (sym);
1813
1814 /* We want to allocate storage for this variable. */
1815 TREE_STATIC (decl) = 1;
1816
1817 if (sym->attr.dimension)
1818 {
1819 assert (sym->attr.pointer || sym->attr.allocatable
1820 || GFC_ARRAY_TYPE_P (TREE_TYPE (sym->backend_decl)));
1821 if (sym->attr.pointer || sym->attr.allocatable)
1822 gfc_trans_static_array_pointer (sym);
1823 else
1824 gfc_trans_auto_array_allocation (sym->backend_decl, sym, NULL_TREE);
1825 }
1826 else if (sym->ts.type == BT_DERIVED)
1827 {
1828 if (sym->value)
1829 gfc_todo_error ("Initialization of derived type module variables");
1830 }
1831 else
1832 {
1833 if (sym->value)
1834 {
1835 gfc_init_se (&se, NULL);
1836 gfc_conv_constant (&se, sym->value);
1837 DECL_INITIAL (decl) = se.expr;
1838 }
1839 }
1840
1841 /* Create the variable. */
1842 pushdecl (decl);
1843 rest_of_decl_compilation (decl, NULL, 1, 0);
1844
1845 /* Also add length of strings. */
1846 if (sym->ts.type == BT_CHARACTER)
1847 {
1848 tree length;
1849
1850 length = sym->ts.cl->backend_decl;
1851 if (!INTEGER_CST_P (length))
1852 {
1853 pushdecl (length);
1854 rest_of_decl_compilation (length, NULL, 1, 0);
1855 }
1856 }
1857}
1858
1859
1860/* Generate all the required code for module variables. */
1861
1862void
1863gfc_generate_module_vars (gfc_namespace * ns)
1864{
1865 module_namespace = ns;
1866
dfc222eb 1867 /* Check if the frontend left the namespace in a reasonable state. */
4ee9c684 1868 assert (ns->proc_name && !ns->proc_name->tlink);
1869
dfc222eb 1870 /* Create decls for all the module variables. */
4ee9c684 1871 gfc_traverse_ns (ns, gfc_create_module_variable);
1872}
1873
1874static void
1875gfc_generate_contained_functions (gfc_namespace * parent)
1876{
1877 gfc_namespace *ns;
1878
1879 /* We create all the prototypes before generating any code. */
1880 for (ns = parent->contained; ns; ns = ns->sibling)
1881 {
1882 /* Skip namespaces from used modules. */
1883 if (ns->parent != parent)
1884 continue;
1885
1886 gfc_build_function_decl (ns->proc_name);
1887 }
1888
1889 for (ns = parent->contained; ns; ns = ns->sibling)
1890 {
1891 /* Skip namespaces from used modules. */
1892 if (ns->parent != parent)
1893 continue;
1894
1895 gfc_generate_function_code (ns);
1896 }
1897}
1898
1899
1900/* Generate decls for all local variables. We do this to ensure correct
1901 handling of expressions which only appear in the specification of
1902 other functions. */
1903
1904static void
1905generate_local_decl (gfc_symbol * sym)
1906{
1907 if (sym->attr.flavor == FL_VARIABLE)
1908 {
4ee9c684 1909 if (sym->attr.referenced)
1910 gfc_get_symbol_decl (sym);
1911 else if (sym->attr.dummy)
1912 {
1913 if (warn_unused_parameter)
1914 warning ("unused parameter `%s'", sym->name);
1915 }
ae93fbc6 1916 /* warn for unused variables, but not if they're inside a common
36609028 1917 block or are use_associated. */
1918 else if (warn_unused_variable
1919 && !(sym->attr.in_common || sym->attr.use_assoc))
1920 warning ("unused variable `%s'", sym->name);
4ee9c684 1921 }
1922}
1923
1924static void
1925generate_local_vars (gfc_namespace * ns)
1926{
1927 gfc_traverse_ns (ns, generate_local_decl);
1928}
1929
1930
1931/* Finalize DECL and all nested functions with cgraph. */
1932
1933static void
1934gfc_finalize (tree decl)
1935{
1936 struct cgraph_node *cgn;
1937
1938 cgn = cgraph_node (decl);
1939 for (cgn = cgn->nested; cgn ; cgn = cgn->next_nested)
1940 gfc_finalize (cgn->decl);
1941
1942 cgraph_finalize_function (decl, false);
1943}
1944
6374121b 1945/* Convert FNDECL's code to GIMPLE and handle any nested functions. */
1946
1947static void
1948gfc_gimplify_function (tree fndecl)
1949{
1950 struct cgraph_node *cgn;
1951
1952 gimplify_function_tree (fndecl);
1953 dump_function (TDI_generic, fndecl);
1954
1955 /* Convert all nested functions to GIMPLE now. We do things in this order
1956 so that items like VLA sizes are expanded properly in the context of the
1957 correct function. */
1958 cgn = cgraph_node (fndecl);
1959 for (cgn = cgn->nested; cgn; cgn = cgn->next_nested)
1960 gfc_gimplify_function (cgn->decl);
1961}
1962
4ee9c684 1963/* Generate code for a function. */
1964
1965void
1966gfc_generate_function_code (gfc_namespace * ns)
1967{
1968 tree fndecl;
1969 tree old_context;
1970 tree decl;
1971 tree tmp;
1972 stmtblock_t block;
1973 stmtblock_t body;
1974 tree result;
1975 gfc_symbol *sym;
1976
1977 sym = ns->proc_name;
1978 /* Check that the frontend isn't still using this. */
1979 assert (sym->tlink == NULL);
1980
1981 sym->tlink = sym;
1982
1983 /* Create the declaration for functions with global scope. */
1984 if (!sym->backend_decl)
1985 gfc_build_function_decl (ns->proc_name);
1986
1987 fndecl = sym->backend_decl;
1988 old_context = current_function_decl;
1989
1990 if (old_context)
1991 {
1992 push_function_context ();
1993 saved_parent_function_decls = saved_function_decls;
1994 saved_function_decls = NULL_TREE;
1995 }
1996
1997 /* let GCC know the current scope is this function */
1998 current_function_decl = fndecl;
1999
2000 /* print function name on the console at compile time
2001 (unless this feature was switched of by command line option "-quiet" */
2002 announce_function (fndecl);
2003
2004 if (DECL_CONTEXT (fndecl) == NULL_TREE)
2005 {
2006 /* create RTL for function declaration */
2007 rest_of_decl_compilation (fndecl, NULL, 1, 0);
2008 }
2009
2010 /* create RTL for function definition */
2011 make_decl_rtl (fndecl, NULL);
2012
2013 /* Set the line and filename. sym->decalred_at seems to point to the last
2014 statement for subroutines, but it'll do for now. */
2015 gfc_set_backend_locus (&sym->declared_at);
2016
2017 /* line and file should not be 0 */
2018 init_function_start (fndecl);
2019
4ee9c684 2020 /* Even though we're inside a function body, we still don't want to
2021 call expand_expr to calculate the size of a variable-sized array.
2022 We haven't necessarily assigned RTL to all variables yet, so it's
2023 not safe to try to expand expressions involving them. */
4ee9c684 2024 cfun->x_dont_save_pending_sizes_p = 1;
2025
2026 /* Will be created as needed. */
2027 current_fake_result_decl = NULL_TREE;
2028
2029 /* function.c requires a push at the start of the function */
2030 pushlevel (0);
2031
2032 gfc_start_block (&block);
2033
2034 gfc_generate_contained_functions (ns);
2035
2036 /* Translate COMMON blocks. */
2037 gfc_trans_common (ns);
2038
2039 generate_local_vars (ns);
2040
2041 current_function_return_label = NULL;
2042
2043 /* Now generate the code for the body of this function. */
2044 gfc_init_block (&body);
2045
2046 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
2047 && sym->attr.subroutine)
2048 {
2049 tree alternate_return;
2050 alternate_return = gfc_get_fake_result_decl (sym);
2051 gfc_add_modify_expr (&body, alternate_return, integer_zero_node);
2052 }
2053
2054 tmp = gfc_trans_code (ns->code);
2055 gfc_add_expr_to_block (&body, tmp);
2056
2057 /* Add a return label if needed. */
2058 if (current_function_return_label)
2059 {
2060 tmp = build1_v (LABEL_EXPR, current_function_return_label);
2061 gfc_add_expr_to_block (&body, tmp);
2062 }
2063
2064 tmp = gfc_finish_block (&body);
2065 /* Add code to create and cleanup arrays. */
2066 tmp = gfc_trans_deferred_vars (sym, tmp);
2067 gfc_add_expr_to_block (&block, tmp);
2068
2069 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
2070 {
2071 if (sym->attr.subroutine ||sym == sym->result)
2072 {
2073 result = current_fake_result_decl;
2074 current_fake_result_decl = NULL_TREE;
2075 }
2076 else
2077 result = sym->result->backend_decl;
2078
2079 if (result == NULL_TREE)
2080 warning ("Function return value not set");
2081 else
2082 {
2083 /* Set the return value to the the dummy result variable. */
2084 tmp = build (MODIFY_EXPR, TREE_TYPE (result),
2085 DECL_RESULT (fndecl), result);
2086 tmp = build_v (RETURN_EXPR, tmp);
2087 gfc_add_expr_to_block (&block, tmp);
2088 }
2089 }
2090
2091 /* Add all the decls we created during processing. */
2092 decl = saved_function_decls;
2093 while (decl)
2094 {
2095 tree next;
2096
2097 next = TREE_CHAIN (decl);
2098 TREE_CHAIN (decl) = NULL_TREE;
2099 pushdecl (decl);
2100 decl = next;
2101 }
2102 saved_function_decls = NULL_TREE;
2103
2104 DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);
2105
2106 /* Finish off this function and send it for code generation. */
2107 poplevel (1, 0, 1);
2108 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
2109
2110 /* Output the GENERIC tree. */
2111 dump_function (TDI_original, fndecl);
2112
2113 /* Store the end of the function, so that we get good line number
2114 info for the epilogue. */
2115 cfun->function_end_locus = input_location;
2116
2117 /* We're leaving the context of this function, so zap cfun.
2118 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
2119 tree_rest_of_compilation. */
2120 cfun = NULL;
2121
2122 if (old_context)
2123 {
2124 pop_function_context ();
2125 saved_function_decls = saved_parent_function_decls;
2126 }
2127 current_function_decl = old_context;
2128
2129 if (decl_function_context (fndecl))
6374121b 2130 /* Register this function with cgraph just far enough to get it
2131 added to our parent's nested function list. */
2132 (void) cgraph_node (fndecl);
4ee9c684 2133 else
2134 {
6374121b 2135 gfc_gimplify_function (fndecl);
2136 lower_nested_functions (fndecl);
4ee9c684 2137 gfc_finalize (fndecl);
2138 }
2139}
2140
4ee9c684 2141void
2142gfc_generate_constructors (void)
2143{
2144 if (gfc_static_ctors != NULL_TREE)
2145 abort ();
2146#if 0
2147 tree fnname;
2148 tree type;
2149 tree fndecl;
2150 tree decl;
2151 tree tmp;
2152
2153 if (gfc_static_ctors == NULL_TREE)
2154 return;
2155
2156 fnname = get_file_function_name ('I');
2157 type = build_function_type (void_type_node,
2158 gfc_chainon_list (NULL_TREE, void_type_node));
2159
2160 fndecl = build_decl (FUNCTION_DECL, fnname, type);
2161 TREE_PUBLIC (fndecl) = 1;
2162
2163 decl = build_decl (RESULT_DECL, NULL_TREE, void_type_node);
2164 DECL_CONTEXT (decl) = fndecl;
2165 DECL_RESULT (fndecl) = decl;
2166
2167 pushdecl (fndecl);
2168
2169 current_function_decl = fndecl;
2170
2171 rest_of_decl_compilation (fndecl, NULL, 1, 0);
2172
2173 make_decl_rtl (fndecl, NULL);
2174
2175 init_function_start (fndecl, input_filename, input_line);
2176
4ee9c684 2177 pushlevel (0);
2178
2179 for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
2180 {
2181 tmp =
2182 gfc_build_function_call (TREE_VALUE (gfc_static_ctors), NULL_TREE);
2183 DECL_SAVED_TREE (fndecl) = build_stmt (EXPR_STMT, tmp);
2184 }
2185
2186 poplevel (1, 0, 1);
2187
2188 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
2189
2190 free_after_parsing (cfun);
2191 free_after_compilation (cfun);
2192
2193 tree_rest_of_compilation (fndecl, 0);
2194
2195 current_function_decl = NULL_TREE;
2196#endif
2197}
2198
2199#include "gt-fortran-trans-decl.h"
Mirror of https://gcc.gnu.org/git/gcc.git