1 /* Backend function setup
2 Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
3 Contributed by Paul Brook
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 2, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING. If not, write to the Free
19 Software Foundation, 59 Temple Place - Suite 330, Boston, MA
22 /* trans-decl.c -- Handling of backend function and variable decls, etc */
26 #include "coretypes.h"
28 #include "tree-dump.h"
29 #include "tree-gimple.h"
40 #include "trans-types.h"
41 #include "trans-array.h"
42 #include "trans-const.h"
43 /* Only for gfc_trans_code. Shouldn't need to include this. */
44 #include "trans-stmt.h"
46 #define MAX_LABEL_VALUE 99999
49 /* Holds the result of the function if no result variable specified. */
51 static GTY(()) tree current_fake_result_decl
;
53 static GTY(()) tree current_function_return_label
;
56 /* Holds the variable DECLs for the current function. */
58 static GTY(()) tree saved_function_decls
= NULL_TREE
;
59 static GTY(()) tree saved_parent_function_decls
= NULL_TREE
;
62 /* The namespace of the module we're currently generating. Only used while
63 outputting decls for module variables. Do not rely on this being set. */
65 static gfc_namespace
*module_namespace
;
68 /* List of static constructor functions. */
70 tree gfc_static_ctors
;
73 /* Function declarations for builtin library functions. */
75 tree gfor_fndecl_internal_malloc
;
76 tree gfor_fndecl_internal_malloc64
;
77 tree gfor_fndecl_internal_free
;
78 tree gfor_fndecl_allocate
;
79 tree gfor_fndecl_allocate64
;
80 tree gfor_fndecl_deallocate
;
81 tree gfor_fndecl_pause_numeric
;
82 tree gfor_fndecl_pause_string
;
83 tree gfor_fndecl_stop_numeric
;
84 tree gfor_fndecl_stop_string
;
85 tree gfor_fndecl_select_string
;
86 tree gfor_fndecl_runtime_error
;
87 tree gfor_fndecl_in_pack
;
88 tree gfor_fndecl_in_unpack
;
89 tree gfor_fndecl_associated
;
92 /* Math functions. Many other math functions are handled in
95 gfc_powdecl_list gfor_fndecl_math_powi
[3][2];
96 tree gfor_fndecl_math_cpowf
;
97 tree gfor_fndecl_math_cpow
;
98 tree gfor_fndecl_math_ishftc4
;
99 tree gfor_fndecl_math_ishftc8
;
100 tree gfor_fndecl_math_exponent4
;
101 tree gfor_fndecl_math_exponent8
;
104 /* String functions. */
106 tree gfor_fndecl_copy_string
;
107 tree gfor_fndecl_compare_string
;
108 tree gfor_fndecl_concat_string
;
109 tree gfor_fndecl_string_len_trim
;
110 tree gfor_fndecl_string_index
;
111 tree gfor_fndecl_string_scan
;
112 tree gfor_fndecl_string_verify
;
113 tree gfor_fndecl_string_trim
;
114 tree gfor_fndecl_string_repeat
;
115 tree gfor_fndecl_adjustl
;
116 tree gfor_fndecl_adjustr
;
119 /* Other misc. runtime library functions. */
121 tree gfor_fndecl_size0
;
122 tree gfor_fndecl_size1
;
123 tree gfor_fndecl_iargc
;
125 /* Intrinsic functions implemented in FORTRAN. */
126 tree gfor_fndecl_si_kind
;
127 tree gfor_fndecl_sr_kind
;
131 gfc_add_decl_to_parent_function (tree decl
)
134 DECL_CONTEXT (decl
) = DECL_CONTEXT (current_function_decl
);
135 DECL_NONLOCAL (decl
) = 1;
136 TREE_CHAIN (decl
) = saved_parent_function_decls
;
137 saved_parent_function_decls
= decl
;
141 gfc_add_decl_to_function (tree decl
)
144 TREE_USED (decl
) = 1;
145 DECL_CONTEXT (decl
) = current_function_decl
;
146 TREE_CHAIN (decl
) = saved_function_decls
;
147 saved_function_decls
= decl
;
151 /* Build a backend label declaration. Set TREE_USED for named labels.
152 The context of the label is always the current_function_decl. All
153 labels are marked artificial. */
156 gfc_build_label_decl (tree label_id
)
158 /* 2^32 temporaries should be enough. */
159 static unsigned int tmp_num
= 1;
163 if (label_id
== NULL_TREE
)
165 /* Build an internal label name. */
166 ASM_FORMAT_PRIVATE_NAME (label_name
, "L", tmp_num
++);
167 label_id
= get_identifier (label_name
);
172 /* Build the LABEL_DECL node. Labels have no type. */
173 label_decl
= build_decl (LABEL_DECL
, label_id
, void_type_node
);
174 DECL_CONTEXT (label_decl
) = current_function_decl
;
175 DECL_MODE (label_decl
) = VOIDmode
;
177 /* We always define the label as used, even if the original source
178 file never references the label. We don't want all kinds of
179 spurious warnings for old-style Fortran code with too many
181 TREE_USED (label_decl
) = 1;
183 DECL_ARTIFICIAL (label_decl
) = 1;
188 /* Returns the return label for the current function. */
191 gfc_get_return_label (void)
193 char name
[GFC_MAX_SYMBOL_LEN
+ 10];
195 if (current_function_return_label
)
196 return current_function_return_label
;
198 sprintf (name
, "__return_%s",
199 IDENTIFIER_POINTER (DECL_NAME (current_function_decl
)));
201 current_function_return_label
=
202 gfc_build_label_decl (get_identifier (name
));
204 DECL_ARTIFICIAL (current_function_return_label
) = 1;
206 return current_function_return_label
;
210 /* Set the backend source location of a decl. */
213 gfc_set_decl_location (tree decl
, locus
* loc
)
215 #ifdef USE_MAPPED_LOCATION
216 DECL_SOURCE_LOCATION (decl
) = loc
->lb
->location
;
218 DECL_SOURCE_LINE (decl
) = loc
->lb
->linenum
;
219 DECL_SOURCE_FILE (decl
) = loc
->lb
->file
->filename
;
224 /* Return the backend label declaration for a given label structure,
225 or create it if it doesn't exist yet. */
228 gfc_get_label_decl (gfc_st_label
* lp
)
230 if (lp
->backend_decl
)
231 return lp
->backend_decl
;
234 char label_name
[GFC_MAX_SYMBOL_LEN
+ 1];
237 /* Validate the label declaration from the front end. */
238 gcc_assert (lp
!= NULL
&& lp
->value
<= MAX_LABEL_VALUE
);
240 /* Build a mangled name for the label. */
241 sprintf (label_name
, "__label_%.6d", lp
->value
);
243 /* Build the LABEL_DECL node. */
244 label_decl
= gfc_build_label_decl (get_identifier (label_name
));
246 /* Tell the debugger where the label came from. */
247 if (lp
->value
<= MAX_LABEL_VALUE
) /* An internal label. */
248 gfc_set_decl_location (label_decl
, &lp
->where
);
250 DECL_ARTIFICIAL (label_decl
) = 1;
252 /* Store the label in the label list and return the LABEL_DECL. */
253 lp
->backend_decl
= label_decl
;
259 /* Convert a gfc_symbol to an identifier of the same name. */
262 gfc_sym_identifier (gfc_symbol
* sym
)
264 return (get_identifier (sym
->name
));
268 /* Construct mangled name from symbol name. */
271 gfc_sym_mangled_identifier (gfc_symbol
* sym
)
273 char name
[GFC_MAX_MANGLED_SYMBOL_LEN
+ 1];
275 if (sym
->module
== NULL
)
276 return gfc_sym_identifier (sym
);
279 snprintf (name
, sizeof name
, "__%s__%s", sym
->module
, sym
->name
);
280 return get_identifier (name
);
285 /* Construct mangled function name from symbol name. */
288 gfc_sym_mangled_function_id (gfc_symbol
* sym
)
291 char name
[GFC_MAX_MANGLED_SYMBOL_LEN
+ 1];
293 if (sym
->module
== NULL
|| sym
->attr
.proc
== PROC_EXTERNAL
294 || (sym
->module
!= NULL
&& sym
->attr
.if_source
== IFSRC_IFBODY
))
296 if (strcmp (sym
->name
, "MAIN__") == 0
297 || sym
->attr
.proc
== PROC_INTRINSIC
)
298 return get_identifier (sym
->name
);
300 if (gfc_option
.flag_underscoring
)
302 has_underscore
= strchr (sym
->name
, '_') != 0;
303 if (gfc_option
.flag_second_underscore
&& has_underscore
)
304 snprintf (name
, sizeof name
, "%s__", sym
->name
);
306 snprintf (name
, sizeof name
, "%s_", sym
->name
);
307 return get_identifier (name
);
310 return get_identifier (sym
->name
);
314 snprintf (name
, sizeof name
, "__%s__%s", sym
->module
, sym
->name
);
315 return get_identifier (name
);
320 /* Returns true if a variable of specified size should go on the stack. */
323 gfc_can_put_var_on_stack (tree size
)
325 unsigned HOST_WIDE_INT low
;
327 if (!INTEGER_CST_P (size
))
330 if (gfc_option
.flag_max_stack_var_size
< 0)
333 if (TREE_INT_CST_HIGH (size
) != 0)
336 low
= TREE_INT_CST_LOW (size
);
337 if (low
> (unsigned HOST_WIDE_INT
) gfc_option
.flag_max_stack_var_size
)
340 /* TODO: Set a per-function stack size limit. */
346 /* Finish processing of a declaration and install its initial value. */
349 gfc_finish_decl (tree decl
, tree init
)
351 if (TREE_CODE (decl
) == PARM_DECL
)
352 gcc_assert (init
== NULL_TREE
);
353 /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se
354 -- it overlaps DECL_ARG_TYPE. */
355 else if (init
== NULL_TREE
)
356 gcc_assert (DECL_INITIAL (decl
) == NULL_TREE
);
358 gcc_assert (DECL_INITIAL (decl
) == error_mark_node
);
360 if (init
!= NULL_TREE
)
362 if (TREE_CODE (decl
) != TYPE_DECL
)
363 DECL_INITIAL (decl
) = init
;
366 /* typedef foo = bar; store the type of bar as the type of foo. */
367 TREE_TYPE (decl
) = TREE_TYPE (init
);
368 DECL_INITIAL (decl
) = init
= 0;
372 if (TREE_CODE (decl
) == VAR_DECL
)
374 if (DECL_SIZE (decl
) == NULL_TREE
375 && TYPE_SIZE (TREE_TYPE (decl
)) != NULL_TREE
)
376 layout_decl (decl
, 0);
378 /* A static variable with an incomplete type is an error if it is
379 initialized. Also if it is not file scope. Otherwise, let it
380 through, but if it is not `extern' then it may cause an error
382 /* An automatic variable with an incomplete type is an error. */
383 if (DECL_SIZE (decl
) == NULL_TREE
384 && (TREE_STATIC (decl
) ? (DECL_INITIAL (decl
) != 0
385 || DECL_CONTEXT (decl
) != 0)
386 : !DECL_EXTERNAL (decl
)))
388 gfc_fatal_error ("storage size not known");
391 if ((DECL_EXTERNAL (decl
) || TREE_STATIC (decl
))
392 && (DECL_SIZE (decl
) != 0)
393 && (TREE_CODE (DECL_SIZE (decl
)) != INTEGER_CST
))
395 gfc_fatal_error ("storage size not constant");
402 /* Apply symbol attributes to a variable, and add it to the function scope. */
405 gfc_finish_var_decl (tree decl
, gfc_symbol
* sym
)
407 /* TREE_ADDRESSABLE means the address of this variable is actually needed.
408 This is the equivalent of the TARGET variables.
409 We also need to set this if the variable is passed by reference in a
411 if (sym
->attr
.target
)
412 TREE_ADDRESSABLE (decl
) = 1;
413 /* If it wasn't used we wouldn't be getting it. */
414 TREE_USED (decl
) = 1;
416 /* Chain this decl to the pending declarations. Don't do pushdecl()
417 because this would add them to the current scope rather than the
419 if (current_function_decl
!= NULL_TREE
)
421 if (sym
->ns
->proc_name
->backend_decl
== current_function_decl
)
422 gfc_add_decl_to_function (decl
);
424 gfc_add_decl_to_parent_function (decl
);
427 /* If a variable is USE associated, it's always external. */
428 if (sym
->attr
.use_assoc
)
430 DECL_EXTERNAL (decl
) = 1;
431 TREE_PUBLIC (decl
) = 1;
433 else if (sym
->module
&& !sym
->attr
.result
&& !sym
->attr
.dummy
)
435 /* TODO: Don't set sym->module for result or dummy variables. */
436 gcc_assert (current_function_decl
== NULL_TREE
);
437 /* This is the declaration of a module variable. */
438 TREE_PUBLIC (decl
) = 1;
439 TREE_STATIC (decl
) = 1;
442 if ((sym
->attr
.save
|| sym
->attr
.data
|| sym
->value
)
443 && !sym
->attr
.use_assoc
)
444 TREE_STATIC (decl
) = 1;
446 /* Keep variables larger than max-stack-var-size off stack. */
447 if (!sym
->ns
->proc_name
->attr
.recursive
448 && INTEGER_CST_P (DECL_SIZE_UNIT (decl
))
449 && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl
)))
450 TREE_STATIC (decl
) = 1;
454 /* Allocate the lang-specific part of a decl. */
457 gfc_allocate_lang_decl (tree decl
)
459 DECL_LANG_SPECIFIC (decl
) = (struct lang_decl
*)
460 ggc_alloc_cleared (sizeof (struct lang_decl
));
463 /* Remember a symbol to generate initialization/cleanup code at function
467 gfc_defer_symbol_init (gfc_symbol
* sym
)
473 /* Don't add a symbol twice. */
477 last
= head
= sym
->ns
->proc_name
;
480 /* Make sure that setup code for dummy variables which are used in the
481 setup of other variables is generated first. */
484 /* Find the first dummy arg seen after us, or the first non-dummy arg.
485 This is a circular list, so don't go past the head. */
487 && (!p
->attr
.dummy
|| p
->dummy_order
> sym
->dummy_order
))
493 /* Insert in between last and p. */
499 /* Create an array index type variable with function scope. */
502 create_index_var (const char * pfx
, int nest
)
506 decl
= gfc_create_var_np (gfc_array_index_type
, pfx
);
508 gfc_add_decl_to_parent_function (decl
);
510 gfc_add_decl_to_function (decl
);
515 /* Create variables to hold all the non-constant bits of info for a
516 descriptorless array. Remember these in the lang-specific part of the
520 gfc_build_qualified_array (tree decl
, gfc_symbol
* sym
)
526 type
= TREE_TYPE (decl
);
528 /* We just use the descriptor, if there is one. */
529 if (GFC_DESCRIPTOR_TYPE_P (type
))
532 gcc_assert (GFC_ARRAY_TYPE_P (type
));
533 nest
= (sym
->ns
->proc_name
->backend_decl
!= current_function_decl
)
534 && !sym
->attr
.contained
;
536 for (dim
= 0; dim
< GFC_TYPE_ARRAY_RANK (type
); dim
++)
538 if (GFC_TYPE_ARRAY_LBOUND (type
, dim
) == NULL_TREE
)
539 GFC_TYPE_ARRAY_LBOUND (type
, dim
) = create_index_var ("lbound", nest
);
540 /* Don't try to use the unkown bound for assumed shape arrays. */
541 if (GFC_TYPE_ARRAY_UBOUND (type
, dim
) == NULL_TREE
542 && (sym
->as
->type
!= AS_ASSUMED_SIZE
543 || dim
< GFC_TYPE_ARRAY_RANK (type
) - 1))
544 GFC_TYPE_ARRAY_UBOUND (type
, dim
) = create_index_var ("ubound", nest
);
546 if (GFC_TYPE_ARRAY_STRIDE (type
, dim
) == NULL_TREE
)
547 GFC_TYPE_ARRAY_STRIDE (type
, dim
) = create_index_var ("stride", nest
);
549 if (GFC_TYPE_ARRAY_OFFSET (type
) == NULL_TREE
)
551 GFC_TYPE_ARRAY_OFFSET (type
) = gfc_create_var_np (gfc_array_index_type
,
554 gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type
));
556 gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type
));
561 /* For some dummy arguments we don't use the actual argument directly.
562 Instead we create a local decl and use that. This allows us to perform
563 initialization, and construct full type information. */
566 gfc_build_dummy_array_decl (gfc_symbol
* sym
, tree dummy
)
576 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
579 /* Add to list of variables if not a fake result variable. */
580 if (sym
->attr
.result
|| sym
->attr
.dummy
)
581 gfc_defer_symbol_init (sym
);
583 type
= TREE_TYPE (dummy
);
584 gcc_assert (TREE_CODE (dummy
) == PARM_DECL
585 && POINTER_TYPE_P (type
));
587 /* Do we know the element size? */
588 known_size
= sym
->ts
.type
!= BT_CHARACTER
589 || INTEGER_CST_P (sym
->ts
.cl
->backend_decl
);
591 if (known_size
&& !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type
)))
593 /* For descriptorless arrays with known element size the actual
594 argument is sufficient. */
595 gcc_assert (GFC_ARRAY_TYPE_P (type
));
596 gfc_build_qualified_array (dummy
, sym
);
600 type
= TREE_TYPE (type
);
601 if (GFC_DESCRIPTOR_TYPE_P (type
))
603 /* Create a decriptorless array pointer. */
606 if (!gfc_option
.flag_repack_arrays
)
608 if (as
->type
== AS_ASSUMED_SIZE
)
613 if (as
->type
== AS_EXPLICIT
)
616 for (n
= 0; n
< as
->rank
; n
++)
620 && as
->upper
[n
]->expr_type
== EXPR_CONSTANT
621 && as
->lower
[n
]->expr_type
== EXPR_CONSTANT
))
629 type
= gfc_typenode_for_spec (&sym
->ts
);
630 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
);
634 /* We now have an expression for the element size, so create a fully
635 qualified type. Reset sym->backend decl or this will just return the
637 sym
->backend_decl
= NULL_TREE
;
638 type
= gfc_sym_type (sym
);
642 ASM_FORMAT_PRIVATE_NAME (name
, IDENTIFIER_POINTER (DECL_NAME (dummy
)), 0);
643 decl
= build_decl (VAR_DECL
, get_identifier (name
), type
);
645 DECL_ARTIFICIAL (decl
) = 1;
646 TREE_PUBLIC (decl
) = 0;
647 TREE_STATIC (decl
) = 0;
648 DECL_EXTERNAL (decl
) = 0;
650 /* We should never get deferred shape arrays here. We used to because of
652 gcc_assert (sym
->as
->type
!= AS_DEFERRED
);
657 GFC_DECL_PARTIAL_PACKED_ARRAY (decl
) = 1;
661 GFC_DECL_PACKED_ARRAY (decl
) = 1;
665 gfc_build_qualified_array (decl
, sym
);
667 if (DECL_LANG_SPECIFIC (dummy
))
668 DECL_LANG_SPECIFIC (decl
) = DECL_LANG_SPECIFIC (dummy
);
670 gfc_allocate_lang_decl (decl
);
672 GFC_DECL_SAVED_DESCRIPTOR (decl
) = dummy
;
674 if (sym
->ns
->proc_name
->backend_decl
== current_function_decl
675 || sym
->attr
.contained
)
676 gfc_add_decl_to_function (decl
);
678 gfc_add_decl_to_parent_function (decl
);
684 /* Return a constant or a variable to use as a string length. Does not
685 add the decl to the current scope. */
688 gfc_create_string_length (gfc_symbol
* sym
)
692 gcc_assert (sym
->ts
.cl
);
693 gfc_conv_const_charlen (sym
->ts
.cl
);
695 if (sym
->ts
.cl
->backend_decl
== NULL_TREE
)
697 char name
[GFC_MAX_MANGLED_SYMBOL_LEN
+ 2];
699 /* Also prefix the mangled name. */
700 strcpy (&name
[1], sym
->name
);
702 length
= build_decl (VAR_DECL
, get_identifier (name
),
703 gfc_charlen_type_node
);
704 DECL_ARTIFICIAL (length
) = 1;
705 TREE_USED (length
) = 1;
706 gfc_defer_symbol_init (sym
);
707 sym
->ts
.cl
->backend_decl
= length
;
710 return sym
->ts
.cl
->backend_decl
;
714 /* Return the decl for a gfc_symbol, create it if it doesn't already
718 gfc_get_symbol_decl (gfc_symbol
* sym
)
721 tree length
= NULL_TREE
;
724 gcc_assert (sym
->attr
.referenced
);
726 if (sym
->ns
&& sym
->ns
->proc_name
->attr
.function
)
727 byref
= gfc_return_by_reference (sym
->ns
->proc_name
);
731 if ((sym
->attr
.dummy
&& ! sym
->attr
.function
) || (sym
->attr
.result
&& byref
))
733 /* Return via extra parameter. */
734 if (sym
->attr
.result
&& byref
735 && !sym
->backend_decl
)
738 DECL_ARGUMENTS (sym
->ns
->proc_name
->backend_decl
);
741 /* Dummy variables should already have been created. */
742 gcc_assert (sym
->backend_decl
);
744 /* Create a character length variable. */
745 if (sym
->ts
.type
== BT_CHARACTER
)
747 if (sym
->ts
.cl
->backend_decl
== NULL_TREE
)
749 length
= gfc_create_string_length (sym
);
750 if (TREE_CODE (length
) != INTEGER_CST
)
752 gfc_finish_var_decl (length
, sym
);
753 gfc_defer_symbol_init (sym
);
758 /* Use a copy of the descriptor for dummy arrays. */
759 if (sym
->attr
.dimension
&& !TREE_USED (sym
->backend_decl
))
762 gfc_build_dummy_array_decl (sym
, sym
->backend_decl
);
765 TREE_USED (sym
->backend_decl
) = 1;
766 return sym
->backend_decl
;
769 if (sym
->backend_decl
)
770 return sym
->backend_decl
;
772 /* Catch function declarations. Only used for actual parameters. */
773 if (sym
->attr
.flavor
== FL_PROCEDURE
)
775 decl
= gfc_get_extern_function_decl (sym
);
779 if (sym
->attr
.intrinsic
)
780 internal_error ("intrinsic variable which isn't a procedure");
782 /* Create string length decl first so that they can be used in the
784 if (sym
->ts
.type
== BT_CHARACTER
)
785 length
= gfc_create_string_length (sym
);
787 /* Create the decl for the variable. */
788 decl
= build_decl (VAR_DECL
, gfc_sym_identifier (sym
), gfc_sym_type (sym
));
790 gfc_set_decl_location (decl
, &sym
->declared_at
);
792 /* Symbols from modules should have their assembler names mangled.
793 This is done here rather than in gfc_finish_var_decl because it
794 is different for string length variables. */
796 SET_DECL_ASSEMBLER_NAME (decl
, gfc_sym_mangled_identifier (sym
));
798 if (sym
->attr
.dimension
)
800 /* Create variables to hold the non-constant bits of array info. */
801 gfc_build_qualified_array (decl
, sym
);
803 /* Remember this variable for allocation/cleanup. */
804 gfc_defer_symbol_init (sym
);
806 if ((sym
->attr
.allocatable
|| !sym
->attr
.dummy
) && !sym
->attr
.pointer
)
807 GFC_DECL_PACKED_ARRAY (decl
) = 1;
810 gfc_finish_var_decl (decl
, sym
);
812 if (sym
->attr
.assign
)
814 gfc_allocate_lang_decl (decl
);
815 GFC_DECL_ASSIGN (decl
) = 1;
816 length
= gfc_create_var (gfc_charlen_type_node
, sym
->name
);
817 GFC_DECL_STRING_LEN (decl
) = length
;
818 GFC_DECL_ASSIGN_ADDR (decl
) = gfc_create_var (pvoid_type_node
, sym
->name
);
819 /* TODO: Need to check we don't change TREE_STATIC (decl) later. */
820 TREE_STATIC (length
) = TREE_STATIC (decl
);
821 /* STRING_LENGTH is also used as flag. Less than -1 means that
822 ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
823 target label's address. Other value is the length of format string
824 and ASSIGN_ADDR is the address of format string. */
825 DECL_INITIAL (length
) = build_int_cst (NULL_TREE
, -2);
828 if (sym
->ts
.type
== BT_CHARACTER
)
830 /* Character variables need special handling. */
831 gfc_allocate_lang_decl (decl
);
833 if (TREE_CODE (length
) != INTEGER_CST
)
835 char name
[GFC_MAX_MANGLED_SYMBOL_LEN
+ 2];
839 /* Also prefix the mangled name for symbols from modules. */
840 strcpy (&name
[1], sym
->name
);
843 IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length
)));
844 SET_DECL_ASSEMBLER_NAME (decl
, get_identifier (name
));
846 gfc_finish_var_decl (length
, sym
);
847 gcc_assert (!sym
->value
);
850 sym
->backend_decl
= decl
;
852 if (TREE_STATIC (decl
) && !sym
->attr
.use_assoc
)
854 /* Add static initializer. */
855 DECL_INITIAL (decl
) = gfc_conv_initializer (sym
->value
, &sym
->ts
,
856 TREE_TYPE (decl
), sym
->attr
.dimension
,
857 sym
->attr
.pointer
|| sym
->attr
.allocatable
);
864 /* Substitute a temporary variable in place of the real one. */
867 gfc_shadow_sym (gfc_symbol
* sym
, tree decl
, gfc_saved_var
* save
)
869 save
->attr
= sym
->attr
;
870 save
->decl
= sym
->backend_decl
;
872 gfc_clear_attr (&sym
->attr
);
873 sym
->attr
.referenced
= 1;
874 sym
->attr
.flavor
= FL_VARIABLE
;
876 sym
->backend_decl
= decl
;
880 /* Restore the original variable. */
883 gfc_restore_sym (gfc_symbol
* sym
, gfc_saved_var
* save
)
885 sym
->attr
= save
->attr
;
886 sym
->backend_decl
= save
->decl
;
890 /* Get a basic decl for an external function. */
893 gfc_get_extern_function_decl (gfc_symbol
* sym
)
898 gfc_intrinsic_sym
*isym
;
900 char s
[GFC_MAX_SYMBOL_LEN
];
904 if (sym
->backend_decl
)
905 return sym
->backend_decl
;
907 /* We should never be creating external decls for alternate entry points.
908 The procedure may be an alternate entry point, but we don't want/need
910 gcc_assert (!(sym
->attr
.entry
|| sym
->attr
.entry_master
));
912 if (sym
->attr
.intrinsic
)
914 /* Call the resolution function to get the actual name. This is
915 a nasty hack which relies on the resolution functions only looking
916 at the first argument. We pass NULL for the second argument
917 otherwise things like AINT get confused. */
918 isym
= gfc_find_function (sym
->name
);
919 gcc_assert (isym
->resolve
.f0
!= NULL
);
921 memset (&e
, 0, sizeof (e
));
922 e
.expr_type
= EXPR_FUNCTION
;
924 memset (&argexpr
, 0, sizeof (argexpr
));
925 gcc_assert (isym
->formal
);
926 argexpr
.ts
= isym
->formal
->ts
;
928 if (isym
->formal
->next
== NULL
)
929 isym
->resolve
.f1 (&e
, &argexpr
);
932 /* All specific intrinsics take one or two arguments. */
933 gcc_assert (isym
->formal
->next
->next
== NULL
);
934 isym
->resolve
.f2 (&e
, &argexpr
, NULL
);
936 sprintf (s
, "specific%s", e
.value
.function
.name
);
937 name
= get_identifier (s
);
942 name
= gfc_sym_identifier (sym
);
943 mangled_name
= gfc_sym_mangled_function_id (sym
);
946 type
= gfc_get_function_type (sym
);
947 fndecl
= build_decl (FUNCTION_DECL
, name
, type
);
949 SET_DECL_ASSEMBLER_NAME (fndecl
, mangled_name
);
950 /* If the return type is a pointer, avoid alias issues by setting
951 DECL_IS_MALLOC to nonzero. This means that the function should be
952 treated as if it were a malloc, meaning it returns a pointer that
954 if (POINTER_TYPE_P (type
))
955 DECL_IS_MALLOC (fndecl
) = 1;
957 /* Set the context of this decl. */
958 if (0 && sym
->ns
&& sym
->ns
->proc_name
)
960 /* TODO: Add external decls to the appropriate scope. */
961 DECL_CONTEXT (fndecl
) = sym
->ns
->proc_name
->backend_decl
;
965 /* Global declaration, e.g. intrinsic subroutine. */
966 DECL_CONTEXT (fndecl
) = NULL_TREE
;
969 DECL_EXTERNAL (fndecl
) = 1;
971 /* This specifies if a function is globally addressable, i.e. it is
972 the opposite of declaring static in C. */
973 TREE_PUBLIC (fndecl
) = 1;
975 /* Set attributes for PURE functions. A call to PURE function in the
976 Fortran 95 sense is both pure and without side effects in the C
978 if (sym
->attr
.pure
|| sym
->attr
.elemental
)
980 if (sym
->attr
.function
)
981 DECL_IS_PURE (fndecl
) = 1;
982 /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
983 parameters and don't use alternate returns (is this
984 allowed?). In that case, calls to them are meaningless, and
985 can be optimized away. See also in build_function_decl(). */
986 TREE_SIDE_EFFECTS (fndecl
) = 0;
989 sym
->backend_decl
= fndecl
;
991 if (DECL_CONTEXT (fndecl
) == NULL_TREE
)
992 pushdecl_top_level (fndecl
);
998 /* Create a declaration for a procedure. For external functions (in the C
999 sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is
1000 a master function with alternate entry points. */
1003 build_function_decl (gfc_symbol
* sym
)
1006 symbol_attribute attr
;
1008 gfc_formal_arglist
*f
;
1010 gcc_assert (!sym
->backend_decl
);
1011 gcc_assert (!sym
->attr
.external
);
1013 /* Set the line and filename. sym->declared_at seems to point to the
1014 last statement for subroutines, but it'll do for now. */
1015 gfc_set_backend_locus (&sym
->declared_at
);
1017 /* Allow only one nesting level. Allow public declarations. */
1018 gcc_assert (current_function_decl
== NULL_TREE
1019 || DECL_CONTEXT (current_function_decl
) == NULL_TREE
);
1021 type
= gfc_get_function_type (sym
);
1022 fndecl
= build_decl (FUNCTION_DECL
, gfc_sym_identifier (sym
), type
);
1024 /* Perform name mangling if this is a top level or module procedure. */
1025 if (current_function_decl
== NULL_TREE
)
1026 SET_DECL_ASSEMBLER_NAME (fndecl
, gfc_sym_mangled_function_id (sym
));
1028 /* Figure out the return type of the declared function, and build a
1029 RESULT_DECL for it. If this is a subroutine with alternate
1030 returns, build a RESULT_DECL for it. */
1033 result_decl
= NULL_TREE
;
1034 /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
1037 if (gfc_return_by_reference (sym
))
1038 type
= void_type_node
;
1041 if (sym
->result
!= sym
)
1042 result_decl
= gfc_sym_identifier (sym
->result
);
1044 type
= TREE_TYPE (TREE_TYPE (fndecl
));
1049 /* Look for alternate return placeholders. */
1050 int has_alternate_returns
= 0;
1051 for (f
= sym
->formal
; f
; f
= f
->next
)
1055 has_alternate_returns
= 1;
1060 if (has_alternate_returns
)
1061 type
= integer_type_node
;
1063 type
= void_type_node
;
1066 result_decl
= build_decl (RESULT_DECL
, result_decl
, type
);
1067 DECL_ARTIFICIAL (result_decl
) = 1;
1068 DECL_IGNORED_P (result_decl
) = 1;
1069 DECL_CONTEXT (result_decl
) = fndecl
;
1070 DECL_RESULT (fndecl
) = result_decl
;
1072 /* Don't call layout_decl for a RESULT_DECL.
1073 layout_decl (result_decl, 0); */
1075 /* If the return type is a pointer, avoid alias issues by setting
1076 DECL_IS_MALLOC to nonzero. This means that the function should be
1077 treated as if it were a malloc, meaning it returns a pointer that
1079 if (POINTER_TYPE_P (type
))
1080 DECL_IS_MALLOC (fndecl
) = 1;
1082 /* Set up all attributes for the function. */
1083 DECL_CONTEXT (fndecl
) = current_function_decl
;
1084 DECL_EXTERNAL (fndecl
) = 0;
1086 /* This specifies if a function is globally visible, i.e. it is
1087 the opposite of declaring static in C. */
1088 if (DECL_CONTEXT (fndecl
) == NULL_TREE
1089 && !sym
->attr
.entry_master
)
1090 TREE_PUBLIC (fndecl
) = 1;
1092 /* TREE_STATIC means the function body is defined here. */
1093 TREE_STATIC (fndecl
) = 1;
1095 /* Set attributes for PURE functions. A call to a PURE function in the
1096 Fortran 95 sense is both pure and without side effects in the C
1098 if (attr
.pure
|| attr
.elemental
)
1100 /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
1101 including a alternate return. In that case it can also be
1102 marked as PURE. See also in gfc_get_extern_function_decl(). */
1104 DECL_IS_PURE (fndecl
) = 1;
1105 TREE_SIDE_EFFECTS (fndecl
) = 0;
1108 /* Layout the function declaration and put it in the binding level
1109 of the current function. */
1112 sym
->backend_decl
= fndecl
;
1116 /* Create the DECL_ARGUMENTS for a procedure. */
1119 create_function_arglist (gfc_symbol
* sym
)
1122 gfc_formal_arglist
*f
;
1129 fndecl
= sym
->backend_decl
;
1131 /* Build formal argument list. Make sure that their TREE_CONTEXT is
1132 the new FUNCTION_DECL node. */
1133 arglist
= NULL_TREE
;
1134 typelist
= TYPE_ARG_TYPES (TREE_TYPE (fndecl
));
1136 if (sym
->attr
.entry_master
)
1138 type
= TREE_VALUE (typelist
);
1139 parm
= build_decl (PARM_DECL
, get_identifier ("__entry"), type
);
1141 DECL_CONTEXT (parm
) = fndecl
;
1142 DECL_ARG_TYPE (parm
) = type
;
1143 TREE_READONLY (parm
) = 1;
1144 gfc_finish_decl (parm
, NULL_TREE
);
1146 arglist
= chainon (arglist
, parm
);
1147 typelist
= TREE_CHAIN (typelist
);
1150 if (gfc_return_by_reference (sym
))
1152 type
= TREE_VALUE (typelist
);
1153 parm
= build_decl (PARM_DECL
, get_identifier ("__result"), type
);
1155 DECL_CONTEXT (parm
) = fndecl
;
1156 DECL_ARG_TYPE (parm
) = type
;
1157 TREE_READONLY (parm
) = 1;
1158 DECL_ARTIFICIAL (parm
) = 1;
1159 gfc_finish_decl (parm
, NULL_TREE
);
1161 arglist
= chainon (arglist
, parm
);
1162 typelist
= TREE_CHAIN (typelist
);
1164 if (sym
->ts
.type
== BT_CHARACTER
)
1166 gfc_allocate_lang_decl (parm
);
1168 /* Length of character result. */
1169 type
= TREE_VALUE (typelist
);
1170 gcc_assert (type
== gfc_charlen_type_node
);
1172 length
= build_decl (PARM_DECL
,
1173 get_identifier (".__result"),
1175 if (!sym
->ts
.cl
->length
)
1177 sym
->ts
.cl
->backend_decl
= length
;
1178 TREE_USED (length
) = 1;
1180 gcc_assert (TREE_CODE (length
) == PARM_DECL
);
1181 arglist
= chainon (arglist
, length
);
1182 typelist
= TREE_CHAIN (typelist
);
1183 DECL_CONTEXT (length
) = fndecl
;
1184 DECL_ARG_TYPE (length
) = type
;
1185 TREE_READONLY (length
) = 1;
1186 DECL_ARTIFICIAL (length
) = 1;
1187 gfc_finish_decl (length
, NULL_TREE
);
1191 for (f
= sym
->formal
; f
; f
= f
->next
)
1193 if (f
->sym
!= NULL
) /* ignore alternate returns. */
1197 type
= TREE_VALUE (typelist
);
1199 /* Build a the argument declaration. */
1200 parm
= build_decl (PARM_DECL
,
1201 gfc_sym_identifier (f
->sym
), type
);
1203 /* Fill in arg stuff. */
1204 DECL_CONTEXT (parm
) = fndecl
;
1205 DECL_ARG_TYPE (parm
) = type
;
1206 DECL_ARG_TYPE_AS_WRITTEN (parm
) = type
;
1207 /* All implementation args are read-only. */
1208 TREE_READONLY (parm
) = 1;
1210 gfc_finish_decl (parm
, NULL_TREE
);
1212 f
->sym
->backend_decl
= parm
;
1214 arglist
= chainon (arglist
, parm
);
1215 typelist
= TREE_CHAIN (typelist
);
1219 /* Add the hidden string length parameters. */
1221 for (f
= sym
->formal
; f
; f
= f
->next
)
1223 char name
[GFC_MAX_SYMBOL_LEN
+ 2];
1224 /* Ignore alternate returns. */
1228 if (f
->sym
->ts
.type
!= BT_CHARACTER
)
1231 parm
= f
->sym
->backend_decl
;
1232 type
= TREE_VALUE (typelist
);
1233 gcc_assert (type
== gfc_charlen_type_node
);
1235 strcpy (&name
[1], f
->sym
->name
);
1237 length
= build_decl (PARM_DECL
, get_identifier (name
), type
);
1239 arglist
= chainon (arglist
, length
);
1240 DECL_CONTEXT (length
) = fndecl
;
1241 DECL_ARTIFICIAL (length
) = 1;
1242 DECL_ARG_TYPE (length
) = type
;
1243 TREE_READONLY (length
) = 1;
1244 gfc_finish_decl (length
, NULL_TREE
);
1246 /* TODO: Check string lengths when -fbounds-check. */
1248 /* Use the passed value for assumed length variables. */
1249 if (!f
->sym
->ts
.cl
->length
)
1251 TREE_USED (length
) = 1;
1252 if (!f
->sym
->ts
.cl
->backend_decl
)
1253 f
->sym
->ts
.cl
->backend_decl
= length
;
1256 /* there is already another variable using this
1257 gfc_charlen node, build a new one for this variable
1258 and chain it into the list of gfc_charlens.
1259 This happens for e.g. in the case
1261 since CHARACTER declarations on the same line share
1262 the same gfc_charlen node. */
1265 cl
= gfc_get_charlen ();
1266 cl
->backend_decl
= length
;
1267 cl
->next
= f
->sym
->ts
.cl
->next
;
1268 f
->sym
->ts
.cl
->next
= cl
;
1273 parm
= TREE_CHAIN (parm
);
1274 typelist
= TREE_CHAIN (typelist
);
1277 gcc_assert (TREE_VALUE (typelist
) == void_type_node
);
1278 DECL_ARGUMENTS (fndecl
) = arglist
;
1281 /* Convert FNDECL's code to GIMPLE and handle any nested functions. */
1284 gfc_gimplify_function (tree fndecl
)
1286 struct cgraph_node
*cgn
;
1288 gimplify_function_tree (fndecl
);
1289 dump_function (TDI_generic
, fndecl
);
1291 /* Convert all nested functions to GIMPLE now. We do things in this order
1292 so that items like VLA sizes are expanded properly in the context of the
1293 correct function. */
1294 cgn
= cgraph_node (fndecl
);
1295 for (cgn
= cgn
->nested
; cgn
; cgn
= cgn
->next_nested
)
1296 gfc_gimplify_function (cgn
->decl
);
1300 /* Do the setup necessary before generating the body of a function. */
1303 trans_function_start (gfc_symbol
* sym
)
1307 fndecl
= sym
->backend_decl
;
1309 /* Let GCC know the current scope is this function. */
1310 current_function_decl
= fndecl
;
1312 /* Let the world know what we're about to do. */
1313 announce_function (fndecl
);
1315 if (DECL_CONTEXT (fndecl
) == NULL_TREE
)
1317 /* Create RTL for function declaration. */
1318 rest_of_decl_compilation (fndecl
, 1, 0);
1321 /* Create RTL for function definition. */
1322 make_decl_rtl (fndecl
);
1324 init_function_start (fndecl
);
1326 /* Even though we're inside a function body, we still don't want to
1327 call expand_expr to calculate the size of a variable-sized array.
1328 We haven't necessarily assigned RTL to all variables yet, so it's
1329 not safe to try to expand expressions involving them. */
1330 cfun
->x_dont_save_pending_sizes_p
= 1;
1332 /* function.c requires a push at the start of the function. */
1336 /* Create thunks for alternate entry points. */
1339 build_entry_thunks (gfc_namespace
* ns
)
1341 gfc_formal_arglist
*formal
;
1342 gfc_formal_arglist
*thunk_formal
;
1344 gfc_symbol
*thunk_sym
;
1352 /* This should always be a toplevel function. */
1353 gcc_assert (current_function_decl
== NULL_TREE
);
1355 gfc_get_backend_locus (&old_loc
);
1356 for (el
= ns
->entries
; el
; el
= el
->next
)
1358 thunk_sym
= el
->sym
;
1360 build_function_decl (thunk_sym
);
1361 create_function_arglist (thunk_sym
);
1363 trans_function_start (thunk_sym
);
1365 thunk_fndecl
= thunk_sym
->backend_decl
;
1367 gfc_start_block (&body
);
1369 /* Pass extra parameter identifying this entry point. */
1370 tmp
= build_int_cst (gfc_array_index_type
, el
->id
);
1371 args
= tree_cons (NULL_TREE
, tmp
, NULL_TREE
);
1372 string_args
= NULL_TREE
;
1374 /* TODO: Pass return by reference parameters. */
1375 if (ns
->proc_name
->attr
.function
)
1376 gfc_todo_error ("Functons with multiple entry points");
1378 for (formal
= ns
->proc_name
->formal
; formal
; formal
= formal
->next
)
1380 /* We don't have a clever way of identifying arguments, so resort to
1381 a brute-force search. */
1382 for (thunk_formal
= thunk_sym
->formal
;
1384 thunk_formal
= thunk_formal
->next
)
1386 if (thunk_formal
->sym
== formal
->sym
)
1392 /* Pass the argument. */
1393 args
= tree_cons (NULL_TREE
, thunk_formal
->sym
->backend_decl
,
1395 if (formal
->sym
->ts
.type
== BT_CHARACTER
)
1397 tmp
= thunk_formal
->sym
->ts
.cl
->backend_decl
;
1398 string_args
= tree_cons (NULL_TREE
, tmp
, string_args
);
1403 /* Pass NULL for a missing argument. */
1404 args
= tree_cons (NULL_TREE
, null_pointer_node
, args
);
1405 if (formal
->sym
->ts
.type
== BT_CHARACTER
)
1407 tmp
= convert (gfc_charlen_type_node
, integer_zero_node
);
1408 string_args
= tree_cons (NULL_TREE
, tmp
, string_args
);
1413 /* Call the master function. */
1414 args
= nreverse (args
);
1415 args
= chainon (args
, nreverse (string_args
));
1416 tmp
= ns
->proc_name
->backend_decl
;
1417 tmp
= gfc_build_function_call (tmp
, args
);
1418 /* TODO: function return value. */
1419 gfc_add_expr_to_block (&body
, tmp
);
1421 /* Finish off this function and send it for code generation. */
1422 DECL_SAVED_TREE (thunk_fndecl
) = gfc_finish_block (&body
);
1424 BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl
)) = thunk_fndecl
;
1426 /* Output the GENERIC tree. */
1427 dump_function (TDI_original
, thunk_fndecl
);
1429 /* Store the end of the function, so that we get good line number
1430 info for the epilogue. */
1431 cfun
->function_end_locus
= input_location
;
1433 /* We're leaving the context of this function, so zap cfun.
1434 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
1435 tree_rest_of_compilation. */
1438 current_function_decl
= NULL_TREE
;
1440 gfc_gimplify_function (thunk_fndecl
);
1441 cgraph_finalize_function (thunk_fndecl
, false);
1443 /* We share the symbols in the formal argument list with other entry
1444 points and the master function. Clear them so that they are
1445 recreated for each function. */
1446 for (formal
= thunk_sym
->formal
; formal
; formal
= formal
->next
)
1448 formal
->sym
->backend_decl
= NULL_TREE
;
1449 if (formal
->sym
->ts
.type
== BT_CHARACTER
)
1450 formal
->sym
->ts
.cl
->backend_decl
= NULL_TREE
;
1454 gfc_set_backend_locus (&old_loc
);
1458 /* Create a decl for a function, and create any thunks for alternate entry
1462 gfc_create_function_decl (gfc_namespace
* ns
)
1464 /* Create a declaration for the master function. */
1465 build_function_decl (ns
->proc_name
);
1467 /* Compile the entry thunks. */
1469 build_entry_thunks (ns
);
1471 /* Now create the read argument list. */
1472 create_function_arglist (ns
->proc_name
);
1475 /* Return the decl used to hold the function return value. */
1478 gfc_get_fake_result_decl (gfc_symbol
* sym
)
1483 char name
[GFC_MAX_SYMBOL_LEN
+ 10];
1485 if (current_fake_result_decl
!= NULL_TREE
)
1486 return current_fake_result_decl
;
1488 /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
1493 if (sym
->ts
.type
== BT_CHARACTER
1494 && !sym
->ts
.cl
->backend_decl
)
1496 length
= gfc_create_string_length (sym
);
1497 gfc_finish_var_decl (length
, sym
);
1500 if (gfc_return_by_reference (sym
))
1502 decl
= DECL_ARGUMENTS (sym
->backend_decl
);
1504 TREE_USED (decl
) = 1;
1506 decl
= gfc_build_dummy_array_decl (sym
, decl
);
1510 sprintf (name
, "__result_%.20s",
1511 IDENTIFIER_POINTER (DECL_NAME (current_function_decl
)));
1513 decl
= build_decl (VAR_DECL
, get_identifier (name
),
1514 TREE_TYPE (TREE_TYPE (current_function_decl
)));
1516 DECL_ARTIFICIAL (decl
) = 1;
1517 DECL_EXTERNAL (decl
) = 0;
1518 TREE_PUBLIC (decl
) = 0;
1519 TREE_USED (decl
) = 1;
1521 layout_decl (decl
, 0);
1523 gfc_add_decl_to_function (decl
);
1526 current_fake_result_decl
= decl
;
1532 /* Builds a function decl. The remaining parameters are the types of the
1533 function arguments. Negative nargs indicates a varargs function. */
1536 gfc_build_library_function_decl (tree name
, tree rettype
, int nargs
, ...)
1545 /* Library functions must be declared with global scope. */
1546 gcc_assert (current_function_decl
== NULL_TREE
);
1548 va_start (p
, nargs
);
1551 /* Create a list of the argument types. */
1552 for (arglist
= NULL_TREE
, n
= abs (nargs
); n
> 0; n
--)
1554 argtype
= va_arg (p
, tree
);
1555 arglist
= gfc_chainon_list (arglist
, argtype
);
1560 /* Terminate the list. */
1561 arglist
= gfc_chainon_list (arglist
, void_type_node
);
1564 /* Build the function type and decl. */
1565 fntype
= build_function_type (rettype
, arglist
);
1566 fndecl
= build_decl (FUNCTION_DECL
, name
, fntype
);
1568 /* Mark this decl as external. */
1569 DECL_EXTERNAL (fndecl
) = 1;
1570 TREE_PUBLIC (fndecl
) = 1;
1576 rest_of_decl_compilation (fndecl
, 1, 0);
1582 gfc_build_intrinsic_function_decls (void)
1584 tree gfc_int4_type_node
= gfc_get_int_type (4);
1585 tree gfc_int8_type_node
= gfc_get_int_type (8);
1586 tree gfc_logical4_type_node
= gfc_get_logical_type (4);
1587 tree gfc_real4_type_node
= gfc_get_real_type (4);
1588 tree gfc_real8_type_node
= gfc_get_real_type (8);
1589 tree gfc_complex4_type_node
= gfc_get_complex_type (4);
1590 tree gfc_complex8_type_node
= gfc_get_complex_type (8);
1592 /* String functions. */
1593 gfor_fndecl_copy_string
=
1594 gfc_build_library_function_decl (get_identifier (PREFIX("copy_string")),
1597 gfc_charlen_type_node
, pchar_type_node
,
1598 gfc_charlen_type_node
, pchar_type_node
);
1600 gfor_fndecl_compare_string
=
1601 gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),
1604 gfc_charlen_type_node
, pchar_type_node
,
1605 gfc_charlen_type_node
, pchar_type_node
);
1607 gfor_fndecl_concat_string
=
1608 gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),
1611 gfc_charlen_type_node
, pchar_type_node
,
1612 gfc_charlen_type_node
, pchar_type_node
,
1613 gfc_charlen_type_node
, pchar_type_node
);
1615 gfor_fndecl_string_len_trim
=
1616 gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")),
1618 2, gfc_charlen_type_node
,
1621 gfor_fndecl_string_index
=
1622 gfc_build_library_function_decl (get_identifier (PREFIX("string_index")),
1624 5, gfc_charlen_type_node
, pchar_type_node
,
1625 gfc_charlen_type_node
, pchar_type_node
,
1626 gfc_logical4_type_node
);
1628 gfor_fndecl_string_scan
=
1629 gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")),
1631 5, gfc_charlen_type_node
, pchar_type_node
,
1632 gfc_charlen_type_node
, pchar_type_node
,
1633 gfc_logical4_type_node
);
1635 gfor_fndecl_string_verify
=
1636 gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")),
1638 5, gfc_charlen_type_node
, pchar_type_node
,
1639 gfc_charlen_type_node
, pchar_type_node
,
1640 gfc_logical4_type_node
);
1642 gfor_fndecl_string_trim
=
1643 gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),
1646 build_pointer_type (gfc_charlen_type_node
),
1648 gfc_charlen_type_node
,
1651 gfor_fndecl_string_repeat
=
1652 gfc_build_library_function_decl (get_identifier (PREFIX("string_repeat")),
1656 gfc_charlen_type_node
,
1658 gfc_int4_type_node
);
1660 gfor_fndecl_adjustl
=
1661 gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),
1665 gfc_charlen_type_node
, pchar_type_node
);
1667 gfor_fndecl_adjustr
=
1668 gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")),
1672 gfc_charlen_type_node
, pchar_type_node
);
1674 gfor_fndecl_si_kind
=
1675 gfc_build_library_function_decl (get_identifier ("selected_int_kind"),
1680 gfor_fndecl_sr_kind
=
1681 gfc_build_library_function_decl (get_identifier ("selected_real_kind"),
1686 /* Power functions. */
1692 static int kinds
[2] = {4, 8};
1693 char name
[PREFIX_LEN
+ 10]; /* _gfortran_pow_?n_?n */
1695 for (ikind
=0; ikind
< 2; ikind
++)
1697 itype
= gfc_get_int_type (kinds
[ikind
]);
1698 for (kind
= 0; kind
< 2; kind
++)
1700 type
= gfc_get_int_type (kinds
[kind
]);
1701 sprintf(name
, PREFIX("pow_i%d_i%d"), kinds
[kind
], kinds
[ikind
]);
1702 gfor_fndecl_math_powi
[kind
][ikind
].integer
=
1703 gfc_build_library_function_decl (get_identifier (name
),
1704 type
, 2, type
, itype
);
1706 type
= gfc_get_real_type (kinds
[kind
]);
1707 sprintf(name
, PREFIX("pow_r%d_i%d"), kinds
[kind
], kinds
[ikind
]);
1708 gfor_fndecl_math_powi
[kind
][ikind
].real
=
1709 gfc_build_library_function_decl (get_identifier (name
),
1710 type
, 2, type
, itype
);
1712 type
= gfc_get_complex_type (kinds
[kind
]);
1713 sprintf(name
, PREFIX("pow_c%d_i%d"), kinds
[kind
], kinds
[ikind
]);
1714 gfor_fndecl_math_powi
[kind
][ikind
].cmplx
=
1715 gfc_build_library_function_decl (get_identifier (name
),
1716 type
, 2, type
, itype
);
1721 gfor_fndecl_math_cpowf
=
1722 gfc_build_library_function_decl (get_identifier ("cpowf"),
1723 gfc_complex4_type_node
,
1724 1, gfc_complex4_type_node
);
1725 gfor_fndecl_math_cpow
=
1726 gfc_build_library_function_decl (get_identifier ("cpow"),
1727 gfc_complex8_type_node
,
1728 1, gfc_complex8_type_node
);
1729 gfor_fndecl_math_ishftc4
=
1730 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")),
1732 3, gfc_int4_type_node
,
1733 gfc_int4_type_node
, gfc_int4_type_node
);
1734 gfor_fndecl_math_ishftc8
=
1735 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")),
1737 3, gfc_int8_type_node
,
1738 gfc_int8_type_node
, gfc_int8_type_node
);
1739 gfor_fndecl_math_exponent4
=
1740 gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r4")),
1742 1, gfc_real4_type_node
);
1743 gfor_fndecl_math_exponent8
=
1744 gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r8")),
1746 1, gfc_real8_type_node
);
1748 /* Other functions. */
1750 gfc_build_library_function_decl (get_identifier (PREFIX("size0")),
1751 gfc_array_index_type
,
1752 1, pvoid_type_node
);
1754 gfc_build_library_function_decl (get_identifier (PREFIX("size1")),
1755 gfc_array_index_type
,
1757 gfc_array_index_type
);
1760 gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),
1766 /* Make prototypes for runtime library functions. */
1769 gfc_build_builtin_function_decls (void)
1771 tree gfc_int4_type_node
= gfc_get_int_type (4);
1772 tree gfc_int8_type_node
= gfc_get_int_type (8);
1773 tree gfc_logical4_type_node
= gfc_get_logical_type (4);
1775 gfor_fndecl_internal_malloc
=
1776 gfc_build_library_function_decl (get_identifier (PREFIX("internal_malloc")),
1777 pvoid_type_node
, 1, gfc_int4_type_node
);
1779 gfor_fndecl_internal_malloc64
=
1780 gfc_build_library_function_decl (get_identifier
1781 (PREFIX("internal_malloc64")),
1782 pvoid_type_node
, 1, gfc_int8_type_node
);
1784 gfor_fndecl_internal_free
=
1785 gfc_build_library_function_decl (get_identifier (PREFIX("internal_free")),
1786 void_type_node
, 1, pvoid_type_node
);
1788 gfor_fndecl_allocate
=
1789 gfc_build_library_function_decl (get_identifier (PREFIX("allocate")),
1790 void_type_node
, 2, ppvoid_type_node
,
1791 gfc_int4_type_node
);
1793 gfor_fndecl_allocate64
=
1794 gfc_build_library_function_decl (get_identifier (PREFIX("allocate64")),
1795 void_type_node
, 2, ppvoid_type_node
,
1796 gfc_int8_type_node
);
1798 gfor_fndecl_deallocate
=
1799 gfc_build_library_function_decl (get_identifier (PREFIX("deallocate")),
1800 void_type_node
, 1, ppvoid_type_node
);
1802 gfor_fndecl_stop_numeric
=
1803 gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
1804 void_type_node
, 1, gfc_int4_type_node
);
1806 gfor_fndecl_stop_string
=
1807 gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),
1808 void_type_node
, 2, pchar_type_node
,
1809 gfc_int4_type_node
);
1811 gfor_fndecl_pause_numeric
=
1812 gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
1813 void_type_node
, 1, gfc_int4_type_node
);
1815 gfor_fndecl_pause_string
=
1816 gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")),
1817 void_type_node
, 2, pchar_type_node
,
1818 gfc_int4_type_node
);
1820 gfor_fndecl_select_string
=
1821 gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
1822 pvoid_type_node
, 0);
1824 gfor_fndecl_runtime_error
=
1825 gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
1828 pchar_type_node
, pchar_type_node
,
1829 gfc_int4_type_node
);
1831 gfor_fndecl_in_pack
= gfc_build_library_function_decl (
1832 get_identifier (PREFIX("internal_pack")),
1833 pvoid_type_node
, 1, pvoid_type_node
);
1835 gfor_fndecl_in_unpack
= gfc_build_library_function_decl (
1836 get_identifier (PREFIX("internal_unpack")),
1837 pvoid_type_node
, 1, pvoid_type_node
);
1839 gfor_fndecl_associated
=
1840 gfc_build_library_function_decl (
1841 get_identifier (PREFIX("associated")),
1842 gfc_logical4_type_node
,
1847 gfc_build_intrinsic_function_decls ();
1848 gfc_build_intrinsic_lib_fndecls ();
1849 gfc_build_io_library_fndecls ();
1853 /* Evaluate the length of dummy character variables. */
1856 gfc_trans_dummy_character (gfc_charlen
* cl
, tree fnbody
)
1860 gfc_finish_decl (cl
->backend_decl
, NULL_TREE
);
1862 gfc_start_block (&body
);
1864 /* Evaluate the string length expression. */
1865 gfc_trans_init_string_length (cl
, &body
);
1867 gfc_add_expr_to_block (&body
, fnbody
);
1868 return gfc_finish_block (&body
);
1872 /* Allocate and cleanup an automatic character variable. */
1875 gfc_trans_auto_character_variable (gfc_symbol
* sym
, tree fnbody
)
1881 gcc_assert (sym
->backend_decl
);
1882 gcc_assert (sym
->ts
.cl
&& sym
->ts
.cl
->length
);
1884 gfc_start_block (&body
);
1886 /* Evaluate the string length expression. */
1887 gfc_trans_init_string_length (sym
->ts
.cl
, &body
);
1889 decl
= sym
->backend_decl
;
1891 /* Emit a DECL_EXPR for this variable, which will cause the
1892 gimplifier to allocate storage, and all that good stuff. */
1893 tmp
= build1 (DECL_EXPR
, TREE_TYPE (decl
), decl
);
1894 gfc_add_expr_to_block (&body
, tmp
);
1896 gfc_add_expr_to_block (&body
, fnbody
);
1897 return gfc_finish_block (&body
);
1901 /* Generate function entry and exit code, and add it to the function body.
1903 Allocation and initialization of array variables.
1904 Allocation of character string variables.
1905 Initialization and possibly repacking of dummy arrays. */
1908 gfc_trans_deferred_vars (gfc_symbol
* proc_sym
, tree fnbody
)
1913 /* Deal with implicit return variables. Explicit return variables will
1914 already have been added. */
1915 if (gfc_return_by_reference (proc_sym
) && proc_sym
->result
== proc_sym
)
1917 if (!current_fake_result_decl
)
1919 warning (0, "Function does not return a value");
1925 fnbody
= gfc_trans_dummy_array_bias (proc_sym
,
1926 current_fake_result_decl
,
1929 else if (proc_sym
->ts
.type
== BT_CHARACTER
)
1931 if (TREE_CODE (proc_sym
->ts
.cl
->backend_decl
) == VAR_DECL
)
1932 fnbody
= gfc_trans_dummy_character (proc_sym
->ts
.cl
, fnbody
);
1935 gfc_todo_error ("Deferred non-array return by reference");
1938 for (sym
= proc_sym
->tlink
; sym
!= proc_sym
; sym
= sym
->tlink
)
1940 if (sym
->attr
.dimension
)
1942 switch (sym
->as
->type
)
1945 if (sym
->attr
.dummy
|| sym
->attr
.result
)
1947 gfc_trans_dummy_array_bias (sym
, sym
->backend_decl
, fnbody
);
1948 else if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1950 if (TREE_STATIC (sym
->backend_decl
))
1951 gfc_trans_static_array_pointer (sym
);
1953 fnbody
= gfc_trans_deferred_array (sym
, fnbody
);
1957 gfc_get_backend_locus (&loc
);
1958 gfc_set_backend_locus (&sym
->declared_at
);
1959 fnbody
= gfc_trans_auto_array_allocation (sym
->backend_decl
,
1961 gfc_set_backend_locus (&loc
);
1965 case AS_ASSUMED_SIZE
:
1966 /* Must be a dummy parameter. */
1967 gcc_assert (sym
->attr
.dummy
);
1969 /* We should always pass assumed size arrays the g77 way. */
1970 fnbody
= gfc_trans_g77_array (sym
, fnbody
);
1973 case AS_ASSUMED_SHAPE
:
1974 /* Must be a dummy parameter. */
1975 gcc_assert (sym
->attr
.dummy
);
1977 fnbody
= gfc_trans_dummy_array_bias (sym
, sym
->backend_decl
,
1982 fnbody
= gfc_trans_deferred_array (sym
, fnbody
);
1989 else if (sym
->ts
.type
== BT_CHARACTER
)
1991 gfc_get_backend_locus (&loc
);
1992 gfc_set_backend_locus (&sym
->declared_at
);
1993 if (sym
->attr
.dummy
|| sym
->attr
.result
)
1994 fnbody
= gfc_trans_dummy_character (sym
->ts
.cl
, fnbody
);
1996 fnbody
= gfc_trans_auto_character_variable (sym
, fnbody
);
1997 gfc_set_backend_locus (&loc
);
2007 /* Output an initialized decl for a module variable. */
2010 gfc_create_module_variable (gfc_symbol
* sym
)
2014 /* Only output symbols from this module. */
2015 if (sym
->ns
!= module_namespace
)
2017 /* I don't think this should ever happen. */
2018 internal_error ("module symbol %s in wrong namespace", sym
->name
);
2021 /* Only output variables and array valued parameters. */
2022 if (sym
->attr
.flavor
!= FL_VARIABLE
2023 && (sym
->attr
.flavor
!= FL_PARAMETER
|| sym
->attr
.dimension
== 0))
2026 /* Don't generate variables from other modules. Variables from
2027 COMMONs will already have been generated. */
2028 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
2031 if (sym
->backend_decl
)
2032 internal_error ("backend decl for module variable %s already exists",
2035 /* We always want module variables to be created. */
2036 sym
->attr
.referenced
= 1;
2037 /* Create the decl. */
2038 decl
= gfc_get_symbol_decl (sym
);
2040 /* Create the variable. */
2042 rest_of_decl_compilation (decl
, 1, 0);
2044 /* Also add length of strings. */
2045 if (sym
->ts
.type
== BT_CHARACTER
)
2049 length
= sym
->ts
.cl
->backend_decl
;
2050 if (!INTEGER_CST_P (length
))
2053 rest_of_decl_compilation (length
, 1, 0);
2059 /* Generate all the required code for module variables. */
2062 gfc_generate_module_vars (gfc_namespace
* ns
)
2064 module_namespace
= ns
;
2066 /* Check if the frontend left the namespace in a reasonable state. */
2067 gcc_assert (ns
->proc_name
&& !ns
->proc_name
->tlink
);
2069 /* Generate COMMON blocks. */
2070 gfc_trans_common (ns
);
2072 /* Create decls for all the module variables. */
2073 gfc_traverse_ns (ns
, gfc_create_module_variable
);
2077 gfc_generate_contained_functions (gfc_namespace
* parent
)
2081 /* We create all the prototypes before generating any code. */
2082 for (ns
= parent
->contained
; ns
; ns
= ns
->sibling
)
2084 /* Skip namespaces from used modules. */
2085 if (ns
->parent
!= parent
)
2088 gfc_create_function_decl (ns
);
2091 for (ns
= parent
->contained
; ns
; ns
= ns
->sibling
)
2093 /* Skip namespaces from used modules. */
2094 if (ns
->parent
!= parent
)
2097 gfc_generate_function_code (ns
);
2102 /* Generate decls for all local variables. We do this to ensure correct
2103 handling of expressions which only appear in the specification of
2107 generate_local_decl (gfc_symbol
* sym
)
2109 if (sym
->attr
.flavor
== FL_VARIABLE
)
2111 if (sym
->attr
.referenced
)
2112 gfc_get_symbol_decl (sym
);
2113 else if (sym
->attr
.dummy
&& warn_unused_parameter
)
2114 warning (0, "unused parameter %qs", sym
->name
);
2115 /* Warn for unused variables, but not if they're inside a common
2116 block or are use-associated. */
2117 else if (warn_unused_variable
2118 && !(sym
->attr
.in_common
|| sym
->attr
.use_assoc
))
2119 warning (0, "unused variable %qs", sym
->name
);
2124 generate_local_vars (gfc_namespace
* ns
)
2126 gfc_traverse_ns (ns
, generate_local_decl
);
2130 /* Generate a switch statement to jump to the correct entry point. Also
2131 creates the label decls for the entry points. */
2134 gfc_trans_entry_master_switch (gfc_entry_list
* el
)
2141 gfc_init_block (&block
);
2142 for (; el
; el
= el
->next
)
2144 /* Add the case label. */
2145 label
= gfc_build_label_decl (NULL_TREE
);
2146 val
= build_int_cst (gfc_array_index_type
, el
->id
);
2147 tmp
= build3_v (CASE_LABEL_EXPR
, val
, NULL_TREE
, label
);
2148 gfc_add_expr_to_block (&block
, tmp
);
2150 /* And jump to the actual entry point. */
2151 label
= gfc_build_label_decl (NULL_TREE
);
2152 tmp
= build1_v (GOTO_EXPR
, label
);
2153 gfc_add_expr_to_block (&block
, tmp
);
2155 /* Save the label decl. */
2158 tmp
= gfc_finish_block (&block
);
2159 /* The first argument selects the entry point. */
2160 val
= DECL_ARGUMENTS (current_function_decl
);
2161 tmp
= build3_v (SWITCH_EXPR
, val
, tmp
, NULL_TREE
);
2166 /* Generate code for a function. */
2169 gfc_generate_function_code (gfc_namespace
* ns
)
2180 sym
= ns
->proc_name
;
2182 /* Check that the frontend isn't still using this. */
2183 gcc_assert (sym
->tlink
== NULL
);
2186 /* Create the declaration for functions with global scope. */
2187 if (!sym
->backend_decl
)
2188 gfc_create_function_decl (ns
);
2190 fndecl
= sym
->backend_decl
;
2191 old_context
= current_function_decl
;
2195 push_function_context ();
2196 saved_parent_function_decls
= saved_function_decls
;
2197 saved_function_decls
= NULL_TREE
;
2200 trans_function_start (sym
);
2202 /* Will be created as needed. */
2203 current_fake_result_decl
= NULL_TREE
;
2205 gfc_start_block (&block
);
2207 gfc_generate_contained_functions (ns
);
2209 /* Translate COMMON blocks. */
2210 gfc_trans_common (ns
);
2212 generate_local_vars (ns
);
2214 current_function_return_label
= NULL
;
2216 /* Now generate the code for the body of this function. */
2217 gfc_init_block (&body
);
2219 if (TREE_TYPE (DECL_RESULT (fndecl
)) != void_type_node
2220 && sym
->attr
.subroutine
)
2222 tree alternate_return
;
2223 alternate_return
= gfc_get_fake_result_decl (sym
);
2224 gfc_add_modify_expr (&body
, alternate_return
, integer_zero_node
);
2229 /* Jump to the correct entry point. */
2230 tmp
= gfc_trans_entry_master_switch (ns
->entries
);
2231 gfc_add_expr_to_block (&body
, tmp
);
2234 tmp
= gfc_trans_code (ns
->code
);
2235 gfc_add_expr_to_block (&body
, tmp
);
2237 /* Add a return label if needed. */
2238 if (current_function_return_label
)
2240 tmp
= build1_v (LABEL_EXPR
, current_function_return_label
);
2241 gfc_add_expr_to_block (&body
, tmp
);
2244 tmp
= gfc_finish_block (&body
);
2245 /* Add code to create and cleanup arrays. */
2246 tmp
= gfc_trans_deferred_vars (sym
, tmp
);
2247 gfc_add_expr_to_block (&block
, tmp
);
2249 if (TREE_TYPE (DECL_RESULT (fndecl
)) != void_type_node
)
2251 if (sym
->attr
.subroutine
|| sym
== sym
->result
)
2253 result
= current_fake_result_decl
;
2254 current_fake_result_decl
= NULL_TREE
;
2257 result
= sym
->result
->backend_decl
;
2259 if (result
== NULL_TREE
)
2260 warning (0, "Function return value not set");
2263 /* Set the return value to the dummy result variable. */
2264 tmp
= build2 (MODIFY_EXPR
, TREE_TYPE (result
),
2265 DECL_RESULT (fndecl
), result
);
2266 tmp
= build1_v (RETURN_EXPR
, tmp
);
2267 gfc_add_expr_to_block (&block
, tmp
);
2271 /* Add all the decls we created during processing. */
2272 decl
= saved_function_decls
;
2277 next
= TREE_CHAIN (decl
);
2278 TREE_CHAIN (decl
) = NULL_TREE
;
2282 saved_function_decls
= NULL_TREE
;
2284 DECL_SAVED_TREE (fndecl
) = gfc_finish_block (&block
);
2286 /* Finish off this function and send it for code generation. */
2288 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl
)) = fndecl
;
2290 /* Output the GENERIC tree. */
2291 dump_function (TDI_original
, fndecl
);
2293 /* Store the end of the function, so that we get good line number
2294 info for the epilogue. */
2295 cfun
->function_end_locus
= input_location
;
2297 /* We're leaving the context of this function, so zap cfun.
2298 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
2299 tree_rest_of_compilation. */
2304 pop_function_context ();
2305 saved_function_decls
= saved_parent_function_decls
;
2307 current_function_decl
= old_context
;
2309 if (decl_function_context (fndecl
))
2310 /* Register this function with cgraph just far enough to get it
2311 added to our parent's nested function list. */
2312 (void) cgraph_node (fndecl
);
2315 gfc_gimplify_function (fndecl
);
2316 cgraph_finalize_function (fndecl
, false);
2321 gfc_generate_constructors (void)
2323 gcc_assert (gfc_static_ctors
== NULL_TREE
);
2331 if (gfc_static_ctors
== NULL_TREE
)
2334 fnname
= get_file_function_name ('I');
2335 type
= build_function_type (void_type_node
,
2336 gfc_chainon_list (NULL_TREE
, void_type_node
));
2338 fndecl
= build_decl (FUNCTION_DECL
, fnname
, type
);
2339 TREE_PUBLIC (fndecl
) = 1;
2341 decl
= build_decl (RESULT_DECL
, NULL_TREE
, void_type_node
);
2342 DECL_ARTIFICIAL (decl
) = 1;
2343 DECL_IGNORED_P (decl
) = 1;
2344 DECL_CONTEXT (decl
) = fndecl
;
2345 DECL_RESULT (fndecl
) = decl
;
2349 current_function_decl
= fndecl
;
2351 rest_of_decl_compilation (fndecl
, 1, 0);
2353 make_decl_rtl (fndecl
);
2355 init_function_start (fndecl
);
2359 for (; gfc_static_ctors
; gfc_static_ctors
= TREE_CHAIN (gfc_static_ctors
))
2362 gfc_build_function_call (TREE_VALUE (gfc_static_ctors
), NULL_TREE
);
2363 DECL_SAVED_TREE (fndecl
) = build_stmt (EXPR_STMT
, tmp
);
2368 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl
)) = fndecl
;
2370 free_after_parsing (cfun
);
2371 free_after_compilation (cfun
);
2373 tree_rest_of_compilation (fndecl
);
2375 current_function_decl
= NULL_TREE
;
2379 /* Translates a BLOCK DATA program unit. This means emitting the
2380 commons contained therein plus their initializations. We also emit
2381 a globally visible symbol to make sure that each BLOCK DATA program
2382 unit remains unique. */
2385 gfc_generate_block_data (gfc_namespace
* ns
)
2390 /* Tell the backend the source location of the block data. */
2392 gfc_set_backend_locus (&ns
->proc_name
->declared_at
);
2394 gfc_set_backend_locus (&gfc_current_locus
);
2396 /* Process the DATA statements. */
2397 gfc_trans_common (ns
);
2399 /* Create a global symbol with the mane of the block data. This is to
2400 generate linker errors if the same name is used twice. It is never
2403 id
= gfc_sym_mangled_function_id (ns
->proc_name
);
2405 id
= get_identifier ("__BLOCK_DATA__");
2407 decl
= build_decl (VAR_DECL
, id
, gfc_array_index_type
);
2408 TREE_PUBLIC (decl
) = 1;
2409 TREE_STATIC (decl
) = 1;
2412 rest_of_decl_compilation (decl
, 1, 0);
2415 #include "gt-fortran-trans-decl.h"