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.
152 Set TREE_USED for named lables. For artificial labels it's up to the
153 caller to mark the label as used. */
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
;
179 DECL_ARTIFICIAL (label_decl
) = 1;
183 /* We always define the label as used, even if the original source
184 file never references the label. We don't want all kinds of
185 spurious warnings for old-style Fortran code with too many
187 TREE_USED (label_decl
) = 1;
194 /* Returns the return label for the current function. */
197 gfc_get_return_label (void)
199 char name
[GFC_MAX_SYMBOL_LEN
+ 10];
201 if (current_function_return_label
)
202 return current_function_return_label
;
204 sprintf (name
, "__return_%s",
205 IDENTIFIER_POINTER (DECL_NAME (current_function_decl
)));
207 current_function_return_label
=
208 gfc_build_label_decl (get_identifier (name
));
210 DECL_ARTIFICIAL (current_function_return_label
) = 1;
212 return current_function_return_label
;
216 /* Set the backend source location of a decl. */
219 gfc_set_decl_location (tree decl
, locus
* loc
)
221 #ifdef USE_MAPPED_LOCATION
222 DECL_SOURCE_LOCATION (decl
) = loc
->lb
->location
;
224 DECL_SOURCE_LINE (decl
) = loc
->lb
->linenum
;
225 DECL_SOURCE_FILE (decl
) = loc
->lb
->file
->filename
;
230 /* Return the backend label declaration for a given label structure,
231 or create it if it doesn't exist yet. */
234 gfc_get_label_decl (gfc_st_label
* lp
)
236 if (lp
->backend_decl
)
237 return lp
->backend_decl
;
240 char label_name
[GFC_MAX_SYMBOL_LEN
+ 1];
243 /* Validate the label declaration from the front end. */
244 gcc_assert (lp
!= NULL
&& lp
->value
<= MAX_LABEL_VALUE
);
246 /* Build a mangled name for the label. */
247 sprintf (label_name
, "__label_%.6d", lp
->value
);
249 /* Build the LABEL_DECL node. */
250 label_decl
= gfc_build_label_decl (get_identifier (label_name
));
252 /* Tell the debugger where the label came from. */
253 if (lp
->value
<= MAX_LABEL_VALUE
) /* An internal label. */
254 gfc_set_decl_location (label_decl
, &lp
->where
);
256 DECL_ARTIFICIAL (label_decl
) = 1;
258 /* Store the label in the label list and return the LABEL_DECL. */
259 lp
->backend_decl
= label_decl
;
265 /* Convert a gfc_symbol to an identifier of the same name. */
268 gfc_sym_identifier (gfc_symbol
* sym
)
270 return (get_identifier (sym
->name
));
274 /* Construct mangled name from symbol name. */
277 gfc_sym_mangled_identifier (gfc_symbol
* sym
)
279 char name
[GFC_MAX_MANGLED_SYMBOL_LEN
+ 1];
281 if (sym
->module
[0] == 0)
282 return gfc_sym_identifier (sym
);
285 snprintf (name
, sizeof name
, "__%s__%s", sym
->module
, sym
->name
);
286 return get_identifier (name
);
291 /* Construct mangled function name from symbol name. */
294 gfc_sym_mangled_function_id (gfc_symbol
* sym
)
297 char name
[GFC_MAX_MANGLED_SYMBOL_LEN
+ 1];
299 if (sym
->module
[0] == 0 || sym
->attr
.proc
== PROC_EXTERNAL
300 || (sym
->module
[0] != 0 && sym
->attr
.if_source
== IFSRC_IFBODY
))
302 if (strcmp (sym
->name
, "MAIN__") == 0
303 || sym
->attr
.proc
== PROC_INTRINSIC
)
304 return get_identifier (sym
->name
);
306 if (gfc_option
.flag_underscoring
)
308 has_underscore
= strchr (sym
->name
, '_') != 0;
309 if (gfc_option
.flag_second_underscore
&& has_underscore
)
310 snprintf (name
, sizeof name
, "%s__", sym
->name
);
312 snprintf (name
, sizeof name
, "%s_", sym
->name
);
313 return get_identifier (name
);
316 return get_identifier (sym
->name
);
320 snprintf (name
, sizeof name
, "__%s__%s", sym
->module
, sym
->name
);
321 return get_identifier (name
);
326 /* Finish processing of a declaration and install its initial value. */
329 gfc_finish_decl (tree decl
, tree init
)
331 if (TREE_CODE (decl
) == PARM_DECL
)
332 gcc_assert (init
== NULL_TREE
);
333 /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se
334 -- it overlaps DECL_ARG_TYPE. */
335 else if (init
== NULL_TREE
)
336 gcc_assert (DECL_INITIAL (decl
) == NULL_TREE
);
338 gcc_assert (DECL_INITIAL (decl
) == error_mark_node
);
340 if (init
!= NULL_TREE
)
342 if (TREE_CODE (decl
) != TYPE_DECL
)
343 DECL_INITIAL (decl
) = init
;
346 /* typedef foo = bar; store the type of bar as the type of foo. */
347 TREE_TYPE (decl
) = TREE_TYPE (init
);
348 DECL_INITIAL (decl
) = init
= 0;
352 if (TREE_CODE (decl
) == VAR_DECL
)
354 if (DECL_SIZE (decl
) == NULL_TREE
355 && TYPE_SIZE (TREE_TYPE (decl
)) != NULL_TREE
)
356 layout_decl (decl
, 0);
358 /* A static variable with an incomplete type is an error if it is
359 initialized. Also if it is not file scope. Otherwise, let it
360 through, but if it is not `extern' then it may cause an error
362 /* An automatic variable with an incomplete type is an error. */
363 if (DECL_SIZE (decl
) == NULL_TREE
364 && (TREE_STATIC (decl
) ? (DECL_INITIAL (decl
) != 0
365 || DECL_CONTEXT (decl
) != 0)
366 : !DECL_EXTERNAL (decl
)))
368 gfc_fatal_error ("storage size not known");
371 if ((DECL_EXTERNAL (decl
) || TREE_STATIC (decl
))
372 && (DECL_SIZE (decl
) != 0)
373 && (TREE_CODE (DECL_SIZE (decl
)) != INTEGER_CST
))
375 gfc_fatal_error ("storage size not constant");
382 /* Apply symbol attributes to a variable, and add it to the function scope. */
385 gfc_finish_var_decl (tree decl
, gfc_symbol
* sym
)
387 /* TREE_ADDRESSABLE means the address of this variable is actually needed.
388 This is the equivalent of the TARGET variables.
389 We also need to set this if the variable is passed by reference in a
391 if (sym
->attr
.target
)
392 TREE_ADDRESSABLE (decl
) = 1;
393 /* If it wasn't used we wouldn't be getting it. */
394 TREE_USED (decl
) = 1;
396 /* Chain this decl to the pending declarations. Don't do pushdecl()
397 because this would add them to the current scope rather than the
399 if (current_function_decl
!= NULL_TREE
)
401 if (sym
->ns
->proc_name
->backend_decl
== current_function_decl
)
402 gfc_add_decl_to_function (decl
);
404 gfc_add_decl_to_parent_function (decl
);
407 /* If a variable is USE associated, it's always external. */
408 if (sym
->attr
.use_assoc
)
410 DECL_EXTERNAL (decl
) = 1;
411 TREE_PUBLIC (decl
) = 1;
413 else if (sym
->module
[0] && !sym
->attr
.result
&& !sym
->attr
.dummy
)
415 /* TODO: Don't set sym->module for result or dummy variables. */
416 gcc_assert (current_function_decl
== NULL_TREE
);
417 /* This is the declaration of a module variable. */
418 TREE_PUBLIC (decl
) = 1;
419 TREE_STATIC (decl
) = 1;
422 if ((sym
->attr
.save
|| sym
->attr
.data
|| sym
->value
)
423 && !sym
->attr
.use_assoc
)
424 TREE_STATIC (decl
) = 1;
426 /* Keep variables larger than max-stack-var-size off stack. */
427 if (!sym
->ns
->proc_name
->attr
.recursive
428 && INTEGER_CST_P (DECL_SIZE_UNIT (decl
))
429 && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl
)))
430 TREE_STATIC (decl
) = 1;
434 /* Allocate the lang-specific part of a decl. */
437 gfc_allocate_lang_decl (tree decl
)
439 DECL_LANG_SPECIFIC (decl
) = (struct lang_decl
*)
440 ggc_alloc_cleared (sizeof (struct lang_decl
));
443 /* Remember a symbol to generate initialization/cleanup code at function
447 gfc_defer_symbol_init (gfc_symbol
* sym
)
453 /* Don't add a symbol twice. */
457 last
= head
= sym
->ns
->proc_name
;
460 /* Make sure that setup code for dummy variables which are used in the
461 setup of other variables is generated first. */
464 /* Find the first dummy arg seen after us, or the first non-dummy arg.
465 This is a circular list, so don't go past the head. */
467 && (!p
->attr
.dummy
|| p
->dummy_order
> sym
->dummy_order
))
473 /* Insert in between last and p. */
479 /* Create an array index type variable with function scope. */
482 create_index_var (const char * pfx
, int nest
)
486 decl
= gfc_create_var_np (gfc_array_index_type
, pfx
);
488 gfc_add_decl_to_parent_function (decl
);
490 gfc_add_decl_to_function (decl
);
495 /* Create variables to hold all the non-constant bits of info for a
496 descriptorless array. Remember these in the lang-specific part of the
500 gfc_build_qualified_array (tree decl
, gfc_symbol
* sym
)
506 type
= TREE_TYPE (decl
);
508 /* We just use the descriptor, if there is one. */
509 if (GFC_DESCRIPTOR_TYPE_P (type
))
512 gcc_assert (GFC_ARRAY_TYPE_P (type
));
513 nest
= (sym
->ns
->proc_name
->backend_decl
!= current_function_decl
)
514 && !sym
->attr
.contained
;
516 for (dim
= 0; dim
< GFC_TYPE_ARRAY_RANK (type
); dim
++)
518 if (GFC_TYPE_ARRAY_LBOUND (type
, dim
) == NULL_TREE
)
519 GFC_TYPE_ARRAY_LBOUND (type
, dim
) = create_index_var ("lbound", nest
);
520 /* Don't try to use the unkown bound for assumed shape arrays. */
521 if (GFC_TYPE_ARRAY_UBOUND (type
, dim
) == NULL_TREE
522 && (sym
->as
->type
!= AS_ASSUMED_SIZE
523 || dim
< GFC_TYPE_ARRAY_RANK (type
) - 1))
524 GFC_TYPE_ARRAY_UBOUND (type
, dim
) = create_index_var ("ubound", nest
);
526 if (GFC_TYPE_ARRAY_STRIDE (type
, dim
) == NULL_TREE
)
527 GFC_TYPE_ARRAY_STRIDE (type
, dim
) = create_index_var ("stride", nest
);
529 if (GFC_TYPE_ARRAY_OFFSET (type
) == NULL_TREE
)
531 GFC_TYPE_ARRAY_OFFSET (type
) = gfc_create_var_np (gfc_array_index_type
,
534 gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type
));
536 gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type
));
541 /* For some dummy arguments we don't use the actual argument directly.
542 Instead we create a local decl and use that. This allows us to preform
543 initialization, and construct full type information. */
546 gfc_build_dummy_array_decl (gfc_symbol
* sym
, tree dummy
)
556 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
559 /* Add to list of variables if not a fake result variable. */
560 if (sym
->attr
.result
|| sym
->attr
.dummy
)
561 gfc_defer_symbol_init (sym
);
563 type
= TREE_TYPE (dummy
);
564 gcc_assert (TREE_CODE (dummy
) == PARM_DECL
565 && POINTER_TYPE_P (type
));
567 /* Do we know the element size? */
568 known_size
= sym
->ts
.type
!= BT_CHARACTER
569 || INTEGER_CST_P (sym
->ts
.cl
->backend_decl
);
571 if (known_size
&& !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type
)))
573 /* For descriptorless arrays with known element size the actual
574 argument is sufficient. */
575 gcc_assert (GFC_ARRAY_TYPE_P (type
));
576 gfc_build_qualified_array (dummy
, sym
);
580 type
= TREE_TYPE (type
);
581 if (GFC_DESCRIPTOR_TYPE_P (type
))
583 /* Create a decriptorless array pointer. */
586 if (!gfc_option
.flag_repack_arrays
)
588 if (as
->type
== AS_ASSUMED_SIZE
)
593 if (as
->type
== AS_EXPLICIT
)
596 for (n
= 0; n
< as
->rank
; n
++)
600 && as
->upper
[n
]->expr_type
== EXPR_CONSTANT
601 && as
->lower
[n
]->expr_type
== EXPR_CONSTANT
))
609 type
= gfc_typenode_for_spec (&sym
->ts
);
610 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
);
614 /* We now have an expression for the element size, so create a fully
615 qualified type. Reset sym->backend decl or this will just return the
617 sym
->backend_decl
= NULL_TREE
;
618 type
= gfc_sym_type (sym
);
622 ASM_FORMAT_PRIVATE_NAME (name
, IDENTIFIER_POINTER (DECL_NAME (dummy
)), 0);
623 decl
= build_decl (VAR_DECL
, get_identifier (name
), type
);
625 DECL_ARTIFICIAL (decl
) = 1;
626 TREE_PUBLIC (decl
) = 0;
627 TREE_STATIC (decl
) = 0;
628 DECL_EXTERNAL (decl
) = 0;
630 /* We should never get deferred shape arrays here. We used to because of
632 gcc_assert (sym
->as
->type
!= AS_DEFERRED
);
637 GFC_DECL_PARTIAL_PACKED_ARRAY (decl
) = 1;
641 GFC_DECL_PACKED_ARRAY (decl
) = 1;
645 gfc_build_qualified_array (decl
, sym
);
647 if (DECL_LANG_SPECIFIC (dummy
))
648 DECL_LANG_SPECIFIC (decl
) = DECL_LANG_SPECIFIC (dummy
);
650 gfc_allocate_lang_decl (decl
);
652 GFC_DECL_SAVED_DESCRIPTOR (decl
) = dummy
;
654 if (sym
->ns
->proc_name
->backend_decl
== current_function_decl
655 || sym
->attr
.contained
)
656 gfc_add_decl_to_function (decl
);
658 gfc_add_decl_to_parent_function (decl
);
664 /* Return a constant or a variable to use as a string length. Does not
665 add the decl to the current scope. */
668 gfc_create_string_length (gfc_symbol
* sym
)
672 gcc_assert (sym
->ts
.cl
);
673 gfc_conv_const_charlen (sym
->ts
.cl
);
675 if (sym
->ts
.cl
->backend_decl
== NULL_TREE
)
677 char name
[GFC_MAX_MANGLED_SYMBOL_LEN
+ 2];
679 /* Also prefix the mangled name. */
680 strcpy (&name
[1], sym
->name
);
682 length
= build_decl (VAR_DECL
, get_identifier (name
),
683 gfc_charlen_type_node
);
684 DECL_ARTIFICIAL (length
) = 1;
685 TREE_USED (length
) = 1;
686 gfc_defer_symbol_init (sym
);
687 sym
->ts
.cl
->backend_decl
= length
;
690 return sym
->ts
.cl
->backend_decl
;
694 /* Return the decl for a gfc_symbol, create it if it doesn't already
698 gfc_get_symbol_decl (gfc_symbol
* sym
)
701 tree length
= NULL_TREE
;
704 gcc_assert (sym
->attr
.referenced
);
706 if (sym
->ns
&& sym
->ns
->proc_name
->attr
.function
)
707 byref
= gfc_return_by_reference (sym
->ns
->proc_name
);
711 if ((sym
->attr
.dummy
&& ! sym
->attr
.function
) || (sym
->attr
.result
&& byref
))
713 /* Return via extra parameter. */
714 if (sym
->attr
.result
&& byref
715 && !sym
->backend_decl
)
718 DECL_ARGUMENTS (sym
->ns
->proc_name
->backend_decl
);
721 /* Dummy variables should already have been created. */
722 gcc_assert (sym
->backend_decl
);
724 /* Create a character length variable. */
725 if (sym
->ts
.type
== BT_CHARACTER
)
727 if (sym
->ts
.cl
->backend_decl
== NULL_TREE
)
729 length
= gfc_create_string_length (sym
);
730 if (TREE_CODE (length
) != INTEGER_CST
)
732 gfc_finish_var_decl (length
, sym
);
733 gfc_defer_symbol_init (sym
);
738 /* Use a copy of the descriptor for dummy arrays. */
739 if (sym
->attr
.dimension
&& !TREE_USED (sym
->backend_decl
))
742 gfc_build_dummy_array_decl (sym
, sym
->backend_decl
);
745 TREE_USED (sym
->backend_decl
) = 1;
746 return sym
->backend_decl
;
749 if (sym
->backend_decl
)
750 return sym
->backend_decl
;
752 /* Catch function declarations. Only used for actual parameters. */
753 if (sym
->attr
.flavor
== FL_PROCEDURE
)
755 decl
= gfc_get_extern_function_decl (sym
);
759 if (sym
->attr
.intrinsic
)
760 internal_error ("intrinsic variable which isn't a procedure");
762 /* Create string length decl first so that they can be used in the
764 if (sym
->ts
.type
== BT_CHARACTER
)
765 length
= gfc_create_string_length (sym
);
767 /* Create the decl for the variable. */
768 decl
= build_decl (VAR_DECL
, gfc_sym_identifier (sym
), gfc_sym_type (sym
));
770 gfc_set_decl_location (decl
, &sym
->declared_at
);
772 /* Symbols from modules should have their assembler names mangled.
773 This is done here rather than in gfc_finish_var_decl because it
774 is different for string length variables. */
776 SET_DECL_ASSEMBLER_NAME (decl
, gfc_sym_mangled_identifier (sym
));
778 if (sym
->attr
.dimension
)
780 /* Create variables to hold the non-constant bits of array info. */
781 gfc_build_qualified_array (decl
, sym
);
783 /* Remember this variable for allocation/cleanup. */
784 gfc_defer_symbol_init (sym
);
786 if ((sym
->attr
.allocatable
|| !sym
->attr
.dummy
) && !sym
->attr
.pointer
)
787 GFC_DECL_PACKED_ARRAY (decl
) = 1;
790 gfc_finish_var_decl (decl
, sym
);
792 if (sym
->attr
.assign
)
794 gfc_allocate_lang_decl (decl
);
795 GFC_DECL_ASSIGN (decl
) = 1;
796 length
= gfc_create_var (gfc_charlen_type_node
, sym
->name
);
797 GFC_DECL_STRING_LEN (decl
) = length
;
798 GFC_DECL_ASSIGN_ADDR (decl
) = gfc_create_var (pvoid_type_node
, sym
->name
);
799 /* TODO: Need to check we don't change TREE_STATIC (decl) later. */
800 TREE_STATIC (length
) = TREE_STATIC (decl
);
801 /* STRING_LENGTH is also used as flag. Less than -1 means that
802 ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
803 target label's address. Other value is the length of format string
804 and ASSIGN_ADDR is the address of format string. */
805 DECL_INITIAL (length
) = build_int_cst (NULL_TREE
, -2);
808 if (sym
->ts
.type
== BT_CHARACTER
)
810 /* Character variables need special handling. */
811 gfc_allocate_lang_decl (decl
);
813 if (TREE_CODE (length
) != INTEGER_CST
)
815 char name
[GFC_MAX_MANGLED_SYMBOL_LEN
+ 2];
819 /* Also prefix the mangled name for symbols from modules. */
820 strcpy (&name
[1], sym
->name
);
823 IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length
)));
824 SET_DECL_ASSEMBLER_NAME (decl
, get_identifier (name
));
826 gfc_finish_var_decl (length
, sym
);
827 gcc_assert (!sym
->value
);
830 sym
->backend_decl
= decl
;
832 if (TREE_STATIC (decl
) && !sym
->attr
.use_assoc
)
834 /* Add static initializer. */
835 DECL_INITIAL (decl
) = gfc_conv_initializer (sym
->value
, &sym
->ts
,
836 TREE_TYPE (decl
), sym
->attr
.dimension
,
837 sym
->attr
.pointer
|| sym
->attr
.allocatable
);
844 /* Substitute a temporary variable in place of the real one. */
847 gfc_shadow_sym (gfc_symbol
* sym
, tree decl
, gfc_saved_var
* save
)
849 save
->attr
= sym
->attr
;
850 save
->decl
= sym
->backend_decl
;
852 gfc_clear_attr (&sym
->attr
);
853 sym
->attr
.referenced
= 1;
854 sym
->attr
.flavor
= FL_VARIABLE
;
856 sym
->backend_decl
= decl
;
860 /* Restore the original variable. */
863 gfc_restore_sym (gfc_symbol
* sym
, gfc_saved_var
* save
)
865 sym
->attr
= save
->attr
;
866 sym
->backend_decl
= save
->decl
;
870 /* Get a basic decl for an external function. */
873 gfc_get_extern_function_decl (gfc_symbol
* sym
)
878 gfc_intrinsic_sym
*isym
;
880 char s
[GFC_MAX_SYMBOL_LEN
];
884 if (sym
->backend_decl
)
885 return sym
->backend_decl
;
887 /* We should never be creating external decls for alternate entry points.
888 The procedure may be an alternate entry point, but we don't want/need
890 gcc_assert (!(sym
->attr
.entry
|| sym
->attr
.entry_master
));
892 if (sym
->attr
.intrinsic
)
894 /* Call the resolution function to get the actual name. This is
895 a nasty hack which relies on the resolution functions only looking
896 at the first argument. We pass NULL for the second argument
897 otherwise things like AINT get confused. */
898 isym
= gfc_find_function (sym
->name
);
899 gcc_assert (isym
->resolve
.f0
!= NULL
);
901 memset (&e
, 0, sizeof (e
));
902 e
.expr_type
= EXPR_FUNCTION
;
904 memset (&argexpr
, 0, sizeof (argexpr
));
905 gcc_assert (isym
->formal
);
906 argexpr
.ts
= isym
->formal
->ts
;
908 if (isym
->formal
->next
== NULL
)
909 isym
->resolve
.f1 (&e
, &argexpr
);
912 /* All specific intrinsics take one or two arguments. */
913 gcc_assert (isym
->formal
->next
->next
== NULL
);
914 isym
->resolve
.f2 (&e
, &argexpr
, NULL
);
916 sprintf (s
, "specific%s", e
.value
.function
.name
);
917 name
= get_identifier (s
);
922 name
= gfc_sym_identifier (sym
);
923 mangled_name
= gfc_sym_mangled_function_id (sym
);
926 type
= gfc_get_function_type (sym
);
927 fndecl
= build_decl (FUNCTION_DECL
, name
, type
);
929 SET_DECL_ASSEMBLER_NAME (fndecl
, mangled_name
);
930 /* If the return type is a pointer, avoid alias issues by setting
931 DECL_IS_MALLOC to nonzero. This means that the function should be
932 treated as if it were a malloc, meaning it returns a pointer that
934 if (POINTER_TYPE_P (type
))
935 DECL_IS_MALLOC (fndecl
) = 1;
937 /* Set the context of this decl. */
938 if (0 && sym
->ns
&& sym
->ns
->proc_name
)
940 /* TODO: Add external decls to the appropriate scope. */
941 DECL_CONTEXT (fndecl
) = sym
->ns
->proc_name
->backend_decl
;
945 /* Global declaration, e.g. intrinsic subroutine. */
946 DECL_CONTEXT (fndecl
) = NULL_TREE
;
949 DECL_EXTERNAL (fndecl
) = 1;
951 /* This specifies if a function is globally addressable, i.e. it is
952 the opposite of declaring static in C. */
953 TREE_PUBLIC (fndecl
) = 1;
955 /* Set attributes for PURE functions. A call to PURE function in the
956 Fortran 95 sense is both pure and without side effects in the C
958 if (sym
->attr
.pure
|| sym
->attr
.elemental
)
960 if (sym
->attr
.function
)
961 DECL_IS_PURE (fndecl
) = 1;
962 /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
963 parameters and don't use alternate returns (is this
964 allowed?). In that case, calls to them are meaningless, and
965 can be optimized away. See also in build_function_decl(). */
966 TREE_SIDE_EFFECTS (fndecl
) = 0;
969 sym
->backend_decl
= fndecl
;
971 if (DECL_CONTEXT (fndecl
) == NULL_TREE
)
972 pushdecl_top_level (fndecl
);
978 /* Create a declaration for a procedure. For external functions (in the C
979 sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is
980 a master function with alternate entry points. */
983 build_function_decl (gfc_symbol
* sym
)
986 symbol_attribute attr
;
988 gfc_formal_arglist
*f
;
990 gcc_assert (!sym
->backend_decl
);
991 gcc_assert (!sym
->attr
.external
);
993 /* Set the line and filename. sym->declared_at seems to point to the
994 last statement for subroutines, but it'll do for now. */
995 gfc_set_backend_locus (&sym
->declared_at
);
997 /* Allow only one nesting level. Allow public declarations. */
998 gcc_assert (current_function_decl
== NULL_TREE
999 || DECL_CONTEXT (current_function_decl
) == NULL_TREE
);
1001 type
= gfc_get_function_type (sym
);
1002 fndecl
= build_decl (FUNCTION_DECL
, gfc_sym_identifier (sym
), type
);
1004 /* Perform name mangling if this is a top level or module procedure. */
1005 if (current_function_decl
== NULL_TREE
)
1006 SET_DECL_ASSEMBLER_NAME (fndecl
, gfc_sym_mangled_function_id (sym
));
1008 /* Figure out the return type of the declared function, and build a
1009 RESULT_DECL for it. If this is a subroutine with alternate
1010 returns, build a RESULT_DECL for it. */
1013 result_decl
= NULL_TREE
;
1014 /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
1017 if (gfc_return_by_reference (sym
))
1018 type
= void_type_node
;
1021 if (sym
->result
!= sym
)
1022 result_decl
= gfc_sym_identifier (sym
->result
);
1024 type
= TREE_TYPE (TREE_TYPE (fndecl
));
1029 /* Look for alternate return placeholders. */
1030 int has_alternate_returns
= 0;
1031 for (f
= sym
->formal
; f
; f
= f
->next
)
1035 has_alternate_returns
= 1;
1040 if (has_alternate_returns
)
1041 type
= integer_type_node
;
1043 type
= void_type_node
;
1046 result_decl
= build_decl (RESULT_DECL
, result_decl
, type
);
1047 DECL_ARTIFICIAL (result_decl
) = 1;
1048 DECL_IGNORED_P (result_decl
) = 1;
1049 DECL_CONTEXT (result_decl
) = fndecl
;
1050 DECL_RESULT (fndecl
) = result_decl
;
1052 /* Don't call layout_decl for a RESULT_DECL.
1053 layout_decl (result_decl, 0); */
1055 /* If the return type is a pointer, avoid alias issues by setting
1056 DECL_IS_MALLOC to nonzero. This means that the function should be
1057 treated as if it were a malloc, meaning it returns a pointer that
1059 if (POINTER_TYPE_P (type
))
1060 DECL_IS_MALLOC (fndecl
) = 1;
1062 /* Set up all attributes for the function. */
1063 DECL_CONTEXT (fndecl
) = current_function_decl
;
1064 DECL_EXTERNAL (fndecl
) = 0;
1066 /* This specifies if a function is globally visible, i.e. it is
1067 the opposite of declaring static in C. */
1068 if (DECL_CONTEXT (fndecl
) == NULL_TREE
1069 && !sym
->attr
.entry_master
)
1070 TREE_PUBLIC (fndecl
) = 1;
1072 /* TREE_STATIC means the function body is defined here. */
1073 TREE_STATIC (fndecl
) = 1;
1075 /* Set attributes for PURE functions. A call to a PURE function in the
1076 Fortran 95 sense is both pure and without side effects in the C
1078 if (attr
.pure
|| attr
.elemental
)
1080 /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
1081 including a alternate return. In that case it can also be
1082 marked as PURE. See also in gfc_get_extern_function_decl(). */
1084 DECL_IS_PURE (fndecl
) = 1;
1085 TREE_SIDE_EFFECTS (fndecl
) = 0;
1088 /* Layout the function declaration and put it in the binding level
1089 of the current function. */
1092 sym
->backend_decl
= fndecl
;
1096 /* Create the DECL_ARGUMENTS for a procedure. */
1099 create_function_arglist (gfc_symbol
* sym
)
1102 gfc_formal_arglist
*f
;
1109 fndecl
= sym
->backend_decl
;
1111 /* Build formal argument list. Make sure that their TREE_CONTEXT is
1112 the new FUNCTION_DECL node. */
1113 arglist
= NULL_TREE
;
1114 typelist
= TYPE_ARG_TYPES (TREE_TYPE (fndecl
));
1116 if (sym
->attr
.entry_master
)
1118 type
= TREE_VALUE (typelist
);
1119 parm
= build_decl (PARM_DECL
, get_identifier ("__entry"), type
);
1121 DECL_CONTEXT (parm
) = fndecl
;
1122 DECL_ARG_TYPE (parm
) = type
;
1123 TREE_READONLY (parm
) = 1;
1124 gfc_finish_decl (parm
, NULL_TREE
);
1126 arglist
= chainon (arglist
, parm
);
1127 typelist
= TREE_CHAIN (typelist
);
1130 if (gfc_return_by_reference (sym
))
1132 type
= TREE_VALUE (typelist
);
1133 parm
= build_decl (PARM_DECL
, get_identifier ("__result"), type
);
1135 DECL_CONTEXT (parm
) = fndecl
;
1136 DECL_ARG_TYPE (parm
) = type
;
1137 TREE_READONLY (parm
) = 1;
1138 DECL_ARTIFICIAL (parm
) = 1;
1139 gfc_finish_decl (parm
, NULL_TREE
);
1141 arglist
= chainon (arglist
, parm
);
1142 typelist
= TREE_CHAIN (typelist
);
1144 if (sym
->ts
.type
== BT_CHARACTER
)
1146 gfc_allocate_lang_decl (parm
);
1148 /* Length of character result. */
1149 type
= TREE_VALUE (typelist
);
1150 gcc_assert (type
== gfc_charlen_type_node
);
1152 length
= build_decl (PARM_DECL
,
1153 get_identifier (".__result"),
1155 if (!sym
->ts
.cl
->length
)
1157 sym
->ts
.cl
->backend_decl
= length
;
1158 TREE_USED (length
) = 1;
1160 gcc_assert (TREE_CODE (length
) == PARM_DECL
);
1161 arglist
= chainon (arglist
, length
);
1162 typelist
= TREE_CHAIN (typelist
);
1163 DECL_CONTEXT (length
) = fndecl
;
1164 DECL_ARG_TYPE (length
) = type
;
1165 TREE_READONLY (length
) = 1;
1166 DECL_ARTIFICIAL (length
) = 1;
1167 gfc_finish_decl (length
, NULL_TREE
);
1171 for (f
= sym
->formal
; f
; f
= f
->next
)
1173 if (f
->sym
!= NULL
) /* ignore alternate returns. */
1177 type
= TREE_VALUE (typelist
);
1179 /* Build a the argument declaration. */
1180 parm
= build_decl (PARM_DECL
,
1181 gfc_sym_identifier (f
->sym
), type
);
1183 /* Fill in arg stuff. */
1184 DECL_CONTEXT (parm
) = fndecl
;
1185 DECL_ARG_TYPE (parm
) = type
;
1186 DECL_ARG_TYPE_AS_WRITTEN (parm
) = type
;
1187 /* All implementation args are read-only. */
1188 TREE_READONLY (parm
) = 1;
1190 gfc_finish_decl (parm
, NULL_TREE
);
1192 f
->sym
->backend_decl
= parm
;
1194 arglist
= chainon (arglist
, parm
);
1195 typelist
= TREE_CHAIN (typelist
);
1199 /* Add the hidden string length parameters. */
1201 for (f
= sym
->formal
; f
; f
= f
->next
)
1203 char name
[GFC_MAX_SYMBOL_LEN
+ 2];
1204 /* Ignore alternate returns. */
1208 if (f
->sym
->ts
.type
!= BT_CHARACTER
)
1211 parm
= f
->sym
->backend_decl
;
1212 type
= TREE_VALUE (typelist
);
1213 gcc_assert (type
== gfc_charlen_type_node
);
1215 strcpy (&name
[1], f
->sym
->name
);
1217 length
= build_decl (PARM_DECL
, get_identifier (name
), type
);
1219 arglist
= chainon (arglist
, length
);
1220 DECL_CONTEXT (length
) = fndecl
;
1221 DECL_ARTIFICIAL (length
) = 1;
1222 DECL_ARG_TYPE (length
) = type
;
1223 TREE_READONLY (length
) = 1;
1224 gfc_finish_decl (length
, NULL_TREE
);
1226 /* TODO: Check string lengths when -fbounds-check. */
1228 /* Use the passed value for assumed length variables. */
1229 if (!f
->sym
->ts
.cl
->length
)
1231 TREE_USED (length
) = 1;
1232 if (!f
->sym
->ts
.cl
->backend_decl
)
1233 f
->sym
->ts
.cl
->backend_decl
= length
;
1236 /* there is already another variable using this
1237 gfc_charlen node, build a new one for this variable
1238 and chain it into the list of gfc_charlens.
1239 This happens for e.g. in the case
1241 since CHARACTER declarations on the same line share
1242 the same gfc_charlen node. */
1245 cl
= gfc_get_charlen ();
1246 cl
->backend_decl
= length
;
1247 cl
->next
= f
->sym
->ts
.cl
->next
;
1248 f
->sym
->ts
.cl
->next
= cl
;
1253 parm
= TREE_CHAIN (parm
);
1254 typelist
= TREE_CHAIN (typelist
);
1257 gcc_assert (TREE_VALUE (typelist
) == void_type_node
);
1258 DECL_ARGUMENTS (fndecl
) = arglist
;
1261 /* Convert FNDECL's code to GIMPLE and handle any nested functions. */
1264 gfc_gimplify_function (tree fndecl
)
1266 struct cgraph_node
*cgn
;
1268 gimplify_function_tree (fndecl
);
1269 dump_function (TDI_generic
, fndecl
);
1271 /* Convert all nested functions to GIMPLE now. We do things in this order
1272 so that items like VLA sizes are expanded properly in the context of the
1273 correct function. */
1274 cgn
= cgraph_node (fndecl
);
1275 for (cgn
= cgn
->nested
; cgn
; cgn
= cgn
->next_nested
)
1276 gfc_gimplify_function (cgn
->decl
);
1280 /* Do the setup necessary before generating the body of a function. */
1283 trans_function_start (gfc_symbol
* sym
)
1287 fndecl
= sym
->backend_decl
;
1289 /* Let GCC know the current scope is this function. */
1290 current_function_decl
= fndecl
;
1292 /* Let the world know what we're about to do. */
1293 announce_function (fndecl
);
1295 if (DECL_CONTEXT (fndecl
) == NULL_TREE
)
1297 /* Create RTL for function declaration. */
1298 rest_of_decl_compilation (fndecl
, 1, 0);
1301 /* Create RTL for function definition. */
1302 make_decl_rtl (fndecl
);
1304 init_function_start (fndecl
);
1306 /* Even though we're inside a function body, we still don't want to
1307 call expand_expr to calculate the size of a variable-sized array.
1308 We haven't necessarily assigned RTL to all variables yet, so it's
1309 not safe to try to expand expressions involving them. */
1310 cfun
->x_dont_save_pending_sizes_p
= 1;
1312 /* function.c requires a push at the start of the function. */
1316 /* Create thunks for alternate entry points. */
1319 build_entry_thunks (gfc_namespace
* ns
)
1321 gfc_formal_arglist
*formal
;
1322 gfc_formal_arglist
*thunk_formal
;
1324 gfc_symbol
*thunk_sym
;
1332 /* This should always be a toplevel function. */
1333 gcc_assert (current_function_decl
== NULL_TREE
);
1335 gfc_get_backend_locus (&old_loc
);
1336 for (el
= ns
->entries
; el
; el
= el
->next
)
1338 thunk_sym
= el
->sym
;
1340 build_function_decl (thunk_sym
);
1341 create_function_arglist (thunk_sym
);
1343 trans_function_start (thunk_sym
);
1345 thunk_fndecl
= thunk_sym
->backend_decl
;
1347 gfc_start_block (&body
);
1349 /* Pass extra parameter identifying this entry point. */
1350 tmp
= build_int_cst (gfc_array_index_type
, el
->id
);
1351 args
= tree_cons (NULL_TREE
, tmp
, NULL_TREE
);
1352 string_args
= NULL_TREE
;
1354 /* TODO: Pass return by reference parameters. */
1355 if (ns
->proc_name
->attr
.function
)
1356 gfc_todo_error ("Functons with multiple entry points");
1358 for (formal
= ns
->proc_name
->formal
; formal
; formal
= formal
->next
)
1360 /* We don't have a clever way of identifying arguments, so resort to
1361 a brute-force search. */
1362 for (thunk_formal
= thunk_sym
->formal
;
1364 thunk_formal
= thunk_formal
->next
)
1366 if (thunk_formal
->sym
== formal
->sym
)
1372 /* Pass the argument. */
1373 args
= tree_cons (NULL_TREE
, thunk_formal
->sym
->backend_decl
,
1375 if (formal
->sym
->ts
.type
== BT_CHARACTER
)
1377 tmp
= thunk_formal
->sym
->ts
.cl
->backend_decl
;
1378 string_args
= tree_cons (NULL_TREE
, tmp
, string_args
);
1383 /* Pass NULL for a missing argument. */
1384 args
= tree_cons (NULL_TREE
, null_pointer_node
, args
);
1385 if (formal
->sym
->ts
.type
== BT_CHARACTER
)
1387 tmp
= convert (gfc_charlen_type_node
, integer_zero_node
);
1388 string_args
= tree_cons (NULL_TREE
, tmp
, string_args
);
1393 /* Call the master function. */
1394 args
= nreverse (args
);
1395 args
= chainon (args
, nreverse (string_args
));
1396 tmp
= ns
->proc_name
->backend_decl
;
1397 tmp
= gfc_build_function_call (tmp
, args
);
1398 /* TODO: function return value. */
1399 gfc_add_expr_to_block (&body
, tmp
);
1401 /* Finish off this function and send it for code generation. */
1402 DECL_SAVED_TREE (thunk_fndecl
) = gfc_finish_block (&body
);
1404 BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl
)) = thunk_fndecl
;
1406 /* Output the GENERIC tree. */
1407 dump_function (TDI_original
, thunk_fndecl
);
1409 /* Store the end of the function, so that we get good line number
1410 info for the epilogue. */
1411 cfun
->function_end_locus
= input_location
;
1413 /* We're leaving the context of this function, so zap cfun.
1414 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
1415 tree_rest_of_compilation. */
1418 current_function_decl
= NULL_TREE
;
1420 gfc_gimplify_function (thunk_fndecl
);
1421 cgraph_finalize_function (thunk_fndecl
, false);
1423 /* We share the symbols in the formal argument list with other entry
1424 points and the master function. Clear them so that they are
1425 recreated for each function. */
1426 for (formal
= thunk_sym
->formal
; formal
; formal
= formal
->next
)
1428 formal
->sym
->backend_decl
= NULL_TREE
;
1429 if (formal
->sym
->ts
.type
== BT_CHARACTER
)
1430 formal
->sym
->ts
.cl
->backend_decl
= NULL_TREE
;
1434 gfc_set_backend_locus (&old_loc
);
1438 /* Create a decl for a function, and create any thunks for alternate entry
1442 gfc_create_function_decl (gfc_namespace
* ns
)
1444 /* Create a declaration for the master function. */
1445 build_function_decl (ns
->proc_name
);
1447 /* Compile the entry thunks. */
1449 build_entry_thunks (ns
);
1451 /* Now create the read argument list. */
1452 create_function_arglist (ns
->proc_name
);
1455 /* Return the decl used to hold the function return value. */
1458 gfc_get_fake_result_decl (gfc_symbol
* sym
)
1463 char name
[GFC_MAX_SYMBOL_LEN
+ 10];
1465 if (current_fake_result_decl
!= NULL_TREE
)
1466 return current_fake_result_decl
;
1468 /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
1473 if (sym
->ts
.type
== BT_CHARACTER
1474 && !sym
->ts
.cl
->backend_decl
)
1476 length
= gfc_create_string_length (sym
);
1477 gfc_finish_var_decl (length
, sym
);
1480 if (gfc_return_by_reference (sym
))
1482 decl
= DECL_ARGUMENTS (sym
->backend_decl
);
1484 TREE_USED (decl
) = 1;
1486 decl
= gfc_build_dummy_array_decl (sym
, decl
);
1490 sprintf (name
, "__result_%.20s",
1491 IDENTIFIER_POINTER (DECL_NAME (current_function_decl
)));
1493 decl
= build_decl (VAR_DECL
, get_identifier (name
),
1494 TREE_TYPE (TREE_TYPE (current_function_decl
)));
1496 DECL_ARTIFICIAL (decl
) = 1;
1497 DECL_EXTERNAL (decl
) = 0;
1498 TREE_PUBLIC (decl
) = 0;
1499 TREE_USED (decl
) = 1;
1501 layout_decl (decl
, 0);
1503 gfc_add_decl_to_function (decl
);
1506 current_fake_result_decl
= decl
;
1512 /* Builds a function decl. The remaining parameters are the types of the
1513 function arguments. Negative nargs indicates a varargs function. */
1516 gfc_build_library_function_decl (tree name
, tree rettype
, int nargs
, ...)
1525 /* Library functions must be declared with global scope. */
1526 gcc_assert (current_function_decl
== NULL_TREE
);
1528 va_start (p
, nargs
);
1531 /* Create a list of the argument types. */
1532 for (arglist
= NULL_TREE
, n
= abs (nargs
); n
> 0; n
--)
1534 argtype
= va_arg (p
, tree
);
1535 arglist
= gfc_chainon_list (arglist
, argtype
);
1540 /* Terminate the list. */
1541 arglist
= gfc_chainon_list (arglist
, void_type_node
);
1544 /* Build the function type and decl. */
1545 fntype
= build_function_type (rettype
, arglist
);
1546 fndecl
= build_decl (FUNCTION_DECL
, name
, fntype
);
1548 /* Mark this decl as external. */
1549 DECL_EXTERNAL (fndecl
) = 1;
1550 TREE_PUBLIC (fndecl
) = 1;
1556 rest_of_decl_compilation (fndecl
, 1, 0);
1562 gfc_build_intrinsic_function_decls (void)
1564 tree gfc_int4_type_node
= gfc_get_int_type (4);
1565 tree gfc_int8_type_node
= gfc_get_int_type (8);
1566 tree gfc_logical4_type_node
= gfc_get_logical_type (4);
1567 tree gfc_real4_type_node
= gfc_get_real_type (4);
1568 tree gfc_real8_type_node
= gfc_get_real_type (8);
1569 tree gfc_complex4_type_node
= gfc_get_complex_type (4);
1570 tree gfc_complex8_type_node
= gfc_get_complex_type (8);
1572 /* String functions. */
1573 gfor_fndecl_copy_string
=
1574 gfc_build_library_function_decl (get_identifier (PREFIX("copy_string")),
1577 gfc_charlen_type_node
, pchar_type_node
,
1578 gfc_charlen_type_node
, pchar_type_node
);
1580 gfor_fndecl_compare_string
=
1581 gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),
1584 gfc_charlen_type_node
, pchar_type_node
,
1585 gfc_charlen_type_node
, pchar_type_node
);
1587 gfor_fndecl_concat_string
=
1588 gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),
1591 gfc_charlen_type_node
, pchar_type_node
,
1592 gfc_charlen_type_node
, pchar_type_node
,
1593 gfc_charlen_type_node
, pchar_type_node
);
1595 gfor_fndecl_string_len_trim
=
1596 gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")),
1598 2, gfc_charlen_type_node
,
1601 gfor_fndecl_string_index
=
1602 gfc_build_library_function_decl (get_identifier (PREFIX("string_index")),
1604 5, gfc_charlen_type_node
, pchar_type_node
,
1605 gfc_charlen_type_node
, pchar_type_node
,
1606 gfc_logical4_type_node
);
1608 gfor_fndecl_string_scan
=
1609 gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")),
1611 5, gfc_charlen_type_node
, pchar_type_node
,
1612 gfc_charlen_type_node
, pchar_type_node
,
1613 gfc_logical4_type_node
);
1615 gfor_fndecl_string_verify
=
1616 gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")),
1618 5, gfc_charlen_type_node
, pchar_type_node
,
1619 gfc_charlen_type_node
, pchar_type_node
,
1620 gfc_logical4_type_node
);
1622 gfor_fndecl_string_trim
=
1623 gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),
1626 build_pointer_type (gfc_charlen_type_node
),
1628 gfc_charlen_type_node
,
1631 gfor_fndecl_string_repeat
=
1632 gfc_build_library_function_decl (get_identifier (PREFIX("string_repeat")),
1636 gfc_charlen_type_node
,
1638 gfc_int4_type_node
);
1640 gfor_fndecl_adjustl
=
1641 gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),
1645 gfc_charlen_type_node
, pchar_type_node
);
1647 gfor_fndecl_adjustr
=
1648 gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")),
1652 gfc_charlen_type_node
, pchar_type_node
);
1654 gfor_fndecl_si_kind
=
1655 gfc_build_library_function_decl (get_identifier ("selected_int_kind"),
1660 gfor_fndecl_sr_kind
=
1661 gfc_build_library_function_decl (get_identifier ("selected_real_kind"),
1666 /* Power functions. */
1672 static int kinds
[2] = {4, 8};
1673 char name
[PREFIX_LEN
+ 10]; /* _gfortran_pow_?n_?n */
1675 for (ikind
=0; ikind
< 2; ikind
++)
1677 itype
= gfc_get_int_type (kinds
[ikind
]);
1678 for (kind
= 0; kind
< 2; kind
++)
1680 type
= gfc_get_int_type (kinds
[kind
]);
1681 sprintf(name
, PREFIX("pow_i%d_i%d"), kinds
[kind
], kinds
[ikind
]);
1682 gfor_fndecl_math_powi
[kind
][ikind
].integer
=
1683 gfc_build_library_function_decl (get_identifier (name
),
1684 type
, 2, type
, itype
);
1686 type
= gfc_get_real_type (kinds
[kind
]);
1687 sprintf(name
, PREFIX("pow_r%d_i%d"), kinds
[kind
], kinds
[ikind
]);
1688 gfor_fndecl_math_powi
[kind
][ikind
].real
=
1689 gfc_build_library_function_decl (get_identifier (name
),
1690 type
, 2, type
, itype
);
1692 type
= gfc_get_complex_type (kinds
[kind
]);
1693 sprintf(name
, PREFIX("pow_c%d_i%d"), kinds
[kind
], kinds
[ikind
]);
1694 gfor_fndecl_math_powi
[kind
][ikind
].cmplx
=
1695 gfc_build_library_function_decl (get_identifier (name
),
1696 type
, 2, type
, itype
);
1701 gfor_fndecl_math_cpowf
=
1702 gfc_build_library_function_decl (get_identifier ("cpowf"),
1703 gfc_complex4_type_node
,
1704 1, gfc_complex4_type_node
);
1705 gfor_fndecl_math_cpow
=
1706 gfc_build_library_function_decl (get_identifier ("cpow"),
1707 gfc_complex8_type_node
,
1708 1, gfc_complex8_type_node
);
1709 gfor_fndecl_math_ishftc4
=
1710 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")),
1712 3, gfc_int4_type_node
,
1713 gfc_int4_type_node
, gfc_int4_type_node
);
1714 gfor_fndecl_math_ishftc8
=
1715 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")),
1717 3, gfc_int8_type_node
,
1718 gfc_int8_type_node
, gfc_int8_type_node
);
1719 gfor_fndecl_math_exponent4
=
1720 gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r4")),
1722 1, gfc_real4_type_node
);
1723 gfor_fndecl_math_exponent8
=
1724 gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r8")),
1726 1, gfc_real8_type_node
);
1728 /* Other functions. */
1730 gfc_build_library_function_decl (get_identifier (PREFIX("size0")),
1731 gfc_array_index_type
,
1732 1, pvoid_type_node
);
1734 gfc_build_library_function_decl (get_identifier (PREFIX("size1")),
1735 gfc_array_index_type
,
1737 gfc_array_index_type
);
1740 gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),
1746 /* Make prototypes for runtime library functions. */
1749 gfc_build_builtin_function_decls (void)
1751 tree gfc_int4_type_node
= gfc_get_int_type (4);
1752 tree gfc_int8_type_node
= gfc_get_int_type (8);
1753 tree gfc_logical4_type_node
= gfc_get_logical_type (4);
1755 gfor_fndecl_internal_malloc
=
1756 gfc_build_library_function_decl (get_identifier (PREFIX("internal_malloc")),
1757 pvoid_type_node
, 1, gfc_int4_type_node
);
1759 gfor_fndecl_internal_malloc64
=
1760 gfc_build_library_function_decl (get_identifier
1761 (PREFIX("internal_malloc64")),
1762 pvoid_type_node
, 1, gfc_int8_type_node
);
1764 gfor_fndecl_internal_free
=
1765 gfc_build_library_function_decl (get_identifier (PREFIX("internal_free")),
1766 void_type_node
, 1, pvoid_type_node
);
1768 gfor_fndecl_allocate
=
1769 gfc_build_library_function_decl (get_identifier (PREFIX("allocate")),
1770 void_type_node
, 2, ppvoid_type_node
,
1771 gfc_int4_type_node
);
1773 gfor_fndecl_allocate64
=
1774 gfc_build_library_function_decl (get_identifier (PREFIX("allocate64")),
1775 void_type_node
, 2, ppvoid_type_node
,
1776 gfc_int8_type_node
);
1778 gfor_fndecl_deallocate
=
1779 gfc_build_library_function_decl (get_identifier (PREFIX("deallocate")),
1780 void_type_node
, 1, ppvoid_type_node
);
1782 gfor_fndecl_stop_numeric
=
1783 gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
1784 void_type_node
, 1, gfc_int4_type_node
);
1786 gfor_fndecl_stop_string
=
1787 gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),
1788 void_type_node
, 2, pchar_type_node
,
1789 gfc_int4_type_node
);
1791 gfor_fndecl_pause_numeric
=
1792 gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
1793 void_type_node
, 1, gfc_int4_type_node
);
1795 gfor_fndecl_pause_string
=
1796 gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")),
1797 void_type_node
, 2, pchar_type_node
,
1798 gfc_int4_type_node
);
1800 gfor_fndecl_select_string
=
1801 gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
1802 pvoid_type_node
, 0);
1804 gfor_fndecl_runtime_error
=
1805 gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
1808 pchar_type_node
, pchar_type_node
,
1809 gfc_int4_type_node
);
1811 gfor_fndecl_in_pack
= gfc_build_library_function_decl (
1812 get_identifier (PREFIX("internal_pack")),
1813 pvoid_type_node
, 1, pvoid_type_node
);
1815 gfor_fndecl_in_unpack
= gfc_build_library_function_decl (
1816 get_identifier (PREFIX("internal_unpack")),
1817 pvoid_type_node
, 1, pvoid_type_node
);
1819 gfor_fndecl_associated
=
1820 gfc_build_library_function_decl (
1821 get_identifier (PREFIX("associated")),
1822 gfc_logical4_type_node
,
1827 gfc_build_intrinsic_function_decls ();
1828 gfc_build_intrinsic_lib_fndecls ();
1829 gfc_build_io_library_fndecls ();
1833 /* Evaluate the length of dummy character variables. */
1836 gfc_trans_dummy_character (gfc_charlen
* cl
, tree fnbody
)
1840 gfc_finish_decl (cl
->backend_decl
, NULL_TREE
);
1842 gfc_start_block (&body
);
1844 /* Evaluate the string length expression. */
1845 gfc_trans_init_string_length (cl
, &body
);
1847 gfc_add_expr_to_block (&body
, fnbody
);
1848 return gfc_finish_block (&body
);
1852 /* Allocate and cleanup an automatic character variable. */
1855 gfc_trans_auto_character_variable (gfc_symbol
* sym
, tree fnbody
)
1861 gcc_assert (sym
->backend_decl
);
1862 gcc_assert (sym
->ts
.cl
&& sym
->ts
.cl
->length
);
1864 gfc_start_block (&body
);
1866 /* Evaluate the string length expression. */
1867 gfc_trans_init_string_length (sym
->ts
.cl
, &body
);
1869 decl
= sym
->backend_decl
;
1871 /* Emit a DECL_EXPR for this variable, which will cause the
1872 gimplifier to allocate storage, and all that good stuff. */
1873 tmp
= build1 (DECL_EXPR
, TREE_TYPE (decl
), decl
);
1874 gfc_add_expr_to_block (&body
, tmp
);
1876 gfc_add_expr_to_block (&body
, fnbody
);
1877 return gfc_finish_block (&body
);
1881 /* Generate function entry and exit code, and add it to the function body.
1883 Allocation and initialization of array variables.
1884 Allocation of character string variables.
1885 Initialization and possibly repacking of dummy arrays. */
1888 gfc_trans_deferred_vars (gfc_symbol
* proc_sym
, tree fnbody
)
1893 /* Deal with implicit return variables. Explicit return variables will
1894 already have been added. */
1895 if (gfc_return_by_reference (proc_sym
) && proc_sym
->result
== proc_sym
)
1897 if (!current_fake_result_decl
)
1899 warning ("Function does not return a value");
1905 fnbody
= gfc_trans_dummy_array_bias (proc_sym
,
1906 current_fake_result_decl
,
1909 else if (proc_sym
->ts
.type
== BT_CHARACTER
)
1911 if (TREE_CODE (proc_sym
->ts
.cl
->backend_decl
) == VAR_DECL
)
1912 fnbody
= gfc_trans_dummy_character (proc_sym
->ts
.cl
, fnbody
);
1915 gfc_todo_error ("Deferred non-array return by reference");
1918 for (sym
= proc_sym
->tlink
; sym
!= proc_sym
; sym
= sym
->tlink
)
1920 if (sym
->attr
.dimension
)
1922 switch (sym
->as
->type
)
1925 if (sym
->attr
.dummy
|| sym
->attr
.result
)
1927 gfc_trans_dummy_array_bias (sym
, sym
->backend_decl
, fnbody
);
1928 else if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1930 if (TREE_STATIC (sym
->backend_decl
))
1931 gfc_trans_static_array_pointer (sym
);
1933 fnbody
= gfc_trans_deferred_array (sym
, fnbody
);
1937 gfc_get_backend_locus (&loc
);
1938 gfc_set_backend_locus (&sym
->declared_at
);
1939 fnbody
= gfc_trans_auto_array_allocation (sym
->backend_decl
,
1941 gfc_set_backend_locus (&loc
);
1945 case AS_ASSUMED_SIZE
:
1946 /* Must be a dummy parameter. */
1947 gcc_assert (sym
->attr
.dummy
);
1949 /* We should always pass assumed size arrays the g77 way. */
1950 fnbody
= gfc_trans_g77_array (sym
, fnbody
);
1953 case AS_ASSUMED_SHAPE
:
1954 /* Must be a dummy parameter. */
1955 gcc_assert (sym
->attr
.dummy
);
1957 fnbody
= gfc_trans_dummy_array_bias (sym
, sym
->backend_decl
,
1962 fnbody
= gfc_trans_deferred_array (sym
, fnbody
);
1969 else if (sym
->ts
.type
== BT_CHARACTER
)
1971 gfc_get_backend_locus (&loc
);
1972 gfc_set_backend_locus (&sym
->declared_at
);
1973 if (sym
->attr
.dummy
|| sym
->attr
.result
)
1974 fnbody
= gfc_trans_dummy_character (sym
->ts
.cl
, fnbody
);
1976 fnbody
= gfc_trans_auto_character_variable (sym
, fnbody
);
1977 gfc_set_backend_locus (&loc
);
1987 /* Output an initialized decl for a module variable. */
1990 gfc_create_module_variable (gfc_symbol
* sym
)
1994 /* Only output symbols from this module. */
1995 if (sym
->ns
!= module_namespace
)
1997 /* I don't think this should ever happen. */
1998 internal_error ("module symbol %s in wrong namespace", sym
->name
);
2001 /* Only output variables and array valued parameters. */
2002 if (sym
->attr
.flavor
!= FL_VARIABLE
2003 && (sym
->attr
.flavor
!= FL_PARAMETER
|| sym
->attr
.dimension
== 0))
2006 /* Don't generate variables from other modules. Variables from
2007 COMMONs will already have been generated. */
2008 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
2011 if (sym
->backend_decl
)
2012 internal_error ("backend decl for module variable %s already exists",
2015 /* We always want module variables to be created. */
2016 sym
->attr
.referenced
= 1;
2017 /* Create the decl. */
2018 decl
= gfc_get_symbol_decl (sym
);
2020 /* Create the variable. */
2022 rest_of_decl_compilation (decl
, 1, 0);
2024 /* Also add length of strings. */
2025 if (sym
->ts
.type
== BT_CHARACTER
)
2029 length
= sym
->ts
.cl
->backend_decl
;
2030 if (!INTEGER_CST_P (length
))
2033 rest_of_decl_compilation (length
, 1, 0);
2039 /* Generate all the required code for module variables. */
2042 gfc_generate_module_vars (gfc_namespace
* ns
)
2044 module_namespace
= ns
;
2046 /* Check if the frontend left the namespace in a reasonable state. */
2047 gcc_assert (ns
->proc_name
&& !ns
->proc_name
->tlink
);
2049 /* Generate COMMON blocks. */
2050 gfc_trans_common (ns
);
2052 /* Create decls for all the module variables. */
2053 gfc_traverse_ns (ns
, gfc_create_module_variable
);
2057 gfc_generate_contained_functions (gfc_namespace
* parent
)
2061 /* We create all the prototypes before generating any code. */
2062 for (ns
= parent
->contained
; ns
; ns
= ns
->sibling
)
2064 /* Skip namespaces from used modules. */
2065 if (ns
->parent
!= parent
)
2068 gfc_create_function_decl (ns
);
2071 for (ns
= parent
->contained
; ns
; ns
= ns
->sibling
)
2073 /* Skip namespaces from used modules. */
2074 if (ns
->parent
!= parent
)
2077 gfc_generate_function_code (ns
);
2082 /* Generate decls for all local variables. We do this to ensure correct
2083 handling of expressions which only appear in the specification of
2087 generate_local_decl (gfc_symbol
* sym
)
2089 if (sym
->attr
.flavor
== FL_VARIABLE
)
2091 if (sym
->attr
.referenced
)
2092 gfc_get_symbol_decl (sym
);
2093 else if (sym
->attr
.dummy
&& warn_unused_parameter
)
2094 warning ("unused parameter %qs", sym
->name
);
2095 /* Warn for unused variables, but not if they're inside a common
2096 block or are use-associated. */
2097 else if (warn_unused_variable
2098 && !(sym
->attr
.in_common
|| sym
->attr
.use_assoc
))
2099 warning ("unused variable %qs", sym
->name
);
2104 generate_local_vars (gfc_namespace
* ns
)
2106 gfc_traverse_ns (ns
, generate_local_decl
);
2110 /* Generate a switch statement to jump to the correct entry point. Also
2111 creates the label decls for the entry points. */
2114 gfc_trans_entry_master_switch (gfc_entry_list
* el
)
2121 gfc_init_block (&block
);
2122 for (; el
; el
= el
->next
)
2124 /* Add the case label. */
2125 label
= build_decl (LABEL_DECL
, NULL_TREE
, NULL_TREE
);
2126 DECL_CONTEXT (label
) = current_function_decl
;
2127 val
= build_int_cst (gfc_array_index_type
, el
->id
);
2128 tmp
= build3_v (CASE_LABEL_EXPR
, val
, NULL_TREE
, label
);
2129 gfc_add_expr_to_block (&block
, tmp
);
2131 /* And jump to the actual entry point. */
2132 label
= gfc_build_label_decl (NULL_TREE
);
2133 TREE_USED (label
) = 1;
2134 DECL_CONTEXT (label
) = current_function_decl
;
2135 tmp
= build1_v (GOTO_EXPR
, label
);
2136 gfc_add_expr_to_block (&block
, tmp
);
2138 /* Save the label decl. */
2141 tmp
= gfc_finish_block (&block
);
2142 /* The first argument selects the entry point. */
2143 val
= DECL_ARGUMENTS (current_function_decl
);
2144 tmp
= build3_v (SWITCH_EXPR
, val
, tmp
, NULL_TREE
);
2149 /* Generate code for a function. */
2152 gfc_generate_function_code (gfc_namespace
* ns
)
2163 sym
= ns
->proc_name
;
2165 /* Check that the frontend isn't still using this. */
2166 gcc_assert (sym
->tlink
== NULL
);
2169 /* Create the declaration for functions with global scope. */
2170 if (!sym
->backend_decl
)
2171 gfc_create_function_decl (ns
);
2173 fndecl
= sym
->backend_decl
;
2174 old_context
= current_function_decl
;
2178 push_function_context ();
2179 saved_parent_function_decls
= saved_function_decls
;
2180 saved_function_decls
= NULL_TREE
;
2183 trans_function_start (sym
);
2185 /* Will be created as needed. */
2186 current_fake_result_decl
= NULL_TREE
;
2188 gfc_start_block (&block
);
2190 gfc_generate_contained_functions (ns
);
2192 /* Translate COMMON blocks. */
2193 gfc_trans_common (ns
);
2195 generate_local_vars (ns
);
2197 current_function_return_label
= NULL
;
2199 /* Now generate the code for the body of this function. */
2200 gfc_init_block (&body
);
2202 if (TREE_TYPE (DECL_RESULT (fndecl
)) != void_type_node
2203 && sym
->attr
.subroutine
)
2205 tree alternate_return
;
2206 alternate_return
= gfc_get_fake_result_decl (sym
);
2207 gfc_add_modify_expr (&body
, alternate_return
, integer_zero_node
);
2212 /* Jump to the correct entry point. */
2213 tmp
= gfc_trans_entry_master_switch (ns
->entries
);
2214 gfc_add_expr_to_block (&body
, tmp
);
2217 tmp
= gfc_trans_code (ns
->code
);
2218 gfc_add_expr_to_block (&body
, tmp
);
2220 /* Add a return label if needed. */
2221 if (current_function_return_label
)
2223 tmp
= build1_v (LABEL_EXPR
, current_function_return_label
);
2224 gfc_add_expr_to_block (&body
, tmp
);
2227 tmp
= gfc_finish_block (&body
);
2228 /* Add code to create and cleanup arrays. */
2229 tmp
= gfc_trans_deferred_vars (sym
, tmp
);
2230 gfc_add_expr_to_block (&block
, tmp
);
2232 if (TREE_TYPE (DECL_RESULT (fndecl
)) != void_type_node
)
2234 if (sym
->attr
.subroutine
|| sym
== sym
->result
)
2236 result
= current_fake_result_decl
;
2237 current_fake_result_decl
= NULL_TREE
;
2240 result
= sym
->result
->backend_decl
;
2242 if (result
== NULL_TREE
)
2243 warning ("Function return value not set");
2246 /* Set the return value to the dummy result variable. */
2247 tmp
= build2 (MODIFY_EXPR
, TREE_TYPE (result
),
2248 DECL_RESULT (fndecl
), result
);
2249 tmp
= build1_v (RETURN_EXPR
, tmp
);
2250 gfc_add_expr_to_block (&block
, tmp
);
2254 /* Add all the decls we created during processing. */
2255 decl
= saved_function_decls
;
2260 next
= TREE_CHAIN (decl
);
2261 TREE_CHAIN (decl
) = NULL_TREE
;
2265 saved_function_decls
= NULL_TREE
;
2267 DECL_SAVED_TREE (fndecl
) = gfc_finish_block (&block
);
2269 /* Finish off this function and send it for code generation. */
2271 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl
)) = fndecl
;
2273 /* Output the GENERIC tree. */
2274 dump_function (TDI_original
, fndecl
);
2276 /* Store the end of the function, so that we get good line number
2277 info for the epilogue. */
2278 cfun
->function_end_locus
= input_location
;
2280 /* We're leaving the context of this function, so zap cfun.
2281 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
2282 tree_rest_of_compilation. */
2287 pop_function_context ();
2288 saved_function_decls
= saved_parent_function_decls
;
2290 current_function_decl
= old_context
;
2292 if (decl_function_context (fndecl
))
2293 /* Register this function with cgraph just far enough to get it
2294 added to our parent's nested function list. */
2295 (void) cgraph_node (fndecl
);
2298 gfc_gimplify_function (fndecl
);
2299 cgraph_finalize_function (fndecl
, false);
2304 gfc_generate_constructors (void)
2306 gcc_assert (gfc_static_ctors
== NULL_TREE
);
2314 if (gfc_static_ctors
== NULL_TREE
)
2317 fnname
= get_file_function_name ('I');
2318 type
= build_function_type (void_type_node
,
2319 gfc_chainon_list (NULL_TREE
, void_type_node
));
2321 fndecl
= build_decl (FUNCTION_DECL
, fnname
, type
);
2322 TREE_PUBLIC (fndecl
) = 1;
2324 decl
= build_decl (RESULT_DECL
, NULL_TREE
, void_type_node
);
2325 DECL_ARTIFICIAL (decl
) = 1;
2326 DECL_IGNORED_P (decl
) = 1;
2327 DECL_CONTEXT (decl
) = fndecl
;
2328 DECL_RESULT (fndecl
) = decl
;
2332 current_function_decl
= fndecl
;
2334 rest_of_decl_compilation (fndecl
, 1, 0);
2336 make_decl_rtl (fndecl
);
2338 init_function_start (fndecl
);
2342 for (; gfc_static_ctors
; gfc_static_ctors
= TREE_CHAIN (gfc_static_ctors
))
2345 gfc_build_function_call (TREE_VALUE (gfc_static_ctors
), NULL_TREE
);
2346 DECL_SAVED_TREE (fndecl
) = build_stmt (EXPR_STMT
, tmp
);
2351 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl
)) = fndecl
;
2353 free_after_parsing (cfun
);
2354 free_after_compilation (cfun
);
2356 tree_rest_of_compilation (fndecl
);
2358 current_function_decl
= NULL_TREE
;
2362 /* Translates a BLOCK DATA program unit. This means emitting the
2363 commons contained therein plus their initializations. We also emit
2364 a globally visible symbol to make sure that each BLOCK DATA program
2365 unit remains unique. */
2368 gfc_generate_block_data (gfc_namespace
* ns
)
2373 /* Tell the backend the source location of the block data. */
2375 gfc_set_backend_locus (&ns
->proc_name
->declared_at
);
2377 gfc_set_backend_locus (&gfc_current_locus
);
2379 /* Process the DATA statements. */
2380 gfc_trans_common (ns
);
2382 /* Create a global symbol with the mane of the block data. This is to
2383 generate linker errors if the same name is used twice. It is never
2386 id
= gfc_sym_mangled_function_id (ns
->proc_name
);
2388 id
= get_identifier ("__BLOCK_DATA__");
2390 decl
= build_decl (VAR_DECL
, id
, gfc_array_index_type
);
2391 TREE_PUBLIC (decl
) = 1;
2392 TREE_STATIC (decl
) = 1;
2395 rest_of_decl_compilation (decl
, 1, 0);
2398 #include "gt-fortran-trans-decl.h"