]> 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
Daily bump.
[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
96tree gfor_fndecl_math_powf;
97tree gfor_fndecl_math_pow;
98tree gfor_fndecl_math_cpowf;
99tree gfor_fndecl_math_cpow;
100tree gfor_fndecl_math_cabsf;
101tree gfor_fndecl_math_cabs;
102tree gfor_fndecl_math_sign4;
103tree gfor_fndecl_math_sign8;
104tree gfor_fndecl_math_ishftc4;
105tree gfor_fndecl_math_ishftc8;
106tree gfor_fndecl_math_exponent4;
107tree gfor_fndecl_math_exponent8;
108
109
110/* String functions. */
111
112tree gfor_fndecl_copy_string;
113tree gfor_fndecl_compare_string;
114tree gfor_fndecl_concat_string;
115tree gfor_fndecl_string_len_trim;
116tree gfor_fndecl_string_index;
117tree gfor_fndecl_string_scan;
118tree gfor_fndecl_string_verify;
119tree gfor_fndecl_string_trim;
120tree gfor_fndecl_string_repeat;
121tree gfor_fndecl_adjustl;
122tree gfor_fndecl_adjustr;
123
124
125/* Other misc. runtime library functions. */
126
127tree gfor_fndecl_size0;
128tree gfor_fndecl_size1;
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
870/* Get a basic decl for an external function. */
871
872tree
873gfc_get_extern_function_decl (gfc_symbol * sym)
874{
875 tree type;
876 tree fndecl;
877 gfc_expr e;
878 gfc_intrinsic_sym *isym;
879 gfc_expr argexpr;
880 char s[GFC_MAX_SYMBOL_LEN];
881 tree name;
882 tree mangled_name;
883
884 if (sym->backend_decl)
885 return sym->backend_decl;
886
887 if (sym->attr.intrinsic)
888 {
889 /* Call the resolution function to get the actual name. This is
890 a nasty hack which relies on the resolution functions only looking
891 at the first argument. We pass NULL for the second argument
892 otherwise things like AINT get confused. */
893 isym = gfc_find_function (sym->name);
894 assert (isym->resolve.f0 != NULL);
895
896 memset (&e, 0, sizeof (e));
897 e.expr_type = EXPR_FUNCTION;
898
899 memset (&argexpr, 0, sizeof (argexpr));
900 assert (isym->formal);
901 argexpr.ts = isym->formal->ts;
902
903 if (isym->formal->next == NULL)
904 isym->resolve.f1 (&e, &argexpr);
905 else
906 {
907 /* All specific intrinsics take one or two arguments. */
908 assert (isym->formal->next->next == NULL);
909 isym->resolve.f2 (&e, &argexpr, NULL);
910 }
911 sprintf (s, "specific%s", e.value.function.name);
912 name = get_identifier (s);
913 mangled_name = name;
914 }
915 else
916 {
917 name = gfc_sym_identifier (sym);
918 mangled_name = gfc_sym_mangled_function_id (sym);
919 }
920
921 type = gfc_get_function_type (sym);
922 fndecl = build_decl (FUNCTION_DECL, name, type);
923
924 SET_DECL_ASSEMBLER_NAME (fndecl, mangled_name);
925 /* If the return type is a pointer, avoid alias issues by setting
926 DECL_IS_MALLOC to nonzero. This means that the function should be
927 treated as if it were a malloc, meaning it returns a pointer that
928 is not an alias. */
929 if (POINTER_TYPE_P (type))
930 DECL_IS_MALLOC (fndecl) = 1;
931
932 /* Set the context of this decl. */
933 if (0 && sym->ns && sym->ns->proc_name)
934 {
935 /* TODO: Add external decls to the appropriate scope. */
936 DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
937 }
938 else
939 {
940 /* Global declaration, eg. intrinsic subroutine. */
941 DECL_CONTEXT (fndecl) = NULL_TREE;
942 }
943
944 DECL_EXTERNAL (fndecl) = 1;
945
946 /* This specifies if a function is globaly addressable, ie. it is
947 the opposite of declaring static in C. */
948 TREE_PUBLIC (fndecl) = 1;
949
950 /* Set attributes for PURE functions. A call to PURE function in the
951 Fortran 95 sense is both pure and without side effects in the C
952 sense. */
953 if (sym->attr.pure || sym->attr.elemental)
954 {
955 DECL_IS_PURE (fndecl) = 1;
956/* TODO: check if pure/elemental procedures can have INTENT(OUT) parameters.
957 TREE_SIDE_EFFECTS (fndecl) = 0;*/
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);
1033 DECL_CONTEXT (result_decl) = fndecl;
1034 DECL_RESULT (fndecl) = result_decl;
1035
1036 /* Don't call layout_decl for a RESULT_DECL.
1037 layout_decl (result_decl, 0); */
1038
1039 /* If the return type is a pointer, avoid alias issues by setting
1040 DECL_IS_MALLOC to nonzero. This means that the function should be
1041 treated as if it were a malloc, meaning it returns a pointer that
1042 is not an alias. */
1043 if (POINTER_TYPE_P (type))
1044 DECL_IS_MALLOC (fndecl) = 1;
1045
1046 /* Set up all attributes for the function. */
1047 DECL_CONTEXT (fndecl) = current_function_decl;
1048 DECL_EXTERNAL (fndecl) = 0;
1049
1050 /* This specifies if a function is globaly addressable, ie. it is
dfc222eb 1051 the opposite of declaring static in C. */
4ee9c684 1052 if (DECL_CONTEXT (fndecl) == NULL_TREE || attr.external)
1053 TREE_PUBLIC (fndecl) = 1;
1054
1055 /* TREE_STATIC means the function body is defined here. */
1056 if (!attr.external)
1057 TREE_STATIC (fndecl) = 1;
1058
1059 /* Set attributes for PURE functions. A call to PURE function in the
1060 Fortran 95 sense is both pure and without side effects in the C
1061 sense. */
1062 if (attr.pure || attr.elemental)
1063 {
1064 DECL_IS_PURE (fndecl) = 1;
1065 TREE_SIDE_EFFECTS (fndecl) = 0;
1066 }
1067
1068 /* Layout the function declaration and put it in the binding level
1069 of the current function. */
1070 if (!attr.external)
1071 {
1072 tree parm;
1073
1074 pushdecl (fndecl);
1075 /* Build formal argument list. Make sure that their TREE_CONTEXT is
1076 the new FUNCTION_DECL node. */
1077 current_function_decl = fndecl;
1078 arglist = NULL_TREE;
1079 typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
1080 if (gfc_return_by_reference (sym))
1081 {
1082 type = TREE_VALUE (typelist);
1083 parm = build_decl (PARM_DECL, get_identifier ("__result"), type);
1084
1085 DECL_CONTEXT (parm) = fndecl;
1086 DECL_ARG_TYPE (parm) = type;
1087 TREE_READONLY (parm) = 1;
1088 gfc_finish_decl (parm, NULL_TREE);
1089
1090 arglist = chainon (arglist, parm);
1091 typelist = TREE_CHAIN (typelist);
1092
1093 if (sym->ts.type == BT_CHARACTER)
1094 {
1095 gfc_allocate_lang_decl (parm);
1096
dfc222eb 1097 /* Length of character result. */
4ee9c684 1098 type = TREE_VALUE (typelist);
1099 assert (type == gfc_strlen_type_node);
1100
1101 length = build_decl (PARM_DECL,
1102 get_identifier (".__result"),
1103 type);
1104 if (!sym->ts.cl->length)
1105 {
1106 sym->ts.cl->backend_decl = length;
1107 TREE_USED (length) = 1;
1108 }
1109 assert (TREE_CODE (length) == PARM_DECL);
1110 arglist = chainon (arglist, length);
1111 typelist = TREE_CHAIN (typelist);
1112 DECL_CONTEXT (length) = fndecl;
1113 DECL_ARG_TYPE (length) = type;
1114 TREE_READONLY (length) = 1;
1115 gfc_finish_decl (length, NULL_TREE);
1116 }
1117 }
1118
1119 for (f = sym->formal; f; f = f->next)
1120 {
1121 if (f->sym != NULL) /* ignore alternate returns. */
1122 {
1123 length = NULL_TREE;
1124
1125 type = TREE_VALUE (typelist);
1126
1127 /* Build a the argument declaration. */
1128 parm = build_decl (PARM_DECL,
1129 gfc_sym_identifier (f->sym), type);
1130
1131 /* Fill in arg stuff. */
1132 DECL_CONTEXT (parm) = fndecl;
1133 DECL_ARG_TYPE (parm) = type;
1134 DECL_ARG_TYPE_AS_WRITTEN (parm) = type;
1135 /* All implementation args are read-only. */
1136 TREE_READONLY (parm) = 1;
1137
1138 gfc_finish_decl (parm, NULL_TREE);
1139
1140 f->sym->backend_decl = parm;
1141
1142 arglist = chainon (arglist, parm);
1143 typelist = TREE_CHAIN (typelist);
1144 }
1145 }
1146
1147 /* Add the hidden string length parameters. */
1148 parm = arglist;
1149 for (f = sym->formal; f; f = f->next)
1150 {
1151 char name[GFC_MAX_SYMBOL_LEN + 2];
1152 /* Ignore alternate returns. */
1153 if (f->sym == NULL)
1154 continue;
1155
1156 if (f->sym->ts.type != BT_CHARACTER)
1157 continue;
1158
1159 parm = f->sym->backend_decl;
1160 type = TREE_VALUE (typelist);
1161 assert (type == gfc_strlen_type_node);
1162
1163 strcpy (&name[1], f->sym->name);
1164 name[0] = '_';
1165 length = build_decl (PARM_DECL, get_identifier (name), type);
1166
1167 arglist = chainon (arglist, length);
1168 DECL_CONTEXT (length) = fndecl;
1169 DECL_ARG_TYPE (length) = type;
1170 TREE_READONLY (length) = 1;
1171 gfc_finish_decl (length, NULL_TREE);
1172
1173 /* TODO: Check string lengths when -fbounds-check. */
1174
1175 /* Use the passed value for assumed length variables. */
1176 if (!f->sym->ts.cl->length)
1177 {
1178 TREE_USED (length) = 1;
1179 f->sym->ts.cl->backend_decl = length;
1180 }
1181
1182 parm = TREE_CHAIN (parm);
1183 typelist = TREE_CHAIN (typelist);
1184 }
1185
1186 assert (TREE_VALUE (typelist) == void_type_node);
1187 DECL_ARGUMENTS (fndecl) = arglist;
1188
1189 /* Restore the old context. */
1190 current_function_decl = DECL_CONTEXT (fndecl);
1191 }
1192 sym->backend_decl = fndecl;
1193}
1194
1195
1196/* Return the decl used to hold the function return value. */
1197
1198tree
1199gfc_get_fake_result_decl (gfc_symbol * sym)
1200{
1201 tree decl;
1202 tree length;
1203
1204 char name[GFC_MAX_SYMBOL_LEN + 10];
1205
1206 if (current_fake_result_decl != NULL_TREE)
1207 return current_fake_result_decl;
1208
1209 /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
1210 sym is NULL. */
1211 if (!sym)
1212 return NULL_TREE;
1213
1214 if (sym->ts.type == BT_CHARACTER
1215 && !sym->ts.cl->backend_decl)
1216 {
1217 length = gfc_create_string_length (sym);
1218 gfc_finish_var_decl (length, sym);
1219 }
1220
1221 if (gfc_return_by_reference (sym))
1222 {
1223 decl = DECL_ARGUMENTS (sym->backend_decl);
1224
1225 TREE_USED (decl) = 1;
1226 if (sym->as)
1227 decl = gfc_build_dummy_array_decl (sym, decl);
1228 }
1229 else
1230 {
1231 sprintf (name, "__result_%.20s",
1232 IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
1233
1234 decl = build_decl (VAR_DECL, get_identifier (name),
1235 TREE_TYPE (TREE_TYPE (current_function_decl)));
1236
1237 DECL_ARTIFICIAL (decl) = 1;
1238 DECL_EXTERNAL (decl) = 0;
1239 TREE_PUBLIC (decl) = 0;
1240 TREE_USED (decl) = 1;
1241
1242 layout_decl (decl, 0);
1243
1244 gfc_add_decl_to_function (decl);
1245 }
1246
1247 current_fake_result_decl = decl;
1248
1249 return decl;
1250}
1251
1252
1253/* Builds a function decl. The remaining parameters are the types of the
1254 function arguments. Negative nargs indicates a varargs function. */
1255
1256tree
1257gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
1258{
1259 tree arglist;
1260 tree argtype;
1261 tree fntype;
1262 tree fndecl;
1263 va_list p;
1264 int n;
1265
1266 /* Library functions must be declared with global scope. */
1267 assert (current_function_decl == NULL_TREE);
1268
1269 va_start (p, nargs);
1270
1271
1272 /* Create a list of the argument types. */
1273 for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
1274 {
1275 argtype = va_arg (p, tree);
1276 arglist = gfc_chainon_list (arglist, argtype);
1277 }
1278
1279 if (nargs >= 0)
1280 {
1281 /* Terminate the list. */
1282 arglist = gfc_chainon_list (arglist, void_type_node);
1283 }
1284
1285 /* Build the function type and decl. */
1286 fntype = build_function_type (rettype, arglist);
1287 fndecl = build_decl (FUNCTION_DECL, name, fntype);
1288
1289 /* Mark this decl as external. */
1290 DECL_EXTERNAL (fndecl) = 1;
1291 TREE_PUBLIC (fndecl) = 1;
1292
1293 va_end (p);
1294
1295 pushdecl (fndecl);
1296
1297 rest_of_decl_compilation (fndecl, NULL, 1, 0);
1298
1299 return fndecl;
1300}
1301
1302static void
1303gfc_build_intrinsic_function_decls (void)
1304{
1305 /* String functions. */
1306 gfor_fndecl_copy_string =
1307 gfc_build_library_function_decl (get_identifier (PREFIX("copy_string")),
1308 void_type_node,
1309 4,
1310 gfc_strlen_type_node, pchar_type_node,
1311 gfc_strlen_type_node, pchar_type_node);
1312
1313 gfor_fndecl_compare_string =
1314 gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),
1315 gfc_int4_type_node,
1316 4,
1317 gfc_strlen_type_node, pchar_type_node,
1318 gfc_strlen_type_node, pchar_type_node);
1319
1320 gfor_fndecl_concat_string =
1321 gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),
1322 void_type_node,
1323 6,
1324 gfc_strlen_type_node, pchar_type_node,
1325 gfc_strlen_type_node, pchar_type_node,
1326 gfc_strlen_type_node, pchar_type_node);
1327
1328 gfor_fndecl_string_len_trim =
1329 gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")),
1330 gfc_int4_type_node,
1331 2, gfc_strlen_type_node,
1332 pchar_type_node);
1333
1334 gfor_fndecl_string_index =
1335 gfc_build_library_function_decl (get_identifier (PREFIX("string_index")),
1336 gfc_int4_type_node,
1337 5, gfc_strlen_type_node, pchar_type_node,
1338 gfc_strlen_type_node, pchar_type_node,
1339 gfc_logical4_type_node);
1340
1341 gfor_fndecl_string_scan =
1342 gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")),
1343 gfc_int4_type_node,
1344 5, gfc_strlen_type_node, pchar_type_node,
1345 gfc_strlen_type_node, pchar_type_node,
1346 gfc_logical4_type_node);
1347
1348 gfor_fndecl_string_verify =
1349 gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")),
1350 gfc_int4_type_node,
1351 5, gfc_strlen_type_node, pchar_type_node,
1352 gfc_strlen_type_node, pchar_type_node,
1353 gfc_logical4_type_node);
1354
1355 gfor_fndecl_string_trim =
1356 gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),
1357 void_type_node,
1358 4,
1359 build_pointer_type (gfc_strlen_type_node),
1360 ppvoid_type_node,
1361 gfc_strlen_type_node,
1362 pchar_type_node);
1363
1364 gfor_fndecl_string_repeat =
1365 gfc_build_library_function_decl (get_identifier (PREFIX("string_repeat")),
1366 void_type_node,
1367 4,
1368 pchar_type_node,
1369 gfc_strlen_type_node,
1370 pchar_type_node,
1371 gfc_int4_type_node);
1372
1373 gfor_fndecl_adjustl =
1374 gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),
1375 void_type_node,
1376 3,
1377 pchar_type_node,
1378 gfc_strlen_type_node, pchar_type_node);
1379
1380 gfor_fndecl_adjustr =
1381 gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")),
1382 void_type_node,
1383 3,
1384 pchar_type_node,
1385 gfc_strlen_type_node, pchar_type_node);
1386
1387 gfor_fndecl_si_kind =
1388 gfc_build_library_function_decl (get_identifier ("selected_int_kind"),
1389 gfc_int4_type_node,
1390 1,
1391 pvoid_type_node);
1392
1393 gfor_fndecl_sr_kind =
1394 gfc_build_library_function_decl (get_identifier ("selected_real_kind"),
1395 gfc_int4_type_node,
1396 2, pvoid_type_node,
1397 pvoid_type_node);
1398
1399
1400 /* Power functions. */
1401 gfor_fndecl_math_powf =
1402 gfc_build_library_function_decl (get_identifier ("powf"),
1403 gfc_real4_type_node,
1404 1, gfc_real4_type_node);
1405 gfor_fndecl_math_pow =
1406 gfc_build_library_function_decl (get_identifier ("pow"),
1407 gfc_real8_type_node,
1408 1, gfc_real8_type_node);
1409 gfor_fndecl_math_cpowf =
1410 gfc_build_library_function_decl (get_identifier ("cpowf"),
1411 gfc_complex4_type_node,
1412 1, gfc_complex4_type_node);
1413 gfor_fndecl_math_cpow =
1414 gfc_build_library_function_decl (get_identifier ("cpow"),
1415 gfc_complex8_type_node,
1416 1, gfc_complex8_type_node);
1417 gfor_fndecl_math_cabsf =
1418 gfc_build_library_function_decl (get_identifier ("cabsf"),
1419 gfc_real4_type_node,
1420 1, gfc_complex4_type_node);
1421 gfor_fndecl_math_cabs =
1422 gfc_build_library_function_decl (get_identifier ("cabs"),
1423 gfc_real8_type_node,
1424 1, gfc_complex8_type_node);
1425 gfor_fndecl_math_sign4 =
1426 gfc_build_library_function_decl (get_identifier ("copysignf"),
1427 gfc_real4_type_node,
1428 1, gfc_real4_type_node);
1429 gfor_fndecl_math_sign8 =
1430 gfc_build_library_function_decl (get_identifier ("copysign"),
1431 gfc_real8_type_node,
1432 1, gfc_real8_type_node);
1433 gfor_fndecl_math_ishftc4 =
1434 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")),
1435 gfc_int4_type_node,
1436 3, gfc_int4_type_node,
1437 gfc_int4_type_node, gfc_int4_type_node);
1438 gfor_fndecl_math_ishftc8 =
1439 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")),
1440 gfc_int8_type_node,
1441 3, gfc_int8_type_node,
1442 gfc_int8_type_node, gfc_int8_type_node);
1443 gfor_fndecl_math_exponent4 =
1444 gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r4")),
1445 gfc_int4_type_node,
1446 1, gfc_real4_type_node);
1447 gfor_fndecl_math_exponent8 =
1448 gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r8")),
1449 gfc_int4_type_node,
1450 1, gfc_real8_type_node);
1451
1452 /* Other functions. */
1453 gfor_fndecl_size0 =
1454 gfc_build_library_function_decl (get_identifier (PREFIX("size0")),
1455 gfc_array_index_type,
1456 1, pvoid_type_node);
1457 gfor_fndecl_size1 =
1458 gfc_build_library_function_decl (get_identifier (PREFIX("size1")),
1459 gfc_array_index_type,
1460 2, pvoid_type_node,
1461 gfc_array_index_type);
1462}
1463
1464
1465/* Make prototypes for runtime library functions. */
1466
1467void
1468gfc_build_builtin_function_decls (void)
1469{
1470 gfor_fndecl_internal_malloc =
1471 gfc_build_library_function_decl (get_identifier (PREFIX("internal_malloc")),
1472 pvoid_type_node, 1, gfc_int4_type_node);
1473
1474 gfor_fndecl_internal_malloc64 =
1475 gfc_build_library_function_decl (get_identifier
1476 (PREFIX("internal_malloc64")),
1477 pvoid_type_node, 1, gfc_int8_type_node);
1478
1479 gfor_fndecl_internal_free =
1480 gfc_build_library_function_decl (get_identifier (PREFIX("internal_free")),
1481 void_type_node, 1, pvoid_type_node);
1482
1483 gfor_fndecl_allocate =
1484 gfc_build_library_function_decl (get_identifier (PREFIX("allocate")),
1485 void_type_node, 2, ppvoid_type_node,
1486 gfc_int4_type_node);
1487
1488 gfor_fndecl_allocate64 =
1489 gfc_build_library_function_decl (get_identifier (PREFIX("allocate64")),
1490 void_type_node, 2, ppvoid_type_node,
1491 gfc_int8_type_node);
1492
1493 gfor_fndecl_deallocate =
1494 gfc_build_library_function_decl (get_identifier (PREFIX("deallocate")),
1495 void_type_node, 1, ppvoid_type_node);
1496
1497 gfor_fndecl_stop_numeric =
1498 gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
1499 void_type_node, 1, gfc_int4_type_node);
1500
1501 gfor_fndecl_stop_string =
1502 gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),
1503 void_type_node, 2, pchar_type_node,
1504 gfc_int4_type_node);
1505
1506 gfor_fndecl_pause_numeric =
1507 gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
1508 void_type_node, 1, gfc_int4_type_node);
1509
1510 gfor_fndecl_pause_string =
1511 gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")),
1512 void_type_node, 2, pchar_type_node,
1513 gfc_int4_type_node);
1514
1515 gfor_fndecl_select_string =
1516 gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
1517 pvoid_type_node, 0);
1518
1519 gfor_fndecl_runtime_error =
1520 gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
1521 void_type_node,
1522 3,
1523 pchar_type_node, pchar_type_node,
1524 gfc_int4_type_node);
1525
1526 gfor_fndecl_in_pack = gfc_build_library_function_decl (
1527 get_identifier (PREFIX("internal_pack")),
1528 pvoid_type_node, 1, pvoid_type_node);
1529
1530 gfor_fndecl_in_unpack = gfc_build_library_function_decl (
1531 get_identifier (PREFIX("internal_unpack")),
1532 pvoid_type_node, 1, pvoid_type_node);
1533
1534 gfor_fndecl_associated =
1535 gfc_build_library_function_decl (
1536 get_identifier (PREFIX("associated")),
1537 gfc_logical4_type_node,
1538 2,
1539 ppvoid_type_node,
1540 ppvoid_type_node);
1541
1542 gfc_build_intrinsic_function_decls ();
1543 gfc_build_intrinsic_lib_fndecls ();
1544 gfc_build_io_library_fndecls ();
1545}
1546
1547
1548/* Exaluate the length of dummy character variables. */
1549
1550static tree
1551gfc_trans_dummy_character (gfc_charlen * cl, tree fnbody)
1552{
1553 stmtblock_t body;
1554
1555 gfc_finish_decl (cl->backend_decl, NULL_TREE);
1556
1557 gfc_start_block (&body);
1558
1559 /* Evaluate the string length expression. */
1560 gfc_trans_init_string_length (cl, &body);
1561
1562 gfc_add_expr_to_block (&body, fnbody);
1563 return gfc_finish_block (&body);
1564}
1565
1566
1567/* Allocate and cleanup an automatic character variable. */
1568
1569static tree
1570gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
1571{
1572 stmtblock_t body;
1573 tree decl;
1574 tree args;
1575 tree tmp;
1576
1577 assert (sym->backend_decl);
1578 assert (sym->ts.cl && sym->ts.cl->length);
1579
1580 gfc_start_block (&body);
1581
1582 /* Evaluate the string length expression. */
1583 gfc_trans_init_string_length (sym->ts.cl, &body);
1584
1585 decl = sym->backend_decl;
1586
1587 DECL_DEFER_OUTPUT (decl) = 1;
1588
1589 /* Generate code to allocate the automatic variable. It will be freed
1590 automatically. */
1591 tmp = gfc_build_addr_expr (NULL, decl);
1592 args = gfc_chainon_list (NULL_TREE, tmp);
1593 args = gfc_chainon_list (args, sym->ts.cl->backend_decl);
1594 tmp = gfc_build_function_call (built_in_decls[BUILT_IN_STACK_ALLOC], args);
1595 gfc_add_expr_to_block (&body, tmp);
1596 gfc_add_expr_to_block (&body, fnbody);
1597 return gfc_finish_block (&body);
1598}
1599
1600
1601/* Generate function entry and exit code, and add it to the function body.
1602 This includes:
1603 Allocation and initialisation of array variables.
1604 Allocation of character string variables.
1605 Initialization and possibly repacking of dummy arrays. */
1606
1607static tree
1608gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
1609{
1610 locus loc;
1611 gfc_symbol *sym;
1612
1613 /* Deal with implicit return variables. Explicit return variables will
1614 already have been added. */
1615 if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
1616 {
1617 if (!current_fake_result_decl)
1618 {
1619 warning ("Function does not return a value");
1620 return fnbody;
1621 }
1622
1623 if (proc_sym->as)
1624 {
1625 fnbody = gfc_trans_dummy_array_bias (proc_sym,
1626 current_fake_result_decl,
1627 fnbody);
1628 }
1629 else if (proc_sym->ts.type == BT_CHARACTER)
1630 {
1631 if (TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
1632 fnbody = gfc_trans_dummy_character (proc_sym->ts.cl, fnbody);
1633 }
1634 else
1635 gfc_todo_error ("Deferred non-array return by reference");
1636 }
1637
1638 for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
1639 {
1640 if (sym->attr.dimension)
1641 {
1642 switch (sym->as->type)
1643 {
1644 case AS_EXPLICIT:
1645 if (sym->attr.dummy || sym->attr.result)
1646 fnbody =
1647 gfc_trans_dummy_array_bias (sym, sym->backend_decl, fnbody);
1648 else if (sym->attr.pointer || sym->attr.allocatable)
1649 {
1650 if (TREE_STATIC (sym->backend_decl))
1651 gfc_trans_static_array_pointer (sym);
1652 else
1653 fnbody = gfc_trans_deferred_array (sym, fnbody);
1654 }
1655 else
1656 {
1657 gfc_get_backend_locus (&loc);
1658 gfc_set_backend_locus (&sym->declared_at);
1659 fnbody = gfc_trans_auto_array_allocation (sym->backend_decl,
1660 sym, fnbody);
1661 gfc_set_backend_locus (&loc);
1662 }
1663 break;
1664
1665 case AS_ASSUMED_SIZE:
1666 /* Must be a dummy parameter. */
1667 assert (sym->attr.dummy);
1668
1669 /* We should always pass assumed size arrays the g77 way. */
1670 assert (TREE_CODE (sym->backend_decl) == PARM_DECL);
1671 fnbody = gfc_trans_g77_array (sym, fnbody);
1672 break;
1673
1674 case AS_ASSUMED_SHAPE:
1675 /* Must be a dummy parameter. */
1676 assert (sym->attr.dummy);
1677
1678 fnbody = gfc_trans_dummy_array_bias (sym, sym->backend_decl,
1679 fnbody);
1680 break;
1681
1682 case AS_DEFERRED:
1683 fnbody = gfc_trans_deferred_array (sym, fnbody);
1684 break;
1685
1686 default:
1687 abort ();
1688 }
1689 }
1690 else if (sym->ts.type == BT_CHARACTER)
1691 {
1692 gfc_get_backend_locus (&loc);
1693 gfc_set_backend_locus (&sym->declared_at);
1694 if (sym->attr.dummy || sym->attr.result)
1695 fnbody = gfc_trans_dummy_character (sym->ts.cl, fnbody);
1696 else
1697 fnbody = gfc_trans_auto_character_variable (sym, fnbody);
1698 gfc_set_backend_locus (&loc);
1699 }
1700 else
1701 abort ();
1702 }
1703
1704 return fnbody;
1705}
1706
1707
1708/* Output an initialized decl for a module variable. */
1709
1710static void
1711gfc_create_module_variable (gfc_symbol * sym)
1712{
1713 tree decl;
1714 gfc_se se;
1715
1716 /* Only output symbols from this module. */
1717 if (sym->ns != module_namespace)
1718 {
1719 /* I don't think this should ever happen. */
1720 internal_error ("module symbol %s in wrong namespace", sym->name);
1721 }
1722
1723 /* Don't ouptut symbols from common blocks. */
1724 if (sym->attr.common)
1725 return;
1726
1727 /* Only output variables and array valued parametes. */
1728 if (sym->attr.flavor != FL_VARIABLE
1729 && (sym->attr.flavor != FL_PARAMETER || sym->attr.dimension == 0))
1730 return;
1731
1732 /* Don't generate variables from other modules. */
1733 if (sym->attr.use_assoc)
1734 return;
1735
1736 if (sym->backend_decl)
1737 internal_error ("backend decl for module variable %s already exists",
1738 sym->name);
1739
1740 /* We always want module variables to be created. */
1741 sym->attr.referenced = 1;
1742 /* Create the decl. */
1743 decl = gfc_get_symbol_decl (sym);
1744
1745 /* We want to allocate storage for this variable. */
1746 TREE_STATIC (decl) = 1;
1747
1748 if (sym->attr.dimension)
1749 {
1750 assert (sym->attr.pointer || sym->attr.allocatable
1751 || GFC_ARRAY_TYPE_P (TREE_TYPE (sym->backend_decl)));
1752 if (sym->attr.pointer || sym->attr.allocatable)
1753 gfc_trans_static_array_pointer (sym);
1754 else
1755 gfc_trans_auto_array_allocation (sym->backend_decl, sym, NULL_TREE);
1756 }
1757 else if (sym->ts.type == BT_DERIVED)
1758 {
1759 if (sym->value)
1760 gfc_todo_error ("Initialization of derived type module variables");
1761 }
1762 else
1763 {
1764 if (sym->value)
1765 {
1766 gfc_init_se (&se, NULL);
1767 gfc_conv_constant (&se, sym->value);
1768 DECL_INITIAL (decl) = se.expr;
1769 }
1770 }
1771
1772 /* Create the variable. */
1773 pushdecl (decl);
1774 rest_of_decl_compilation (decl, NULL, 1, 0);
1775
1776 /* Also add length of strings. */
1777 if (sym->ts.type == BT_CHARACTER)
1778 {
1779 tree length;
1780
1781 length = sym->ts.cl->backend_decl;
1782 if (!INTEGER_CST_P (length))
1783 {
1784 pushdecl (length);
1785 rest_of_decl_compilation (length, NULL, 1, 0);
1786 }
1787 }
1788}
1789
1790
1791/* Generate all the required code for module variables. */
1792
1793void
1794gfc_generate_module_vars (gfc_namespace * ns)
1795{
1796 module_namespace = ns;
1797
dfc222eb 1798 /* Check if the frontend left the namespace in a reasonable state. */
4ee9c684 1799 assert (ns->proc_name && !ns->proc_name->tlink);
1800
dfc222eb 1801 /* Create decls for all the module variables. */
4ee9c684 1802 gfc_traverse_ns (ns, gfc_create_module_variable);
1803}
1804
1805static void
1806gfc_generate_contained_functions (gfc_namespace * parent)
1807{
1808 gfc_namespace *ns;
1809
1810 /* We create all the prototypes before generating any code. */
1811 for (ns = parent->contained; ns; ns = ns->sibling)
1812 {
1813 /* Skip namespaces from used modules. */
1814 if (ns->parent != parent)
1815 continue;
1816
1817 gfc_build_function_decl (ns->proc_name);
1818 }
1819
1820 for (ns = parent->contained; ns; ns = ns->sibling)
1821 {
1822 /* Skip namespaces from used modules. */
1823 if (ns->parent != parent)
1824 continue;
1825
1826 gfc_generate_function_code (ns);
1827 }
1828}
1829
1830
1831/* Generate decls for all local variables. We do this to ensure correct
1832 handling of expressions which only appear in the specification of
1833 other functions. */
1834
1835static void
1836generate_local_decl (gfc_symbol * sym)
1837{
1838 if (sym->attr.flavor == FL_VARIABLE)
1839 {
1840 /* TODO: The frontend sometimes creates symbols for things which don't
1841 actually exist. E.g. common block names and the names of formal
1842 arguments. The latter are created while attempting to parse
1843 the argument list as a substring reference.
1844
1845 The proper fix is to avoid adding these symbols in the first place.
1846 For now we hack round it by ignoring anything with an unknown type.
1847 */
1848 if (sym->ts.type == BT_UNKNOWN)
1849 return;
1850
1851 if (sym->attr.referenced)
1852 gfc_get_symbol_decl (sym);
1853 else if (sym->attr.dummy)
1854 {
1855 if (warn_unused_parameter)
1856 warning ("unused parameter `%s'", sym->name);
1857 }
ae93fbc6 1858 /* warn for unused variables, but not if they're inside a common
dfc222eb 1859 block. */
ae93fbc6 1860 else if (warn_unused_variable && !sym->attr.in_common)
4ee9c684 1861 warning ("unused variable `%s'", sym->name);
1862 }
1863}
1864
1865static void
1866generate_local_vars (gfc_namespace * ns)
1867{
1868 gfc_traverse_ns (ns, generate_local_decl);
1869}
1870
1871
1872/* Finalize DECL and all nested functions with cgraph. */
1873
1874static void
1875gfc_finalize (tree decl)
1876{
1877 struct cgraph_node *cgn;
1878
1879 cgn = cgraph_node (decl);
1880 for (cgn = cgn->nested; cgn ; cgn = cgn->next_nested)
1881 gfc_finalize (cgn->decl);
1882
1883 cgraph_finalize_function (decl, false);
1884}
1885
1886/* Generate code for a function. */
1887
1888void
1889gfc_generate_function_code (gfc_namespace * ns)
1890{
1891 tree fndecl;
1892 tree old_context;
1893 tree decl;
1894 tree tmp;
1895 stmtblock_t block;
1896 stmtblock_t body;
1897 tree result;
1898 gfc_symbol *sym;
1899
1900 sym = ns->proc_name;
1901 /* Check that the frontend isn't still using this. */
1902 assert (sym->tlink == NULL);
1903
1904 sym->tlink = sym;
1905
1906 /* Create the declaration for functions with global scope. */
1907 if (!sym->backend_decl)
1908 gfc_build_function_decl (ns->proc_name);
1909
1910 fndecl = sym->backend_decl;
1911 old_context = current_function_decl;
1912
1913 if (old_context)
1914 {
1915 push_function_context ();
1916 saved_parent_function_decls = saved_function_decls;
1917 saved_function_decls = NULL_TREE;
1918 }
1919
1920 /* let GCC know the current scope is this function */
1921 current_function_decl = fndecl;
1922
1923 /* print function name on the console at compile time
1924 (unless this feature was switched of by command line option "-quiet" */
1925 announce_function (fndecl);
1926
1927 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1928 {
1929 /* create RTL for function declaration */
1930 rest_of_decl_compilation (fndecl, NULL, 1, 0);
1931 }
1932
1933 /* create RTL for function definition */
1934 make_decl_rtl (fndecl, NULL);
1935
1936 /* Set the line and filename. sym->decalred_at seems to point to the last
1937 statement for subroutines, but it'll do for now. */
1938 gfc_set_backend_locus (&sym->declared_at);
1939
1940 /* line and file should not be 0 */
1941 init_function_start (fndecl);
1942
1943 /* We're in function-at-a-time mode. */
1944 cfun->x_whole_function_mode_p = 1;
1945
1946 /* Even though we're inside a function body, we still don't want to
1947 call expand_expr to calculate the size of a variable-sized array.
1948 We haven't necessarily assigned RTL to all variables yet, so it's
1949 not safe to try to expand expressions involving them. */
1950 immediate_size_expand = 0;
1951 cfun->x_dont_save_pending_sizes_p = 1;
1952
1953 /* Will be created as needed. */
1954 current_fake_result_decl = NULL_TREE;
1955
1956 /* function.c requires a push at the start of the function */
1957 pushlevel (0);
1958
1959 gfc_start_block (&block);
1960
1961 gfc_generate_contained_functions (ns);
1962
1963 /* Translate COMMON blocks. */
1964 gfc_trans_common (ns);
1965
1966 generate_local_vars (ns);
1967
1968 current_function_return_label = NULL;
1969
1970 /* Now generate the code for the body of this function. */
1971 gfc_init_block (&body);
1972
1973 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
1974 && sym->attr.subroutine)
1975 {
1976 tree alternate_return;
1977 alternate_return = gfc_get_fake_result_decl (sym);
1978 gfc_add_modify_expr (&body, alternate_return, integer_zero_node);
1979 }
1980
1981 tmp = gfc_trans_code (ns->code);
1982 gfc_add_expr_to_block (&body, tmp);
1983
1984 /* Add a return label if needed. */
1985 if (current_function_return_label)
1986 {
1987 tmp = build1_v (LABEL_EXPR, current_function_return_label);
1988 gfc_add_expr_to_block (&body, tmp);
1989 }
1990
1991 tmp = gfc_finish_block (&body);
1992 /* Add code to create and cleanup arrays. */
1993 tmp = gfc_trans_deferred_vars (sym, tmp);
1994 gfc_add_expr_to_block (&block, tmp);
1995
1996 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
1997 {
1998 if (sym->attr.subroutine ||sym == sym->result)
1999 {
2000 result = current_fake_result_decl;
2001 current_fake_result_decl = NULL_TREE;
2002 }
2003 else
2004 result = sym->result->backend_decl;
2005
2006 if (result == NULL_TREE)
2007 warning ("Function return value not set");
2008 else
2009 {
2010 /* Set the return value to the the dummy result variable. */
2011 tmp = build (MODIFY_EXPR, TREE_TYPE (result),
2012 DECL_RESULT (fndecl), result);
2013 tmp = build_v (RETURN_EXPR, tmp);
2014 gfc_add_expr_to_block (&block, tmp);
2015 }
2016 }
2017
2018 /* Add all the decls we created during processing. */
2019 decl = saved_function_decls;
2020 while (decl)
2021 {
2022 tree next;
2023
2024 next = TREE_CHAIN (decl);
2025 TREE_CHAIN (decl) = NULL_TREE;
2026 pushdecl (decl);
2027 decl = next;
2028 }
2029 saved_function_decls = NULL_TREE;
2030
2031 DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);
2032
2033 /* Finish off this function and send it for code generation. */
2034 poplevel (1, 0, 1);
2035 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
2036
2037 /* Output the GENERIC tree. */
2038 dump_function (TDI_original, fndecl);
2039
2040 /* Store the end of the function, so that we get good line number
2041 info for the epilogue. */
2042 cfun->function_end_locus = input_location;
2043
2044 /* We're leaving the context of this function, so zap cfun.
2045 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
2046 tree_rest_of_compilation. */
2047 cfun = NULL;
2048
2049 if (old_context)
2050 {
2051 pop_function_context ();
2052 saved_function_decls = saved_parent_function_decls;
2053 }
2054 current_function_decl = old_context;
2055
2056 if (decl_function_context (fndecl))
2057 {
2058 /* Register this function with cgraph just far enough to get it
2059 added to our parent's nested function list. */
2060 (void) cgraph_node (fndecl);
2061
2062 /* Lowering nested functions requires gimple input. */
2063 gimplify_function_tree (fndecl);
2064 }
2065 else
2066 {
2067 if (cgraph_node (fndecl)->nested)
2068 {
2069 gimplify_function_tree (fndecl);
2070 lower_nested_functions (fndecl);
2071 }
2072 gfc_finalize (fndecl);
2073 }
2074}
2075
2076
2077void
2078gfc_generate_constructors (void)
2079{
2080 if (gfc_static_ctors != NULL_TREE)
2081 abort ();
2082#if 0
2083 tree fnname;
2084 tree type;
2085 tree fndecl;
2086 tree decl;
2087 tree tmp;
2088
2089 if (gfc_static_ctors == NULL_TREE)
2090 return;
2091
2092 fnname = get_file_function_name ('I');
2093 type = build_function_type (void_type_node,
2094 gfc_chainon_list (NULL_TREE, void_type_node));
2095
2096 fndecl = build_decl (FUNCTION_DECL, fnname, type);
2097 TREE_PUBLIC (fndecl) = 1;
2098
2099 decl = build_decl (RESULT_DECL, NULL_TREE, void_type_node);
2100 DECL_CONTEXT (decl) = fndecl;
2101 DECL_RESULT (fndecl) = decl;
2102
2103 pushdecl (fndecl);
2104
2105 current_function_decl = fndecl;
2106
2107 rest_of_decl_compilation (fndecl, NULL, 1, 0);
2108
2109 make_decl_rtl (fndecl, NULL);
2110
2111 init_function_start (fndecl, input_filename, input_line);
2112
2113 cfun->x_whole_function_mode_p = 1;
2114
2115 immediate_size_expand = 0;
2116
2117 pushlevel (0);
2118
2119 for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
2120 {
2121 tmp =
2122 gfc_build_function_call (TREE_VALUE (gfc_static_ctors), NULL_TREE);
2123 DECL_SAVED_TREE (fndecl) = build_stmt (EXPR_STMT, tmp);
2124 }
2125
2126 poplevel (1, 0, 1);
2127
2128 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
2129
2130 free_after_parsing (cfun);
2131 free_after_compilation (cfun);
2132
2133 tree_rest_of_compilation (fndecl, 0);
2134
2135 current_function_decl = NULL_TREE;
2136#endif
2137}
2138
2139#include "gt-fortran-trans-decl.h"
Mirror of https://gcc.gnu.org/git/gcc.git