1 /* Backend function setup
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
3 Free Software Foundation, Inc.
4 Contributed by Paul Brook
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* trans-decl.c -- Handling of backend function and variable decls, etc */
26 #include "coretypes.h"
28 #include "tree-dump.h"
40 #include "pointer-set.h"
41 #include "constructor.h"
43 #include "trans-types.h"
44 #include "trans-array.h"
45 #include "trans-const.h"
46 /* Only for gfc_trans_code. Shouldn't need to include this. */
47 #include "trans-stmt.h"
49 #define MAX_LABEL_VALUE 99999
52 /* Holds the result of the function if no result variable specified. */
54 static GTY(()) tree current_fake_result_decl
;
55 static GTY(()) tree parent_fake_result_decl
;
57 static GTY(()) tree current_function_return_label
;
60 /* Holds the variable DECLs for the current function. */
62 static GTY(()) tree saved_function_decls
;
63 static GTY(()) tree saved_parent_function_decls
;
65 static struct pointer_set_t
*nonlocal_dummy_decl_pset
;
66 static GTY(()) tree nonlocal_dummy_decls
;
68 /* Holds the variable DECLs that are locals. */
70 static GTY(()) tree saved_local_decls
;
72 /* The namespace of the module we're currently generating. Only used while
73 outputting decls for module variables. Do not rely on this being set. */
75 static gfc_namespace
*module_namespace
;
78 /* List of static constructor functions. */
80 tree gfc_static_ctors
;
83 /* Function declarations for builtin library functions. */
85 tree gfor_fndecl_pause_numeric
;
86 tree gfor_fndecl_pause_string
;
87 tree gfor_fndecl_stop_numeric
;
88 tree gfor_fndecl_stop_string
;
89 tree gfor_fndecl_error_stop_string
;
90 tree gfor_fndecl_runtime_error
;
91 tree gfor_fndecl_runtime_error_at
;
92 tree gfor_fndecl_runtime_warning_at
;
93 tree gfor_fndecl_os_error
;
94 tree gfor_fndecl_generate_error
;
95 tree gfor_fndecl_set_args
;
96 tree gfor_fndecl_set_fpe
;
97 tree gfor_fndecl_set_options
;
98 tree gfor_fndecl_set_convert
;
99 tree gfor_fndecl_set_record_marker
;
100 tree gfor_fndecl_set_max_subrecord_length
;
101 tree gfor_fndecl_ctime
;
102 tree gfor_fndecl_fdate
;
103 tree gfor_fndecl_ttynam
;
104 tree gfor_fndecl_in_pack
;
105 tree gfor_fndecl_in_unpack
;
106 tree gfor_fndecl_associated
;
109 /* Math functions. Many other math functions are handled in
110 trans-intrinsic.c. */
112 gfc_powdecl_list gfor_fndecl_math_powi
[4][3];
113 tree gfor_fndecl_math_ishftc4
;
114 tree gfor_fndecl_math_ishftc8
;
115 tree gfor_fndecl_math_ishftc16
;
118 /* String functions. */
120 tree gfor_fndecl_compare_string
;
121 tree gfor_fndecl_concat_string
;
122 tree gfor_fndecl_string_len_trim
;
123 tree gfor_fndecl_string_index
;
124 tree gfor_fndecl_string_scan
;
125 tree gfor_fndecl_string_verify
;
126 tree gfor_fndecl_string_trim
;
127 tree gfor_fndecl_string_minmax
;
128 tree gfor_fndecl_adjustl
;
129 tree gfor_fndecl_adjustr
;
130 tree gfor_fndecl_select_string
;
131 tree gfor_fndecl_compare_string_char4
;
132 tree gfor_fndecl_concat_string_char4
;
133 tree gfor_fndecl_string_len_trim_char4
;
134 tree gfor_fndecl_string_index_char4
;
135 tree gfor_fndecl_string_scan_char4
;
136 tree gfor_fndecl_string_verify_char4
;
137 tree gfor_fndecl_string_trim_char4
;
138 tree gfor_fndecl_string_minmax_char4
;
139 tree gfor_fndecl_adjustl_char4
;
140 tree gfor_fndecl_adjustr_char4
;
141 tree gfor_fndecl_select_string_char4
;
144 /* Conversion between character kinds. */
145 tree gfor_fndecl_convert_char1_to_char4
;
146 tree gfor_fndecl_convert_char4_to_char1
;
149 /* Other misc. runtime library functions. */
151 tree gfor_fndecl_size0
;
152 tree gfor_fndecl_size1
;
153 tree gfor_fndecl_iargc
;
154 tree gfor_fndecl_clz128
;
155 tree gfor_fndecl_ctz128
;
157 /* Intrinsic functions implemented in Fortran. */
158 tree gfor_fndecl_sc_kind
;
159 tree gfor_fndecl_si_kind
;
160 tree gfor_fndecl_sr_kind
;
162 /* BLAS gemm functions. */
163 tree gfor_fndecl_sgemm
;
164 tree gfor_fndecl_dgemm
;
165 tree gfor_fndecl_cgemm
;
166 tree gfor_fndecl_zgemm
;
170 gfc_add_decl_to_parent_function (tree decl
)
173 DECL_CONTEXT (decl
) = DECL_CONTEXT (current_function_decl
);
174 DECL_NONLOCAL (decl
) = 1;
175 TREE_CHAIN (decl
) = saved_parent_function_decls
;
176 saved_parent_function_decls
= decl
;
180 gfc_add_decl_to_function (tree decl
)
183 TREE_USED (decl
) = 1;
184 DECL_CONTEXT (decl
) = current_function_decl
;
185 TREE_CHAIN (decl
) = saved_function_decls
;
186 saved_function_decls
= decl
;
190 add_decl_as_local (tree decl
)
193 TREE_USED (decl
) = 1;
194 DECL_CONTEXT (decl
) = current_function_decl
;
195 TREE_CHAIN (decl
) = saved_local_decls
;
196 saved_local_decls
= decl
;
200 /* Build a backend label declaration. Set TREE_USED for named labels.
201 The context of the label is always the current_function_decl. All
202 labels are marked artificial. */
205 gfc_build_label_decl (tree label_id
)
207 /* 2^32 temporaries should be enough. */
208 static unsigned int tmp_num
= 1;
212 if (label_id
== NULL_TREE
)
214 /* Build an internal label name. */
215 ASM_FORMAT_PRIVATE_NAME (label_name
, "L", tmp_num
++);
216 label_id
= get_identifier (label_name
);
221 /* Build the LABEL_DECL node. Labels have no type. */
222 label_decl
= build_decl (input_location
,
223 LABEL_DECL
, label_id
, void_type_node
);
224 DECL_CONTEXT (label_decl
) = current_function_decl
;
225 DECL_MODE (label_decl
) = VOIDmode
;
227 /* We always define the label as used, even if the original source
228 file never references the label. We don't want all kinds of
229 spurious warnings for old-style Fortran code with too many
231 TREE_USED (label_decl
) = 1;
233 DECL_ARTIFICIAL (label_decl
) = 1;
238 /* Returns the return label for the current function. */
241 gfc_get_return_label (void)
243 char name
[GFC_MAX_SYMBOL_LEN
+ 10];
245 if (current_function_return_label
)
246 return current_function_return_label
;
248 sprintf (name
, "__return_%s",
249 IDENTIFIER_POINTER (DECL_NAME (current_function_decl
)));
251 current_function_return_label
=
252 gfc_build_label_decl (get_identifier (name
));
254 DECL_ARTIFICIAL (current_function_return_label
) = 1;
256 return current_function_return_label
;
260 /* Set the backend source location of a decl. */
263 gfc_set_decl_location (tree decl
, locus
* loc
)
265 DECL_SOURCE_LOCATION (decl
) = loc
->lb
->location
;
269 /* Return the backend label declaration for a given label structure,
270 or create it if it doesn't exist yet. */
273 gfc_get_label_decl (gfc_st_label
* lp
)
275 if (lp
->backend_decl
)
276 return lp
->backend_decl
;
279 char label_name
[GFC_MAX_SYMBOL_LEN
+ 1];
282 /* Validate the label declaration from the front end. */
283 gcc_assert (lp
!= NULL
&& lp
->value
<= MAX_LABEL_VALUE
);
285 /* Build a mangled name for the label. */
286 sprintf (label_name
, "__label_%.6d", lp
->value
);
288 /* Build the LABEL_DECL node. */
289 label_decl
= gfc_build_label_decl (get_identifier (label_name
));
291 /* Tell the debugger where the label came from. */
292 if (lp
->value
<= MAX_LABEL_VALUE
) /* An internal label. */
293 gfc_set_decl_location (label_decl
, &lp
->where
);
295 DECL_ARTIFICIAL (label_decl
) = 1;
297 /* Store the label in the label list and return the LABEL_DECL. */
298 lp
->backend_decl
= label_decl
;
304 /* Convert a gfc_symbol to an identifier of the same name. */
307 gfc_sym_identifier (gfc_symbol
* sym
)
309 if (sym
->attr
.is_main_program
&& strcmp (sym
->name
, "main") == 0)
310 return (get_identifier ("MAIN__"));
312 return (get_identifier (sym
->name
));
316 /* Construct mangled name from symbol name. */
319 gfc_sym_mangled_identifier (gfc_symbol
* sym
)
321 char name
[GFC_MAX_MANGLED_SYMBOL_LEN
+ 1];
323 /* Prevent the mangling of identifiers that have an assigned
324 binding label (mainly those that are bind(c)). */
325 if (sym
->attr
.is_bind_c
== 1
326 && sym
->binding_label
[0] != '\0')
327 return get_identifier(sym
->binding_label
);
329 if (sym
->module
== NULL
)
330 return gfc_sym_identifier (sym
);
333 snprintf (name
, sizeof name
, "__%s_MOD_%s", sym
->module
, sym
->name
);
334 return get_identifier (name
);
339 /* Construct mangled function name from symbol name. */
342 gfc_sym_mangled_function_id (gfc_symbol
* sym
)
345 char name
[GFC_MAX_MANGLED_SYMBOL_LEN
+ 1];
347 /* It may be possible to simply use the binding label if it's
348 provided, and remove the other checks. Then we could use it
349 for other things if we wished. */
350 if ((sym
->attr
.is_bind_c
== 1 || sym
->attr
.is_iso_c
== 1) &&
351 sym
->binding_label
[0] != '\0')
352 /* use the binding label rather than the mangled name */
353 return get_identifier (sym
->binding_label
);
355 if (sym
->module
== NULL
|| sym
->attr
.proc
== PROC_EXTERNAL
356 || (sym
->module
!= NULL
&& (sym
->attr
.external
357 || sym
->attr
.if_source
== IFSRC_IFBODY
)))
359 /* Main program is mangled into MAIN__. */
360 if (sym
->attr
.is_main_program
)
361 return get_identifier ("MAIN__");
363 /* Intrinsic procedures are never mangled. */
364 if (sym
->attr
.proc
== PROC_INTRINSIC
)
365 return get_identifier (sym
->name
);
367 if (gfc_option
.flag_underscoring
)
369 has_underscore
= strchr (sym
->name
, '_') != 0;
370 if (gfc_option
.flag_second_underscore
&& has_underscore
)
371 snprintf (name
, sizeof name
, "%s__", sym
->name
);
373 snprintf (name
, sizeof name
, "%s_", sym
->name
);
374 return get_identifier (name
);
377 return get_identifier (sym
->name
);
381 snprintf (name
, sizeof name
, "__%s_MOD_%s", sym
->module
, sym
->name
);
382 return get_identifier (name
);
388 gfc_set_decl_assembler_name (tree decl
, tree name
)
390 tree target_mangled
= targetm
.mangle_decl_assembler_name (decl
, name
);
391 SET_DECL_ASSEMBLER_NAME (decl
, target_mangled
);
395 /* Returns true if a variable of specified size should go on the stack. */
398 gfc_can_put_var_on_stack (tree size
)
400 unsigned HOST_WIDE_INT low
;
402 if (!INTEGER_CST_P (size
))
405 if (gfc_option
.flag_max_stack_var_size
< 0)
408 if (TREE_INT_CST_HIGH (size
) != 0)
411 low
= TREE_INT_CST_LOW (size
);
412 if (low
> (unsigned HOST_WIDE_INT
) gfc_option
.flag_max_stack_var_size
)
415 /* TODO: Set a per-function stack size limit. */
421 /* gfc_finish_cray_pointee sets DECL_VALUE_EXPR for a Cray pointee to
422 an expression involving its corresponding pointer. There are
423 2 cases; one for variable size arrays, and one for everything else,
424 because variable-sized arrays require one fewer level of
428 gfc_finish_cray_pointee (tree decl
, gfc_symbol
*sym
)
430 tree ptr_decl
= gfc_get_symbol_decl (sym
->cp_pointer
);
433 /* Parameters need to be dereferenced. */
434 if (sym
->cp_pointer
->attr
.dummy
)
435 ptr_decl
= build_fold_indirect_ref_loc (input_location
,
438 /* Check to see if we're dealing with a variable-sized array. */
439 if (sym
->attr
.dimension
440 && TREE_CODE (TREE_TYPE (decl
)) == POINTER_TYPE
)
442 /* These decls will be dereferenced later, so we don't dereference
444 value
= convert (TREE_TYPE (decl
), ptr_decl
);
448 ptr_decl
= convert (build_pointer_type (TREE_TYPE (decl
)),
450 value
= build_fold_indirect_ref_loc (input_location
,
454 SET_DECL_VALUE_EXPR (decl
, value
);
455 DECL_HAS_VALUE_EXPR_P (decl
) = 1;
456 GFC_DECL_CRAY_POINTEE (decl
) = 1;
457 /* This is a fake variable just for debugging purposes. */
458 TREE_ASM_WRITTEN (decl
) = 1;
462 /* Finish processing of a declaration without an initial value. */
465 gfc_finish_decl (tree decl
)
467 gcc_assert (TREE_CODE (decl
) == PARM_DECL
468 || DECL_INITIAL (decl
) == NULL_TREE
);
470 if (TREE_CODE (decl
) != VAR_DECL
)
473 if (DECL_SIZE (decl
) == NULL_TREE
474 && TYPE_SIZE (TREE_TYPE (decl
)) != NULL_TREE
)
475 layout_decl (decl
, 0);
477 /* A few consistency checks. */
478 /* A static variable with an incomplete type is an error if it is
479 initialized. Also if it is not file scope. Otherwise, let it
480 through, but if it is not `extern' then it may cause an error
482 /* An automatic variable with an incomplete type is an error. */
484 /* We should know the storage size. */
485 gcc_assert (DECL_SIZE (decl
) != NULL_TREE
486 || (TREE_STATIC (decl
)
487 ? (!DECL_INITIAL (decl
) || !DECL_CONTEXT (decl
))
488 : DECL_EXTERNAL (decl
)));
490 /* The storage size should be constant. */
491 gcc_assert ((!DECL_EXTERNAL (decl
) && !TREE_STATIC (decl
))
493 || TREE_CODE (DECL_SIZE (decl
)) == INTEGER_CST
);
497 /* Apply symbol attributes to a variable, and add it to the function scope. */
500 gfc_finish_var_decl (tree decl
, gfc_symbol
* sym
)
503 /* TREE_ADDRESSABLE means the address of this variable is actually needed.
504 This is the equivalent of the TARGET variables.
505 We also need to set this if the variable is passed by reference in a
508 /* Set DECL_VALUE_EXPR for Cray Pointees. */
509 if (sym
->attr
.cray_pointee
)
510 gfc_finish_cray_pointee (decl
, sym
);
512 if (sym
->attr
.target
)
513 TREE_ADDRESSABLE (decl
) = 1;
514 /* If it wasn't used we wouldn't be getting it. */
515 TREE_USED (decl
) = 1;
517 /* Chain this decl to the pending declarations. Don't do pushdecl()
518 because this would add them to the current scope rather than the
520 if (current_function_decl
!= NULL_TREE
)
522 if (sym
->ns
->proc_name
->backend_decl
== current_function_decl
523 || sym
->result
== sym
)
524 gfc_add_decl_to_function (decl
);
525 else if (sym
->ns
->proc_name
->attr
.flavor
== FL_LABEL
)
526 /* This is a BLOCK construct. */
527 add_decl_as_local (decl
);
529 gfc_add_decl_to_parent_function (decl
);
532 if (sym
->attr
.cray_pointee
)
535 if(sym
->attr
.is_bind_c
== 1)
537 /* We need to put variables that are bind(c) into the common
538 segment of the object file, because this is what C would do.
539 gfortran would typically put them in either the BSS or
540 initialized data segments, and only mark them as common if
541 they were part of common blocks. However, if they are not put
542 into common space, then C cannot initialize global Fortran
543 variables that it interoperates with and the draft says that
544 either Fortran or C should be able to initialize it (but not
545 both, of course.) (J3/04-007, section 15.3). */
546 TREE_PUBLIC(decl
) = 1;
547 DECL_COMMON(decl
) = 1;
550 /* If a variable is USE associated, it's always external. */
551 if (sym
->attr
.use_assoc
)
553 DECL_EXTERNAL (decl
) = 1;
554 TREE_PUBLIC (decl
) = 1;
556 else if (sym
->module
&& !sym
->attr
.result
&& !sym
->attr
.dummy
)
558 /* TODO: Don't set sym->module for result or dummy variables. */
559 gcc_assert (current_function_decl
== NULL_TREE
|| sym
->result
== sym
);
560 /* This is the declaration of a module variable. */
561 TREE_PUBLIC (decl
) = 1;
562 TREE_STATIC (decl
) = 1;
565 /* Derived types are a bit peculiar because of the possibility of
566 a default initializer; this must be applied each time the variable
567 comes into scope it therefore need not be static. These variables
568 are SAVE_NONE but have an initializer. Otherwise explicitly
569 initialized variables are SAVE_IMPLICIT and explicitly saved are
571 if (!sym
->attr
.use_assoc
572 && (sym
->attr
.save
!= SAVE_NONE
|| sym
->attr
.data
573 || (sym
->value
&& sym
->ns
->proc_name
->attr
.is_main_program
)))
574 TREE_STATIC (decl
) = 1;
576 if (sym
->attr
.volatile_
)
578 TREE_THIS_VOLATILE (decl
) = 1;
579 new_type
= build_qualified_type (TREE_TYPE (decl
), TYPE_QUAL_VOLATILE
);
580 TREE_TYPE (decl
) = new_type
;
583 /* Keep variables larger than max-stack-var-size off stack. */
584 if (!sym
->ns
->proc_name
->attr
.recursive
585 && INTEGER_CST_P (DECL_SIZE_UNIT (decl
))
586 && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl
))
587 /* Put variable length auto array pointers always into stack. */
588 && (TREE_CODE (TREE_TYPE (decl
)) != POINTER_TYPE
589 || sym
->attr
.dimension
== 0
590 || sym
->as
->type
!= AS_EXPLICIT
592 || sym
->attr
.allocatable
)
593 && !DECL_ARTIFICIAL (decl
))
594 TREE_STATIC (decl
) = 1;
596 /* Handle threadprivate variables. */
597 if (sym
->attr
.threadprivate
598 && (TREE_STATIC (decl
) || DECL_EXTERNAL (decl
)))
599 DECL_TLS_MODEL (decl
) = decl_default_tls_model (decl
);
601 if (!sym
->attr
.target
602 && !sym
->attr
.pointer
603 && !sym
->attr
.cray_pointee
604 && !sym
->attr
.proc_pointer
)
605 DECL_RESTRICTED_P (decl
) = 1;
609 /* Allocate the lang-specific part of a decl. */
612 gfc_allocate_lang_decl (tree decl
)
614 DECL_LANG_SPECIFIC (decl
) = (struct lang_decl
*)
615 ggc_alloc_cleared (sizeof (struct lang_decl
));
618 /* Remember a symbol to generate initialization/cleanup code at function
622 gfc_defer_symbol_init (gfc_symbol
* sym
)
628 /* Don't add a symbol twice. */
632 last
= head
= sym
->ns
->proc_name
;
635 /* Make sure that setup code for dummy variables which are used in the
636 setup of other variables is generated first. */
639 /* Find the first dummy arg seen after us, or the first non-dummy arg.
640 This is a circular list, so don't go past the head. */
642 && (!p
->attr
.dummy
|| p
->dummy_order
> sym
->dummy_order
))
648 /* Insert in between last and p. */
654 /* Create an array index type variable with function scope. */
657 create_index_var (const char * pfx
, int nest
)
661 decl
= gfc_create_var_np (gfc_array_index_type
, pfx
);
663 gfc_add_decl_to_parent_function (decl
);
665 gfc_add_decl_to_function (decl
);
670 /* Create variables to hold all the non-constant bits of info for a
671 descriptorless array. Remember these in the lang-specific part of the
675 gfc_build_qualified_array (tree decl
, gfc_symbol
* sym
)
681 type
= TREE_TYPE (decl
);
683 /* We just use the descriptor, if there is one. */
684 if (GFC_DESCRIPTOR_TYPE_P (type
))
687 gcc_assert (GFC_ARRAY_TYPE_P (type
));
688 nest
= (sym
->ns
->proc_name
->backend_decl
!= current_function_decl
)
689 && !sym
->attr
.contained
;
691 for (dim
= 0; dim
< GFC_TYPE_ARRAY_RANK (type
); dim
++)
693 if (GFC_TYPE_ARRAY_LBOUND (type
, dim
) == NULL_TREE
)
695 GFC_TYPE_ARRAY_LBOUND (type
, dim
) = create_index_var ("lbound", nest
);
696 TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type
, dim
)) = 1;
698 /* Don't try to use the unknown bound for assumed shape arrays. */
699 if (GFC_TYPE_ARRAY_UBOUND (type
, dim
) == NULL_TREE
700 && (sym
->as
->type
!= AS_ASSUMED_SIZE
701 || dim
< GFC_TYPE_ARRAY_RANK (type
) - 1))
703 GFC_TYPE_ARRAY_UBOUND (type
, dim
) = create_index_var ("ubound", nest
);
704 TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type
, dim
)) = 1;
707 if (GFC_TYPE_ARRAY_STRIDE (type
, dim
) == NULL_TREE
)
709 GFC_TYPE_ARRAY_STRIDE (type
, dim
) = create_index_var ("stride", nest
);
710 TREE_NO_WARNING (GFC_TYPE_ARRAY_STRIDE (type
, dim
)) = 1;
713 if (GFC_TYPE_ARRAY_OFFSET (type
) == NULL_TREE
)
715 GFC_TYPE_ARRAY_OFFSET (type
) = gfc_create_var_np (gfc_array_index_type
,
717 TREE_NO_WARNING (GFC_TYPE_ARRAY_OFFSET (type
)) = 1;
720 gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type
));
722 gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type
));
725 if (GFC_TYPE_ARRAY_SIZE (type
) == NULL_TREE
726 && sym
->as
->type
!= AS_ASSUMED_SIZE
)
728 GFC_TYPE_ARRAY_SIZE (type
) = create_index_var ("size", nest
);
729 TREE_NO_WARNING (GFC_TYPE_ARRAY_SIZE (type
)) = 1;
732 if (POINTER_TYPE_P (type
))
734 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (type
)));
735 gcc_assert (TYPE_LANG_SPECIFIC (type
)
736 == TYPE_LANG_SPECIFIC (TREE_TYPE (type
)));
737 type
= TREE_TYPE (type
);
740 if (! COMPLETE_TYPE_P (type
) && GFC_TYPE_ARRAY_SIZE (type
))
744 size
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
745 GFC_TYPE_ARRAY_SIZE (type
), gfc_index_one_node
);
746 range
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
748 TYPE_DOMAIN (type
) = range
;
752 if (TYPE_NAME (type
) != NULL_TREE
753 && GFC_TYPE_ARRAY_UBOUND (type
, sym
->as
->rank
- 1) != NULL_TREE
754 && TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type
, sym
->as
->rank
- 1)) == VAR_DECL
)
756 tree gtype
= DECL_ORIGINAL_TYPE (TYPE_NAME (type
));
758 for (dim
= 0; dim
< sym
->as
->rank
- 1; dim
++)
760 gcc_assert (TREE_CODE (gtype
) == ARRAY_TYPE
);
761 gtype
= TREE_TYPE (gtype
);
763 gcc_assert (TREE_CODE (gtype
) == ARRAY_TYPE
);
764 if (TYPE_MAX_VALUE (TYPE_DOMAIN (gtype
)) == NULL
)
765 TYPE_NAME (type
) = NULL_TREE
;
768 if (TYPE_NAME (type
) == NULL_TREE
)
770 tree gtype
= TREE_TYPE (type
), rtype
, type_decl
;
772 for (dim
= sym
->as
->rank
- 1; dim
>= 0; dim
--)
775 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
776 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
777 rtype
= build_range_type (gfc_array_index_type
, lbound
, ubound
);
778 gtype
= build_array_type (gtype
, rtype
);
779 /* Ensure the bound variables aren't optimized out at -O0.
780 For -O1 and above they often will be optimized out, but
781 can be tracked by VTA. Also clear the artificial
782 lbound.N or ubound.N DECL_NAME, so that it doesn't end up
784 if (lbound
&& TREE_CODE (lbound
) == VAR_DECL
785 && DECL_ARTIFICIAL (lbound
) && DECL_IGNORED_P (lbound
))
787 if (DECL_NAME (lbound
)
788 && strstr (IDENTIFIER_POINTER (DECL_NAME (lbound
)),
790 DECL_NAME (lbound
) = NULL_TREE
;
791 DECL_IGNORED_P (lbound
) = 0;
793 if (ubound
&& TREE_CODE (ubound
) == VAR_DECL
794 && DECL_ARTIFICIAL (ubound
) && DECL_IGNORED_P (ubound
))
796 if (DECL_NAME (ubound
)
797 && strstr (IDENTIFIER_POINTER (DECL_NAME (ubound
)),
799 DECL_NAME (ubound
) = NULL_TREE
;
800 DECL_IGNORED_P (ubound
) = 0;
803 TYPE_NAME (type
) = type_decl
= build_decl (input_location
,
804 TYPE_DECL
, NULL
, gtype
);
805 DECL_ORIGINAL_TYPE (type_decl
) = gtype
;
810 /* For some dummy arguments we don't use the actual argument directly.
811 Instead we create a local decl and use that. This allows us to perform
812 initialization, and construct full type information. */
815 gfc_build_dummy_array_decl (gfc_symbol
* sym
, tree dummy
)
825 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
828 /* Add to list of variables if not a fake result variable. */
829 if (sym
->attr
.result
|| sym
->attr
.dummy
)
830 gfc_defer_symbol_init (sym
);
832 type
= TREE_TYPE (dummy
);
833 gcc_assert (TREE_CODE (dummy
) == PARM_DECL
834 && POINTER_TYPE_P (type
));
836 /* Do we know the element size? */
837 known_size
= sym
->ts
.type
!= BT_CHARACTER
838 || INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
);
840 if (known_size
&& !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type
)))
842 /* For descriptorless arrays with known element size the actual
843 argument is sufficient. */
844 gcc_assert (GFC_ARRAY_TYPE_P (type
));
845 gfc_build_qualified_array (dummy
, sym
);
849 type
= TREE_TYPE (type
);
850 if (GFC_DESCRIPTOR_TYPE_P (type
))
852 /* Create a descriptorless array pointer. */
856 /* Even when -frepack-arrays is used, symbols with TARGET attribute
858 if (!gfc_option
.flag_repack_arrays
|| sym
->attr
.target
)
860 if (as
->type
== AS_ASSUMED_SIZE
)
861 packed
= PACKED_FULL
;
865 if (as
->type
== AS_EXPLICIT
)
867 packed
= PACKED_FULL
;
868 for (n
= 0; n
< as
->rank
; n
++)
872 && as
->upper
[n
]->expr_type
== EXPR_CONSTANT
873 && as
->lower
[n
]->expr_type
== EXPR_CONSTANT
))
874 packed
= PACKED_PARTIAL
;
878 packed
= PACKED_PARTIAL
;
881 type
= gfc_typenode_for_spec (&sym
->ts
);
882 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
,
887 /* We now have an expression for the element size, so create a fully
888 qualified type. Reset sym->backend decl or this will just return the
890 DECL_ARTIFICIAL (sym
->backend_decl
) = 1;
891 sym
->backend_decl
= NULL_TREE
;
892 type
= gfc_sym_type (sym
);
893 packed
= PACKED_FULL
;
896 ASM_FORMAT_PRIVATE_NAME (name
, IDENTIFIER_POINTER (DECL_NAME (dummy
)), 0);
897 decl
= build_decl (input_location
,
898 VAR_DECL
, get_identifier (name
), type
);
900 DECL_ARTIFICIAL (decl
) = 1;
901 TREE_PUBLIC (decl
) = 0;
902 TREE_STATIC (decl
) = 0;
903 DECL_EXTERNAL (decl
) = 0;
905 /* We should never get deferred shape arrays here. We used to because of
907 gcc_assert (sym
->as
->type
!= AS_DEFERRED
);
909 if (packed
== PACKED_PARTIAL
)
910 GFC_DECL_PARTIAL_PACKED_ARRAY (decl
) = 1;
911 else if (packed
== PACKED_FULL
)
912 GFC_DECL_PACKED_ARRAY (decl
) = 1;
914 gfc_build_qualified_array (decl
, sym
);
916 if (DECL_LANG_SPECIFIC (dummy
))
917 DECL_LANG_SPECIFIC (decl
) = DECL_LANG_SPECIFIC (dummy
);
919 gfc_allocate_lang_decl (decl
);
921 GFC_DECL_SAVED_DESCRIPTOR (decl
) = dummy
;
923 if (sym
->ns
->proc_name
->backend_decl
== current_function_decl
924 || sym
->attr
.contained
)
925 gfc_add_decl_to_function (decl
);
927 gfc_add_decl_to_parent_function (decl
);
932 /* For symbol SYM with GFC_DECL_SAVED_DESCRIPTOR used in contained
933 function add a VAR_DECL to the current function with DECL_VALUE_EXPR
934 pointing to the artificial variable for debug info purposes. */
937 gfc_nonlocal_dummy_array_decl (gfc_symbol
*sym
)
941 if (! nonlocal_dummy_decl_pset
)
942 nonlocal_dummy_decl_pset
= pointer_set_create ();
944 if (pointer_set_insert (nonlocal_dummy_decl_pset
, sym
->backend_decl
))
947 dummy
= GFC_DECL_SAVED_DESCRIPTOR (sym
->backend_decl
);
948 decl
= build_decl (input_location
, VAR_DECL
, DECL_NAME (dummy
),
949 TREE_TYPE (sym
->backend_decl
));
950 DECL_ARTIFICIAL (decl
) = 0;
951 TREE_USED (decl
) = 1;
952 TREE_PUBLIC (decl
) = 0;
953 TREE_STATIC (decl
) = 0;
954 DECL_EXTERNAL (decl
) = 0;
955 if (DECL_BY_REFERENCE (dummy
))
956 DECL_BY_REFERENCE (decl
) = 1;
957 DECL_LANG_SPECIFIC (decl
) = DECL_LANG_SPECIFIC (sym
->backend_decl
);
958 SET_DECL_VALUE_EXPR (decl
, sym
->backend_decl
);
959 DECL_HAS_VALUE_EXPR_P (decl
) = 1;
960 DECL_CONTEXT (decl
) = DECL_CONTEXT (sym
->backend_decl
);
961 TREE_CHAIN (decl
) = nonlocal_dummy_decls
;
962 nonlocal_dummy_decls
= decl
;
965 /* Return a constant or a variable to use as a string length. Does not
966 add the decl to the current scope. */
969 gfc_create_string_length (gfc_symbol
* sym
)
971 gcc_assert (sym
->ts
.u
.cl
);
972 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
974 if (sym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
977 char name
[GFC_MAX_MANGLED_SYMBOL_LEN
+ 2];
979 /* Also prefix the mangled name. */
980 strcpy (&name
[1], sym
->name
);
982 length
= build_decl (input_location
,
983 VAR_DECL
, get_identifier (name
),
984 gfc_charlen_type_node
);
985 DECL_ARTIFICIAL (length
) = 1;
986 TREE_USED (length
) = 1;
987 if (sym
->ns
->proc_name
->tlink
!= NULL
)
988 gfc_defer_symbol_init (sym
);
990 sym
->ts
.u
.cl
->backend_decl
= length
;
993 gcc_assert (sym
->ts
.u
.cl
->backend_decl
!= NULL_TREE
);
994 return sym
->ts
.u
.cl
->backend_decl
;
997 /* If a variable is assigned a label, we add another two auxiliary
1001 gfc_add_assign_aux_vars (gfc_symbol
* sym
)
1007 gcc_assert (sym
->backend_decl
);
1009 decl
= sym
->backend_decl
;
1010 gfc_allocate_lang_decl (decl
);
1011 GFC_DECL_ASSIGN (decl
) = 1;
1012 length
= build_decl (input_location
,
1013 VAR_DECL
, create_tmp_var_name (sym
->name
),
1014 gfc_charlen_type_node
);
1015 addr
= build_decl (input_location
,
1016 VAR_DECL
, create_tmp_var_name (sym
->name
),
1018 gfc_finish_var_decl (length
, sym
);
1019 gfc_finish_var_decl (addr
, sym
);
1020 /* STRING_LENGTH is also used as flag. Less than -1 means that
1021 ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
1022 target label's address. Otherwise, value is the length of a format string
1023 and ASSIGN_ADDR is its address. */
1024 if (TREE_STATIC (length
))
1025 DECL_INITIAL (length
) = build_int_cst (NULL_TREE
, -2);
1027 gfc_defer_symbol_init (sym
);
1029 GFC_DECL_STRING_LEN (decl
) = length
;
1030 GFC_DECL_ASSIGN_ADDR (decl
) = addr
;
1035 add_attributes_to_decl (symbol_attribute sym_attr
, tree list
)
1040 for (id
= 0; id
< EXT_ATTR_NUM
; id
++)
1041 if (sym_attr
.ext_attr
& (1 << id
))
1043 attr
= build_tree_list (
1044 get_identifier (ext_attr_list
[id
].middle_end_name
),
1046 list
= chainon (list
, attr
);
1053 /* Return the decl for a gfc_symbol, create it if it doesn't already
1057 gfc_get_symbol_decl (gfc_symbol
* sym
)
1060 tree length
= NULL_TREE
;
1064 gcc_assert (sym
->attr
.referenced
1065 || sym
->attr
.use_assoc
1066 || sym
->ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
);
1068 if (sym
->ns
&& sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.function
)
1069 byref
= gfc_return_by_reference (sym
->ns
->proc_name
);
1073 if ((sym
->attr
.dummy
&& ! sym
->attr
.function
) || (sym
->attr
.result
&& byref
))
1075 /* Return via extra parameter. */
1076 if (sym
->attr
.result
&& byref
1077 && !sym
->backend_decl
)
1080 DECL_ARGUMENTS (sym
->ns
->proc_name
->backend_decl
);
1081 /* For entry master function skip over the __entry
1083 if (sym
->ns
->proc_name
->attr
.entry_master
)
1084 sym
->backend_decl
= TREE_CHAIN (sym
->backend_decl
);
1087 /* Dummy variables should already have been created. */
1088 gcc_assert (sym
->backend_decl
);
1090 /* Create a character length variable. */
1091 if (sym
->ts
.type
== BT_CHARACTER
)
1093 if (sym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
1094 length
= gfc_create_string_length (sym
);
1096 length
= sym
->ts
.u
.cl
->backend_decl
;
1097 if (TREE_CODE (length
) == VAR_DECL
1098 && DECL_CONTEXT (length
) == NULL_TREE
)
1100 /* Add the string length to the same context as the symbol. */
1101 if (DECL_CONTEXT (sym
->backend_decl
) == current_function_decl
)
1102 gfc_add_decl_to_function (length
);
1104 gfc_add_decl_to_parent_function (length
);
1106 gcc_assert (DECL_CONTEXT (sym
->backend_decl
) ==
1107 DECL_CONTEXT (length
));
1109 gfc_defer_symbol_init (sym
);
1113 /* Use a copy of the descriptor for dummy arrays. */
1114 if (sym
->attr
.dimension
&& !TREE_USED (sym
->backend_decl
))
1116 decl
= gfc_build_dummy_array_decl (sym
, sym
->backend_decl
);
1117 /* Prevent the dummy from being detected as unused if it is copied. */
1118 if (sym
->backend_decl
!= NULL
&& decl
!= sym
->backend_decl
)
1119 DECL_ARTIFICIAL (sym
->backend_decl
) = 1;
1120 sym
->backend_decl
= decl
;
1123 TREE_USED (sym
->backend_decl
) = 1;
1124 if (sym
->attr
.assign
&& GFC_DECL_ASSIGN (sym
->backend_decl
) == 0)
1126 gfc_add_assign_aux_vars (sym
);
1129 if (sym
->attr
.dimension
1130 && DECL_LANG_SPECIFIC (sym
->backend_decl
)
1131 && GFC_DECL_SAVED_DESCRIPTOR (sym
->backend_decl
)
1132 && DECL_CONTEXT (sym
->backend_decl
) != current_function_decl
)
1133 gfc_nonlocal_dummy_array_decl (sym
);
1135 return sym
->backend_decl
;
1138 if (sym
->backend_decl
)
1139 return sym
->backend_decl
;
1141 /* If use associated and whole file compilation, use the module
1142 declaration. This is only needed for intrinsic types because
1143 they are substituted for one another during optimization. */
1144 if (gfc_option
.flag_whole_file
1145 && sym
->attr
.flavor
== FL_VARIABLE
1146 && sym
->ts
.type
!= BT_DERIVED
1147 && sym
->attr
.use_assoc
1152 gsym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->module
);
1153 if (gsym
&& gsym
->ns
&& gsym
->type
== GSYM_MODULE
)
1157 gfc_find_symbol (sym
->name
, gsym
->ns
, 0, &s
);
1158 if (s
&& s
->backend_decl
)
1160 if (sym
->ts
.type
== BT_CHARACTER
)
1161 sym
->ts
.u
.cl
->backend_decl
= s
->ts
.u
.cl
->backend_decl
;
1162 return s
->backend_decl
;
1167 /* Catch function declarations. Only used for actual parameters and
1168 procedure pointers. */
1169 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1171 decl
= gfc_get_extern_function_decl (sym
);
1172 gfc_set_decl_location (decl
, &sym
->declared_at
);
1176 if (sym
->attr
.intrinsic
)
1177 internal_error ("intrinsic variable which isn't a procedure");
1179 /* Create string length decl first so that they can be used in the
1180 type declaration. */
1181 if (sym
->ts
.type
== BT_CHARACTER
)
1182 length
= gfc_create_string_length (sym
);
1184 /* Create the decl for the variable. */
1185 decl
= build_decl (sym
->declared_at
.lb
->location
,
1186 VAR_DECL
, gfc_sym_identifier (sym
), gfc_sym_type (sym
));
1188 /* Add attributes to variables. Functions are handled elsewhere. */
1189 attributes
= add_attributes_to_decl (sym
->attr
, NULL_TREE
);
1190 decl_attributes (&decl
, attributes
, 0);
1192 /* Symbols from modules should have their assembler names mangled.
1193 This is done here rather than in gfc_finish_var_decl because it
1194 is different for string length variables. */
1197 gfc_set_decl_assembler_name (decl
, gfc_sym_mangled_identifier (sym
));
1198 if (sym
->attr
.use_assoc
)
1199 DECL_IGNORED_P (decl
) = 1;
1202 if (sym
->attr
.dimension
)
1204 /* Create variables to hold the non-constant bits of array info. */
1205 gfc_build_qualified_array (decl
, sym
);
1207 if ((sym
->attr
.allocatable
|| !sym
->attr
.dummy
) && !sym
->attr
.pointer
)
1208 GFC_DECL_PACKED_ARRAY (decl
) = 1;
1211 /* Remember this variable for allocation/cleanup. */
1212 if (sym
->attr
.dimension
|| sym
->attr
.allocatable
1213 || (sym
->ts
.type
== BT_CLASS
&&
1214 (sym
->ts
.u
.derived
->components
->attr
.dimension
1215 || sym
->ts
.u
.derived
->components
->attr
.allocatable
))
1216 || (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.alloc_comp
)
1217 /* This applies a derived type default initializer. */
1218 || (sym
->ts
.type
== BT_DERIVED
1219 && sym
->attr
.save
== SAVE_NONE
1221 && !sym
->attr
.allocatable
1222 && (sym
->value
&& !sym
->ns
->proc_name
->attr
.is_main_program
)
1223 && !sym
->attr
.use_assoc
))
1224 gfc_defer_symbol_init (sym
);
1226 gfc_finish_var_decl (decl
, sym
);
1228 if (sym
->ts
.type
== BT_CHARACTER
)
1230 /* Character variables need special handling. */
1231 gfc_allocate_lang_decl (decl
);
1233 if (TREE_CODE (length
) != INTEGER_CST
)
1235 char name
[GFC_MAX_MANGLED_SYMBOL_LEN
+ 2];
1239 /* Also prefix the mangled name for symbols from modules. */
1240 strcpy (&name
[1], sym
->name
);
1243 IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length
)));
1244 gfc_set_decl_assembler_name (decl
, get_identifier (name
));
1246 gfc_finish_var_decl (length
, sym
);
1247 gcc_assert (!sym
->value
);
1250 else if (sym
->attr
.subref_array_pointer
)
1252 /* We need the span for these beasts. */
1253 gfc_allocate_lang_decl (decl
);
1256 if (sym
->attr
.subref_array_pointer
)
1259 GFC_DECL_SUBREF_ARRAY_P (decl
) = 1;
1260 span
= build_decl (input_location
,
1261 VAR_DECL
, create_tmp_var_name ("span"),
1262 gfc_array_index_type
);
1263 gfc_finish_var_decl (span
, sym
);
1264 TREE_STATIC (span
) = TREE_STATIC (decl
);
1265 DECL_ARTIFICIAL (span
) = 1;
1266 DECL_INITIAL (span
) = build_int_cst (gfc_array_index_type
, 0);
1268 GFC_DECL_SPAN (decl
) = span
;
1269 GFC_TYPE_ARRAY_SPAN (TREE_TYPE (decl
)) = span
;
1272 sym
->backend_decl
= decl
;
1274 if (sym
->attr
.assign
)
1275 gfc_add_assign_aux_vars (sym
);
1277 if (TREE_STATIC (decl
) && !sym
->attr
.use_assoc
1278 && (sym
->attr
.save
|| sym
->ns
->proc_name
->attr
.is_main_program
1279 || gfc_option
.flag_max_stack_var_size
== 0
1280 || sym
->attr
.data
|| sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
))
1282 /* Add static initializer. For procedures, it is only needed if
1283 SAVE is specified otherwise they need to be reinitialized
1284 every time the procedure is entered. The TREE_STATIC is
1285 in this case due to -fmax-stack-var-size=. */
1286 DECL_INITIAL (decl
) = gfc_conv_initializer (sym
->value
, &sym
->ts
,
1287 TREE_TYPE (decl
), sym
->attr
.dimension
,
1288 sym
->attr
.pointer
|| sym
->attr
.allocatable
);
1291 if (!TREE_STATIC (decl
)
1292 && POINTER_TYPE_P (TREE_TYPE (decl
))
1293 && !sym
->attr
.pointer
1294 && !sym
->attr
.allocatable
1295 && !sym
->attr
.proc_pointer
)
1296 DECL_BY_REFERENCE (decl
) = 1;
1302 /* Substitute a temporary variable in place of the real one. */
1305 gfc_shadow_sym (gfc_symbol
* sym
, tree decl
, gfc_saved_var
* save
)
1307 save
->attr
= sym
->attr
;
1308 save
->decl
= sym
->backend_decl
;
1310 gfc_clear_attr (&sym
->attr
);
1311 sym
->attr
.referenced
= 1;
1312 sym
->attr
.flavor
= FL_VARIABLE
;
1314 sym
->backend_decl
= decl
;
1318 /* Restore the original variable. */
1321 gfc_restore_sym (gfc_symbol
* sym
, gfc_saved_var
* save
)
1323 sym
->attr
= save
->attr
;
1324 sym
->backend_decl
= save
->decl
;
1328 /* Declare a procedure pointer. */
1331 get_proc_pointer_decl (gfc_symbol
*sym
)
1336 decl
= sym
->backend_decl
;
1340 decl
= build_decl (input_location
,
1341 VAR_DECL
, get_identifier (sym
->name
),
1342 build_pointer_type (gfc_get_function_type (sym
)));
1344 if ((sym
->ns
->proc_name
1345 && sym
->ns
->proc_name
->backend_decl
== current_function_decl
)
1346 || sym
->attr
.contained
)
1347 gfc_add_decl_to_function (decl
);
1348 else if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
1349 gfc_add_decl_to_parent_function (decl
);
1351 sym
->backend_decl
= decl
;
1353 /* If a variable is USE associated, it's always external. */
1354 if (sym
->attr
.use_assoc
)
1356 DECL_EXTERNAL (decl
) = 1;
1357 TREE_PUBLIC (decl
) = 1;
1359 else if (sym
->module
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
1361 /* This is the declaration of a module variable. */
1362 TREE_PUBLIC (decl
) = 1;
1363 TREE_STATIC (decl
) = 1;
1366 if (!sym
->attr
.use_assoc
1367 && (sym
->attr
.save
!= SAVE_NONE
|| sym
->attr
.data
1368 || (sym
->value
&& sym
->ns
->proc_name
->attr
.is_main_program
)))
1369 TREE_STATIC (decl
) = 1;
1371 if (TREE_STATIC (decl
) && sym
->value
)
1373 /* Add static initializer. */
1374 DECL_INITIAL (decl
) = gfc_conv_initializer (sym
->value
, &sym
->ts
,
1376 sym
->attr
.proc_pointer
? false : sym
->attr
.dimension
,
1377 sym
->attr
.proc_pointer
);
1380 attributes
= add_attributes_to_decl (sym
->attr
, NULL_TREE
);
1381 decl_attributes (&decl
, attributes
, 0);
1387 /* Get a basic decl for an external function. */
1390 gfc_get_extern_function_decl (gfc_symbol
* sym
)
1396 gfc_intrinsic_sym
*isym
;
1398 char s
[GFC_MAX_SYMBOL_LEN
+ 23]; /* "_gfortran_f2c_specific" and '\0'. */
1403 if (sym
->backend_decl
)
1404 return sym
->backend_decl
;
1406 /* We should never be creating external decls for alternate entry points.
1407 The procedure may be an alternate entry point, but we don't want/need
1409 gcc_assert (!(sym
->attr
.entry
|| sym
->attr
.entry_master
));
1411 if (sym
->attr
.proc_pointer
)
1412 return get_proc_pointer_decl (sym
);
1414 /* See if this is an external procedure from the same file. If so,
1415 return the backend_decl. */
1416 gsym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->name
);
1418 if (gfc_option
.flag_whole_file
1419 && !sym
->attr
.use_assoc
1420 && !sym
->backend_decl
1422 && ((gsym
->type
== GSYM_SUBROUTINE
) || (gsym
->type
== GSYM_FUNCTION
))
1423 && gsym
->ns
->proc_name
->backend_decl
)
1425 /* If the namespace has entries, the proc_name is the
1426 entry master. Find the entry and use its backend_decl.
1427 otherwise, use the proc_name backend_decl. */
1428 if (gsym
->ns
->entries
)
1430 gfc_entry_list
*entry
= gsym
->ns
->entries
;
1432 for (; entry
; entry
= entry
->next
)
1434 if (strcmp (gsym
->name
, entry
->sym
->name
) == 0)
1436 sym
->backend_decl
= entry
->sym
->backend_decl
;
1443 sym
->backend_decl
= gsym
->ns
->proc_name
->backend_decl
;
1446 if (sym
->backend_decl
)
1447 return sym
->backend_decl
;
1450 /* See if this is a module procedure from the same file. If so,
1451 return the backend_decl. */
1453 gsym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->module
);
1455 if (gfc_option
.flag_whole_file
1457 && gsym
->type
== GSYM_MODULE
)
1462 gfc_find_symbol (sym
->name
, gsym
->ns
, 0, &s
);
1463 if (s
&& s
->backend_decl
)
1465 sym
->backend_decl
= s
->backend_decl
;
1466 return sym
->backend_decl
;
1470 if (sym
->attr
.intrinsic
)
1472 /* Call the resolution function to get the actual name. This is
1473 a nasty hack which relies on the resolution functions only looking
1474 at the first argument. We pass NULL for the second argument
1475 otherwise things like AINT get confused. */
1476 isym
= gfc_find_function (sym
->name
);
1477 gcc_assert (isym
->resolve
.f0
!= NULL
);
1479 memset (&e
, 0, sizeof (e
));
1480 e
.expr_type
= EXPR_FUNCTION
;
1482 memset (&argexpr
, 0, sizeof (argexpr
));
1483 gcc_assert (isym
->formal
);
1484 argexpr
.ts
= isym
->formal
->ts
;
1486 if (isym
->formal
->next
== NULL
)
1487 isym
->resolve
.f1 (&e
, &argexpr
);
1490 if (isym
->formal
->next
->next
== NULL
)
1491 isym
->resolve
.f2 (&e
, &argexpr
, NULL
);
1494 if (isym
->formal
->next
->next
->next
== NULL
)
1495 isym
->resolve
.f3 (&e
, &argexpr
, NULL
, NULL
);
1498 /* All specific intrinsics take less than 5 arguments. */
1499 gcc_assert (isym
->formal
->next
->next
->next
->next
== NULL
);
1500 isym
->resolve
.f4 (&e
, &argexpr
, NULL
, NULL
, NULL
);
1505 if (gfc_option
.flag_f2c
1506 && ((e
.ts
.type
== BT_REAL
&& e
.ts
.kind
== gfc_default_real_kind
)
1507 || e
.ts
.type
== BT_COMPLEX
))
1509 /* Specific which needs a different implementation if f2c
1510 calling conventions are used. */
1511 sprintf (s
, "_gfortran_f2c_specific%s", e
.value
.function
.name
);
1514 sprintf (s
, "_gfortran_specific%s", e
.value
.function
.name
);
1516 name
= get_identifier (s
);
1517 mangled_name
= name
;
1521 name
= gfc_sym_identifier (sym
);
1522 mangled_name
= gfc_sym_mangled_function_id (sym
);
1525 type
= gfc_get_function_type (sym
);
1526 fndecl
= build_decl (input_location
,
1527 FUNCTION_DECL
, name
, type
);
1529 attributes
= add_attributes_to_decl (sym
->attr
, NULL_TREE
);
1530 decl_attributes (&fndecl
, attributes
, 0);
1532 gfc_set_decl_assembler_name (fndecl
, mangled_name
);
1534 /* Set the context of this decl. */
1535 if (0 && sym
->ns
&& sym
->ns
->proc_name
)
1537 /* TODO: Add external decls to the appropriate scope. */
1538 DECL_CONTEXT (fndecl
) = sym
->ns
->proc_name
->backend_decl
;
1542 /* Global declaration, e.g. intrinsic subroutine. */
1543 DECL_CONTEXT (fndecl
) = NULL_TREE
;
1546 DECL_EXTERNAL (fndecl
) = 1;
1548 /* This specifies if a function is globally addressable, i.e. it is
1549 the opposite of declaring static in C. */
1550 TREE_PUBLIC (fndecl
) = 1;
1552 /* Set attributes for PURE functions. A call to PURE function in the
1553 Fortran 95 sense is both pure and without side effects in the C
1555 if (sym
->attr
.pure
|| sym
->attr
.elemental
)
1557 if (sym
->attr
.function
&& !gfc_return_by_reference (sym
))
1558 DECL_PURE_P (fndecl
) = 1;
1559 /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
1560 parameters and don't use alternate returns (is this
1561 allowed?). In that case, calls to them are meaningless, and
1562 can be optimized away. See also in build_function_decl(). */
1563 TREE_SIDE_EFFECTS (fndecl
) = 0;
1566 /* Mark non-returning functions. */
1567 if (sym
->attr
.noreturn
)
1568 TREE_THIS_VOLATILE(fndecl
) = 1;
1570 sym
->backend_decl
= fndecl
;
1572 if (DECL_CONTEXT (fndecl
) == NULL_TREE
)
1573 pushdecl_top_level (fndecl
);
1579 /* Create a declaration for a procedure. For external functions (in the C
1580 sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is
1581 a master function with alternate entry points. */
1584 build_function_decl (gfc_symbol
* sym
)
1586 tree fndecl
, type
, attributes
;
1587 symbol_attribute attr
;
1589 gfc_formal_arglist
*f
;
1591 gcc_assert (!sym
->backend_decl
);
1592 gcc_assert (!sym
->attr
.external
);
1594 /* Set the line and filename. sym->declared_at seems to point to the
1595 last statement for subroutines, but it'll do for now. */
1596 gfc_set_backend_locus (&sym
->declared_at
);
1598 /* Allow only one nesting level. Allow public declarations. */
1599 gcc_assert (current_function_decl
== NULL_TREE
1600 || DECL_CONTEXT (current_function_decl
) == NULL_TREE
1601 || TREE_CODE (DECL_CONTEXT (current_function_decl
))
1604 type
= gfc_get_function_type (sym
);
1605 fndecl
= build_decl (input_location
,
1606 FUNCTION_DECL
, gfc_sym_identifier (sym
), type
);
1610 attributes
= add_attributes_to_decl (attr
, NULL_TREE
);
1611 decl_attributes (&fndecl
, attributes
, 0);
1613 /* Perform name mangling if this is a top level or module procedure. */
1614 if (current_function_decl
== NULL_TREE
)
1615 gfc_set_decl_assembler_name (fndecl
, gfc_sym_mangled_function_id (sym
));
1617 /* Figure out the return type of the declared function, and build a
1618 RESULT_DECL for it. If this is a subroutine with alternate
1619 returns, build a RESULT_DECL for it. */
1620 result_decl
= NULL_TREE
;
1621 /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
1624 if (gfc_return_by_reference (sym
))
1625 type
= void_type_node
;
1628 if (sym
->result
!= sym
)
1629 result_decl
= gfc_sym_identifier (sym
->result
);
1631 type
= TREE_TYPE (TREE_TYPE (fndecl
));
1636 /* Look for alternate return placeholders. */
1637 int has_alternate_returns
= 0;
1638 for (f
= sym
->formal
; f
; f
= f
->next
)
1642 has_alternate_returns
= 1;
1647 if (has_alternate_returns
)
1648 type
= integer_type_node
;
1650 type
= void_type_node
;
1653 result_decl
= build_decl (input_location
,
1654 RESULT_DECL
, result_decl
, type
);
1655 DECL_ARTIFICIAL (result_decl
) = 1;
1656 DECL_IGNORED_P (result_decl
) = 1;
1657 DECL_CONTEXT (result_decl
) = fndecl
;
1658 DECL_RESULT (fndecl
) = result_decl
;
1660 /* Don't call layout_decl for a RESULT_DECL.
1661 layout_decl (result_decl, 0); */
1663 /* Set up all attributes for the function. */
1664 DECL_CONTEXT (fndecl
) = current_function_decl
;
1665 DECL_EXTERNAL (fndecl
) = 0;
1667 /* This specifies if a function is globally visible, i.e. it is
1668 the opposite of declaring static in C. */
1669 if (DECL_CONTEXT (fndecl
) == NULL_TREE
1670 && !sym
->attr
.entry_master
&& !sym
->attr
.is_main_program
)
1671 TREE_PUBLIC (fndecl
) = 1;
1673 /* TREE_STATIC means the function body is defined here. */
1674 TREE_STATIC (fndecl
) = 1;
1676 /* Set attributes for PURE functions. A call to a PURE function in the
1677 Fortran 95 sense is both pure and without side effects in the C
1679 if (attr
.pure
|| attr
.elemental
)
1681 /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
1682 including an alternate return. In that case it can also be
1683 marked as PURE. See also in gfc_get_extern_function_decl(). */
1684 if (attr
.function
&& !gfc_return_by_reference (sym
))
1685 DECL_PURE_P (fndecl
) = 1;
1686 TREE_SIDE_EFFECTS (fndecl
) = 0;
1690 /* Layout the function declaration and put it in the binding level
1691 of the current function. */
1694 sym
->backend_decl
= fndecl
;
1698 /* Create the DECL_ARGUMENTS for a procedure. */
1701 create_function_arglist (gfc_symbol
* sym
)
1704 gfc_formal_arglist
*f
;
1705 tree typelist
, hidden_typelist
;
1706 tree arglist
, hidden_arglist
;
1710 fndecl
= sym
->backend_decl
;
1712 /* Build formal argument list. Make sure that their TREE_CONTEXT is
1713 the new FUNCTION_DECL node. */
1714 arglist
= NULL_TREE
;
1715 hidden_arglist
= NULL_TREE
;
1716 typelist
= TYPE_ARG_TYPES (TREE_TYPE (fndecl
));
1718 if (sym
->attr
.entry_master
)
1720 type
= TREE_VALUE (typelist
);
1721 parm
= build_decl (input_location
,
1722 PARM_DECL
, get_identifier ("__entry"), type
);
1724 DECL_CONTEXT (parm
) = fndecl
;
1725 DECL_ARG_TYPE (parm
) = type
;
1726 TREE_READONLY (parm
) = 1;
1727 gfc_finish_decl (parm
);
1728 DECL_ARTIFICIAL (parm
) = 1;
1730 arglist
= chainon (arglist
, parm
);
1731 typelist
= TREE_CHAIN (typelist
);
1734 if (gfc_return_by_reference (sym
))
1736 tree type
= TREE_VALUE (typelist
), length
= NULL
;
1738 if (sym
->ts
.type
== BT_CHARACTER
)
1740 /* Length of character result. */
1741 tree len_type
= TREE_VALUE (TREE_CHAIN (typelist
));
1742 gcc_assert (len_type
== gfc_charlen_type_node
);
1744 length
= build_decl (input_location
,
1746 get_identifier (".__result"),
1748 if (!sym
->ts
.u
.cl
->length
)
1750 sym
->ts
.u
.cl
->backend_decl
= length
;
1751 TREE_USED (length
) = 1;
1753 gcc_assert (TREE_CODE (length
) == PARM_DECL
);
1754 DECL_CONTEXT (length
) = fndecl
;
1755 DECL_ARG_TYPE (length
) = len_type
;
1756 TREE_READONLY (length
) = 1;
1757 DECL_ARTIFICIAL (length
) = 1;
1758 gfc_finish_decl (length
);
1759 if (sym
->ts
.u
.cl
->backend_decl
== NULL
1760 || sym
->ts
.u
.cl
->backend_decl
== length
)
1765 if (sym
->ts
.u
.cl
->backend_decl
== NULL
)
1767 tree len
= build_decl (input_location
,
1769 get_identifier ("..__result"),
1770 gfc_charlen_type_node
);
1771 DECL_ARTIFICIAL (len
) = 1;
1772 TREE_USED (len
) = 1;
1773 sym
->ts
.u
.cl
->backend_decl
= len
;
1776 /* Make sure PARM_DECL type doesn't point to incomplete type. */
1777 arg
= sym
->result
? sym
->result
: sym
;
1778 backend_decl
= arg
->backend_decl
;
1779 /* Temporary clear it, so that gfc_sym_type creates complete
1781 arg
->backend_decl
= NULL
;
1782 type
= gfc_sym_type (arg
);
1783 arg
->backend_decl
= backend_decl
;
1784 type
= build_reference_type (type
);
1788 parm
= build_decl (input_location
,
1789 PARM_DECL
, get_identifier ("__result"), type
);
1791 DECL_CONTEXT (parm
) = fndecl
;
1792 DECL_ARG_TYPE (parm
) = TREE_VALUE (typelist
);
1793 TREE_READONLY (parm
) = 1;
1794 DECL_ARTIFICIAL (parm
) = 1;
1795 gfc_finish_decl (parm
);
1797 arglist
= chainon (arglist
, parm
);
1798 typelist
= TREE_CHAIN (typelist
);
1800 if (sym
->ts
.type
== BT_CHARACTER
)
1802 gfc_allocate_lang_decl (parm
);
1803 arglist
= chainon (arglist
, length
);
1804 typelist
= TREE_CHAIN (typelist
);
1808 hidden_typelist
= typelist
;
1809 for (f
= sym
->formal
; f
; f
= f
->next
)
1810 if (f
->sym
!= NULL
) /* Ignore alternate returns. */
1811 hidden_typelist
= TREE_CHAIN (hidden_typelist
);
1813 for (f
= sym
->formal
; f
; f
= f
->next
)
1815 char name
[GFC_MAX_SYMBOL_LEN
+ 2];
1817 /* Ignore alternate returns. */
1821 type
= TREE_VALUE (typelist
);
1823 if (f
->sym
->ts
.type
== BT_CHARACTER
1824 && (!sym
->attr
.is_bind_c
|| sym
->attr
.entry_master
))
1826 tree len_type
= TREE_VALUE (hidden_typelist
);
1827 tree length
= NULL_TREE
;
1828 gcc_assert (len_type
== gfc_charlen_type_node
);
1830 strcpy (&name
[1], f
->sym
->name
);
1832 length
= build_decl (input_location
,
1833 PARM_DECL
, get_identifier (name
), len_type
);
1835 hidden_arglist
= chainon (hidden_arglist
, length
);
1836 DECL_CONTEXT (length
) = fndecl
;
1837 DECL_ARTIFICIAL (length
) = 1;
1838 DECL_ARG_TYPE (length
) = len_type
;
1839 TREE_READONLY (length
) = 1;
1840 gfc_finish_decl (length
);
1842 /* Remember the passed value. */
1843 if (f
->sym
->ts
.u
.cl
->passed_length
!= NULL
)
1845 /* This can happen if the same type is used for multiple
1846 arguments. We need to copy cl as otherwise
1847 cl->passed_length gets overwritten. */
1848 f
->sym
->ts
.u
.cl
= gfc_new_charlen (f
->sym
->ns
, f
->sym
->ts
.u
.cl
);
1850 f
->sym
->ts
.u
.cl
->passed_length
= length
;
1852 /* Use the passed value for assumed length variables. */
1853 if (!f
->sym
->ts
.u
.cl
->length
)
1855 TREE_USED (length
) = 1;
1856 gcc_assert (!f
->sym
->ts
.u
.cl
->backend_decl
);
1857 f
->sym
->ts
.u
.cl
->backend_decl
= length
;
1860 hidden_typelist
= TREE_CHAIN (hidden_typelist
);
1862 if (f
->sym
->ts
.u
.cl
->backend_decl
== NULL
1863 || f
->sym
->ts
.u
.cl
->backend_decl
== length
)
1865 if (f
->sym
->ts
.u
.cl
->backend_decl
== NULL
)
1866 gfc_create_string_length (f
->sym
);
1868 /* Make sure PARM_DECL type doesn't point to incomplete type. */
1869 if (f
->sym
->attr
.flavor
== FL_PROCEDURE
)
1870 type
= build_pointer_type (gfc_get_function_type (f
->sym
));
1872 type
= gfc_sym_type (f
->sym
);
1876 /* For non-constant length array arguments, make sure they use
1877 a different type node from TYPE_ARG_TYPES type. */
1878 if (f
->sym
->attr
.dimension
1879 && type
== TREE_VALUE (typelist
)
1880 && TREE_CODE (type
) == POINTER_TYPE
1881 && GFC_ARRAY_TYPE_P (type
)
1882 && f
->sym
->as
->type
!= AS_ASSUMED_SIZE
1883 && ! COMPLETE_TYPE_P (TREE_TYPE (type
)))
1885 if (f
->sym
->attr
.flavor
== FL_PROCEDURE
)
1886 type
= build_pointer_type (gfc_get_function_type (f
->sym
));
1888 type
= gfc_sym_type (f
->sym
);
1891 if (f
->sym
->attr
.proc_pointer
)
1892 type
= build_pointer_type (type
);
1894 /* Build the argument declaration. */
1895 parm
= build_decl (input_location
,
1896 PARM_DECL
, gfc_sym_identifier (f
->sym
), type
);
1898 /* Fill in arg stuff. */
1899 DECL_CONTEXT (parm
) = fndecl
;
1900 DECL_ARG_TYPE (parm
) = TREE_VALUE (typelist
);
1901 /* All implementation args are read-only. */
1902 TREE_READONLY (parm
) = 1;
1903 if (POINTER_TYPE_P (type
)
1904 && (!f
->sym
->attr
.proc_pointer
1905 && f
->sym
->attr
.flavor
!= FL_PROCEDURE
))
1906 DECL_BY_REFERENCE (parm
) = 1;
1908 gfc_finish_decl (parm
);
1910 f
->sym
->backend_decl
= parm
;
1912 arglist
= chainon (arglist
, parm
);
1913 typelist
= TREE_CHAIN (typelist
);
1916 /* Add the hidden string length parameters, unless the procedure
1918 if (!sym
->attr
.is_bind_c
)
1919 arglist
= chainon (arglist
, hidden_arglist
);
1921 gcc_assert (hidden_typelist
== NULL_TREE
1922 || TREE_VALUE (hidden_typelist
) == void_type_node
);
1923 DECL_ARGUMENTS (fndecl
) = arglist
;
1926 /* Do the setup necessary before generating the body of a function. */
1929 trans_function_start (gfc_symbol
* sym
)
1933 fndecl
= sym
->backend_decl
;
1935 /* Let GCC know the current scope is this function. */
1936 current_function_decl
= fndecl
;
1938 /* Let the world know what we're about to do. */
1939 announce_function (fndecl
);
1941 if (DECL_CONTEXT (fndecl
) == NULL_TREE
)
1943 /* Create RTL for function declaration. */
1944 rest_of_decl_compilation (fndecl
, 1, 0);
1947 /* Create RTL for function definition. */
1948 make_decl_rtl (fndecl
);
1950 init_function_start (fndecl
);
1952 /* Even though we're inside a function body, we still don't want to
1953 call expand_expr to calculate the size of a variable-sized array.
1954 We haven't necessarily assigned RTL to all variables yet, so it's
1955 not safe to try to expand expressions involving them. */
1956 cfun
->dont_save_pending_sizes_p
= 1;
1958 /* function.c requires a push at the start of the function. */
1962 /* Create thunks for alternate entry points. */
1965 build_entry_thunks (gfc_namespace
* ns
)
1967 gfc_formal_arglist
*formal
;
1968 gfc_formal_arglist
*thunk_formal
;
1970 gfc_symbol
*thunk_sym
;
1978 /* This should always be a toplevel function. */
1979 gcc_assert (current_function_decl
== NULL_TREE
);
1981 gfc_get_backend_locus (&old_loc
);
1982 for (el
= ns
->entries
; el
; el
= el
->next
)
1984 thunk_sym
= el
->sym
;
1986 build_function_decl (thunk_sym
);
1987 create_function_arglist (thunk_sym
);
1989 trans_function_start (thunk_sym
);
1991 thunk_fndecl
= thunk_sym
->backend_decl
;
1993 gfc_init_block (&body
);
1995 /* Pass extra parameter identifying this entry point. */
1996 tmp
= build_int_cst (gfc_array_index_type
, el
->id
);
1997 args
= tree_cons (NULL_TREE
, tmp
, NULL_TREE
);
1998 string_args
= NULL_TREE
;
2000 if (thunk_sym
->attr
.function
)
2002 if (gfc_return_by_reference (ns
->proc_name
))
2004 tree ref
= DECL_ARGUMENTS (current_function_decl
);
2005 args
= tree_cons (NULL_TREE
, ref
, args
);
2006 if (ns
->proc_name
->ts
.type
== BT_CHARACTER
)
2007 args
= tree_cons (NULL_TREE
, TREE_CHAIN (ref
),
2012 for (formal
= ns
->proc_name
->formal
; formal
; formal
= formal
->next
)
2014 /* Ignore alternate returns. */
2015 if (formal
->sym
== NULL
)
2018 /* We don't have a clever way of identifying arguments, so resort to
2019 a brute-force search. */
2020 for (thunk_formal
= thunk_sym
->formal
;
2022 thunk_formal
= thunk_formal
->next
)
2024 if (thunk_formal
->sym
== formal
->sym
)
2030 /* Pass the argument. */
2031 DECL_ARTIFICIAL (thunk_formal
->sym
->backend_decl
) = 1;
2032 args
= tree_cons (NULL_TREE
, thunk_formal
->sym
->backend_decl
,
2034 if (formal
->sym
->ts
.type
== BT_CHARACTER
)
2036 tmp
= thunk_formal
->sym
->ts
.u
.cl
->backend_decl
;
2037 string_args
= tree_cons (NULL_TREE
, tmp
, string_args
);
2042 /* Pass NULL for a missing argument. */
2043 args
= tree_cons (NULL_TREE
, null_pointer_node
, args
);
2044 if (formal
->sym
->ts
.type
== BT_CHARACTER
)
2046 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
2047 string_args
= tree_cons (NULL_TREE
, tmp
, string_args
);
2052 /* Call the master function. */
2053 args
= nreverse (args
);
2054 args
= chainon (args
, nreverse (string_args
));
2055 tmp
= ns
->proc_name
->backend_decl
;
2056 tmp
= build_function_call_expr (input_location
, tmp
, args
);
2057 if (ns
->proc_name
->attr
.mixed_entry_master
)
2059 tree union_decl
, field
;
2060 tree master_type
= TREE_TYPE (ns
->proc_name
->backend_decl
);
2062 union_decl
= build_decl (input_location
,
2063 VAR_DECL
, get_identifier ("__result"),
2064 TREE_TYPE (master_type
));
2065 DECL_ARTIFICIAL (union_decl
) = 1;
2066 DECL_EXTERNAL (union_decl
) = 0;
2067 TREE_PUBLIC (union_decl
) = 0;
2068 TREE_USED (union_decl
) = 1;
2069 layout_decl (union_decl
, 0);
2070 pushdecl (union_decl
);
2072 DECL_CONTEXT (union_decl
) = current_function_decl
;
2073 tmp
= fold_build2 (MODIFY_EXPR
, TREE_TYPE (union_decl
),
2075 gfc_add_expr_to_block (&body
, tmp
);
2077 for (field
= TYPE_FIELDS (TREE_TYPE (union_decl
));
2078 field
; field
= TREE_CHAIN (field
))
2079 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field
)),
2080 thunk_sym
->result
->name
) == 0)
2082 gcc_assert (field
!= NULL_TREE
);
2083 tmp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (field
),
2084 union_decl
, field
, NULL_TREE
);
2085 tmp
= fold_build2 (MODIFY_EXPR
,
2086 TREE_TYPE (DECL_RESULT (current_function_decl
)),
2087 DECL_RESULT (current_function_decl
), tmp
);
2088 tmp
= build1_v (RETURN_EXPR
, tmp
);
2090 else if (TREE_TYPE (DECL_RESULT (current_function_decl
))
2093 tmp
= fold_build2 (MODIFY_EXPR
,
2094 TREE_TYPE (DECL_RESULT (current_function_decl
)),
2095 DECL_RESULT (current_function_decl
), tmp
);
2096 tmp
= build1_v (RETURN_EXPR
, tmp
);
2098 gfc_add_expr_to_block (&body
, tmp
);
2100 /* Finish off this function and send it for code generation. */
2101 DECL_SAVED_TREE (thunk_fndecl
) = gfc_finish_block (&body
);
2104 BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl
)) = thunk_fndecl
;
2105 DECL_SAVED_TREE (thunk_fndecl
)
2106 = build3_v (BIND_EXPR
, tmp
, DECL_SAVED_TREE (thunk_fndecl
),
2107 DECL_INITIAL (thunk_fndecl
));
2109 /* Output the GENERIC tree. */
2110 dump_function (TDI_original
, thunk_fndecl
);
2112 /* Store the end of the function, so that we get good line number
2113 info for the epilogue. */
2114 cfun
->function_end_locus
= input_location
;
2116 /* We're leaving the context of this function, so zap cfun.
2117 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
2118 tree_rest_of_compilation. */
2121 current_function_decl
= NULL_TREE
;
2123 cgraph_finalize_function (thunk_fndecl
, true);
2125 /* We share the symbols in the formal argument list with other entry
2126 points and the master function. Clear them so that they are
2127 recreated for each function. */
2128 for (formal
= thunk_sym
->formal
; formal
; formal
= formal
->next
)
2129 if (formal
->sym
!= NULL
) /* Ignore alternate returns. */
2131 formal
->sym
->backend_decl
= NULL_TREE
;
2132 if (formal
->sym
->ts
.type
== BT_CHARACTER
)
2133 formal
->sym
->ts
.u
.cl
->backend_decl
= NULL_TREE
;
2136 if (thunk_sym
->attr
.function
)
2138 if (thunk_sym
->ts
.type
== BT_CHARACTER
)
2139 thunk_sym
->ts
.u
.cl
->backend_decl
= NULL_TREE
;
2140 if (thunk_sym
->result
->ts
.type
== BT_CHARACTER
)
2141 thunk_sym
->result
->ts
.u
.cl
->backend_decl
= NULL_TREE
;
2145 gfc_set_backend_locus (&old_loc
);
2149 /* Create a decl for a function, and create any thunks for alternate entry
2153 gfc_create_function_decl (gfc_namespace
* ns
)
2155 /* Create a declaration for the master function. */
2156 build_function_decl (ns
->proc_name
);
2158 /* Compile the entry thunks. */
2160 build_entry_thunks (ns
);
2162 /* Now create the read argument list. */
2163 create_function_arglist (ns
->proc_name
);
2166 /* Return the decl used to hold the function return value. If
2167 parent_flag is set, the context is the parent_scope. */
2170 gfc_get_fake_result_decl (gfc_symbol
* sym
, int parent_flag
)
2174 tree this_fake_result_decl
;
2175 tree this_function_decl
;
2177 char name
[GFC_MAX_SYMBOL_LEN
+ 10];
2181 this_fake_result_decl
= parent_fake_result_decl
;
2182 this_function_decl
= DECL_CONTEXT (current_function_decl
);
2186 this_fake_result_decl
= current_fake_result_decl
;
2187 this_function_decl
= current_function_decl
;
2191 && sym
->ns
->proc_name
->backend_decl
== this_function_decl
2192 && sym
->ns
->proc_name
->attr
.entry_master
2193 && sym
!= sym
->ns
->proc_name
)
2196 if (this_fake_result_decl
!= NULL
)
2197 for (t
= TREE_CHAIN (this_fake_result_decl
); t
; t
= TREE_CHAIN (t
))
2198 if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t
)), sym
->name
) == 0)
2201 return TREE_VALUE (t
);
2202 decl
= gfc_get_fake_result_decl (sym
->ns
->proc_name
, parent_flag
);
2205 this_fake_result_decl
= parent_fake_result_decl
;
2207 this_fake_result_decl
= current_fake_result_decl
;
2209 if (decl
&& sym
->ns
->proc_name
->attr
.mixed_entry_master
)
2213 for (field
= TYPE_FIELDS (TREE_TYPE (decl
));
2214 field
; field
= TREE_CHAIN (field
))
2215 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field
)),
2219 gcc_assert (field
!= NULL_TREE
);
2220 decl
= fold_build3 (COMPONENT_REF
, TREE_TYPE (field
),
2221 decl
, field
, NULL_TREE
);
2224 var
= create_tmp_var_raw (TREE_TYPE (decl
), sym
->name
);
2226 gfc_add_decl_to_parent_function (var
);
2228 gfc_add_decl_to_function (var
);
2230 SET_DECL_VALUE_EXPR (var
, decl
);
2231 DECL_HAS_VALUE_EXPR_P (var
) = 1;
2232 GFC_DECL_RESULT (var
) = 1;
2234 TREE_CHAIN (this_fake_result_decl
)
2235 = tree_cons (get_identifier (sym
->name
), var
,
2236 TREE_CHAIN (this_fake_result_decl
));
2240 if (this_fake_result_decl
!= NULL_TREE
)
2241 return TREE_VALUE (this_fake_result_decl
);
2243 /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
2248 if (sym
->ts
.type
== BT_CHARACTER
)
2250 if (sym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
2251 length
= gfc_create_string_length (sym
);
2253 length
= sym
->ts
.u
.cl
->backend_decl
;
2254 if (TREE_CODE (length
) == VAR_DECL
2255 && DECL_CONTEXT (length
) == NULL_TREE
)
2256 gfc_add_decl_to_function (length
);
2259 if (gfc_return_by_reference (sym
))
2261 decl
= DECL_ARGUMENTS (this_function_decl
);
2263 if (sym
->ns
->proc_name
->backend_decl
== this_function_decl
2264 && sym
->ns
->proc_name
->attr
.entry_master
)
2265 decl
= TREE_CHAIN (decl
);
2267 TREE_USED (decl
) = 1;
2269 decl
= gfc_build_dummy_array_decl (sym
, decl
);
2273 sprintf (name
, "__result_%.20s",
2274 IDENTIFIER_POINTER (DECL_NAME (this_function_decl
)));
2276 if (!sym
->attr
.mixed_entry_master
&& sym
->attr
.function
)
2277 decl
= build_decl (input_location
,
2278 VAR_DECL
, get_identifier (name
),
2279 gfc_sym_type (sym
));
2281 decl
= build_decl (input_location
,
2282 VAR_DECL
, get_identifier (name
),
2283 TREE_TYPE (TREE_TYPE (this_function_decl
)));
2284 DECL_ARTIFICIAL (decl
) = 1;
2285 DECL_EXTERNAL (decl
) = 0;
2286 TREE_PUBLIC (decl
) = 0;
2287 TREE_USED (decl
) = 1;
2288 GFC_DECL_RESULT (decl
) = 1;
2289 TREE_ADDRESSABLE (decl
) = 1;
2291 layout_decl (decl
, 0);
2294 gfc_add_decl_to_parent_function (decl
);
2296 gfc_add_decl_to_function (decl
);
2300 parent_fake_result_decl
= build_tree_list (NULL
, decl
);
2302 current_fake_result_decl
= build_tree_list (NULL
, decl
);
2308 /* Builds a function decl. The remaining parameters are the types of the
2309 function arguments. Negative nargs indicates a varargs function. */
2312 gfc_build_library_function_decl (tree name
, tree rettype
, int nargs
, ...)
2321 /* Library functions must be declared with global scope. */
2322 gcc_assert (current_function_decl
== NULL_TREE
);
2324 va_start (p
, nargs
);
2327 /* Create a list of the argument types. */
2328 for (arglist
= NULL_TREE
, n
= abs (nargs
); n
> 0; n
--)
2330 argtype
= va_arg (p
, tree
);
2331 arglist
= gfc_chainon_list (arglist
, argtype
);
2336 /* Terminate the list. */
2337 arglist
= gfc_chainon_list (arglist
, void_type_node
);
2340 /* Build the function type and decl. */
2341 fntype
= build_function_type (rettype
, arglist
);
2342 fndecl
= build_decl (input_location
,
2343 FUNCTION_DECL
, name
, fntype
);
2345 /* Mark this decl as external. */
2346 DECL_EXTERNAL (fndecl
) = 1;
2347 TREE_PUBLIC (fndecl
) = 1;
2353 rest_of_decl_compilation (fndecl
, 1, 0);
2359 gfc_build_intrinsic_function_decls (void)
2361 tree gfc_int4_type_node
= gfc_get_int_type (4);
2362 tree gfc_int8_type_node
= gfc_get_int_type (8);
2363 tree gfc_int16_type_node
= gfc_get_int_type (16);
2364 tree gfc_logical4_type_node
= gfc_get_logical_type (4);
2365 tree pchar1_type_node
= gfc_get_pchar_type (1);
2366 tree pchar4_type_node
= gfc_get_pchar_type (4);
2368 /* String functions. */
2369 gfor_fndecl_compare_string
=
2370 gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),
2371 integer_type_node
, 4,
2372 gfc_charlen_type_node
, pchar1_type_node
,
2373 gfc_charlen_type_node
, pchar1_type_node
);
2375 gfor_fndecl_concat_string
=
2376 gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),
2378 gfc_charlen_type_node
, pchar1_type_node
,
2379 gfc_charlen_type_node
, pchar1_type_node
,
2380 gfc_charlen_type_node
, pchar1_type_node
);
2382 gfor_fndecl_string_len_trim
=
2383 gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")),
2384 gfc_int4_type_node
, 2,
2385 gfc_charlen_type_node
, pchar1_type_node
);
2387 gfor_fndecl_string_index
=
2388 gfc_build_library_function_decl (get_identifier (PREFIX("string_index")),
2389 gfc_int4_type_node
, 5,
2390 gfc_charlen_type_node
, pchar1_type_node
,
2391 gfc_charlen_type_node
, pchar1_type_node
,
2392 gfc_logical4_type_node
);
2394 gfor_fndecl_string_scan
=
2395 gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")),
2396 gfc_int4_type_node
, 5,
2397 gfc_charlen_type_node
, pchar1_type_node
,
2398 gfc_charlen_type_node
, pchar1_type_node
,
2399 gfc_logical4_type_node
);
2401 gfor_fndecl_string_verify
=
2402 gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")),
2403 gfc_int4_type_node
, 5,
2404 gfc_charlen_type_node
, pchar1_type_node
,
2405 gfc_charlen_type_node
, pchar1_type_node
,
2406 gfc_logical4_type_node
);
2408 gfor_fndecl_string_trim
=
2409 gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),
2411 build_pointer_type (gfc_charlen_type_node
),
2412 build_pointer_type (pchar1_type_node
),
2413 gfc_charlen_type_node
, pchar1_type_node
);
2415 gfor_fndecl_string_minmax
=
2416 gfc_build_library_function_decl (get_identifier (PREFIX("string_minmax")),
2418 build_pointer_type (gfc_charlen_type_node
),
2419 build_pointer_type (pchar1_type_node
),
2420 integer_type_node
, integer_type_node
);
2422 gfor_fndecl_adjustl
=
2423 gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),
2424 void_type_node
, 3, pchar1_type_node
,
2425 gfc_charlen_type_node
, pchar1_type_node
);
2427 gfor_fndecl_adjustr
=
2428 gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")),
2429 void_type_node
, 3, pchar1_type_node
,
2430 gfc_charlen_type_node
, pchar1_type_node
);
2432 gfor_fndecl_select_string
=
2433 gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
2434 integer_type_node
, 4, pvoid_type_node
,
2435 integer_type_node
, pchar1_type_node
,
2436 gfc_charlen_type_node
);
2438 gfor_fndecl_compare_string_char4
=
2439 gfc_build_library_function_decl (get_identifier
2440 (PREFIX("compare_string_char4")),
2441 integer_type_node
, 4,
2442 gfc_charlen_type_node
, pchar4_type_node
,
2443 gfc_charlen_type_node
, pchar4_type_node
);
2445 gfor_fndecl_concat_string_char4
=
2446 gfc_build_library_function_decl (get_identifier
2447 (PREFIX("concat_string_char4")),
2449 gfc_charlen_type_node
, pchar4_type_node
,
2450 gfc_charlen_type_node
, pchar4_type_node
,
2451 gfc_charlen_type_node
, pchar4_type_node
);
2453 gfor_fndecl_string_len_trim_char4
=
2454 gfc_build_library_function_decl (get_identifier
2455 (PREFIX("string_len_trim_char4")),
2456 gfc_charlen_type_node
, 2,
2457 gfc_charlen_type_node
, pchar4_type_node
);
2459 gfor_fndecl_string_index_char4
=
2460 gfc_build_library_function_decl (get_identifier
2461 (PREFIX("string_index_char4")),
2462 gfc_charlen_type_node
, 5,
2463 gfc_charlen_type_node
, pchar4_type_node
,
2464 gfc_charlen_type_node
, pchar4_type_node
,
2465 gfc_logical4_type_node
);
2467 gfor_fndecl_string_scan_char4
=
2468 gfc_build_library_function_decl (get_identifier
2469 (PREFIX("string_scan_char4")),
2470 gfc_charlen_type_node
, 5,
2471 gfc_charlen_type_node
, pchar4_type_node
,
2472 gfc_charlen_type_node
, pchar4_type_node
,
2473 gfc_logical4_type_node
);
2475 gfor_fndecl_string_verify_char4
=
2476 gfc_build_library_function_decl (get_identifier
2477 (PREFIX("string_verify_char4")),
2478 gfc_charlen_type_node
, 5,
2479 gfc_charlen_type_node
, pchar4_type_node
,
2480 gfc_charlen_type_node
, pchar4_type_node
,
2481 gfc_logical4_type_node
);
2483 gfor_fndecl_string_trim_char4
=
2484 gfc_build_library_function_decl (get_identifier
2485 (PREFIX("string_trim_char4")),
2487 build_pointer_type (gfc_charlen_type_node
),
2488 build_pointer_type (pchar4_type_node
),
2489 gfc_charlen_type_node
, pchar4_type_node
);
2491 gfor_fndecl_string_minmax_char4
=
2492 gfc_build_library_function_decl (get_identifier
2493 (PREFIX("string_minmax_char4")),
2495 build_pointer_type (gfc_charlen_type_node
),
2496 build_pointer_type (pchar4_type_node
),
2497 integer_type_node
, integer_type_node
);
2499 gfor_fndecl_adjustl_char4
=
2500 gfc_build_library_function_decl (get_identifier (PREFIX("adjustl_char4")),
2501 void_type_node
, 3, pchar4_type_node
,
2502 gfc_charlen_type_node
, pchar4_type_node
);
2504 gfor_fndecl_adjustr_char4
=
2505 gfc_build_library_function_decl (get_identifier (PREFIX("adjustr_char4")),
2506 void_type_node
, 3, pchar4_type_node
,
2507 gfc_charlen_type_node
, pchar4_type_node
);
2509 gfor_fndecl_select_string_char4
=
2510 gfc_build_library_function_decl (get_identifier
2511 (PREFIX("select_string_char4")),
2512 integer_type_node
, 4, pvoid_type_node
,
2513 integer_type_node
, pvoid_type_node
,
2514 gfc_charlen_type_node
);
2517 /* Conversion between character kinds. */
2519 gfor_fndecl_convert_char1_to_char4
=
2520 gfc_build_library_function_decl (get_identifier
2521 (PREFIX("convert_char1_to_char4")),
2523 build_pointer_type (pchar4_type_node
),
2524 gfc_charlen_type_node
, pchar1_type_node
);
2526 gfor_fndecl_convert_char4_to_char1
=
2527 gfc_build_library_function_decl (get_identifier
2528 (PREFIX("convert_char4_to_char1")),
2530 build_pointer_type (pchar1_type_node
),
2531 gfc_charlen_type_node
, pchar4_type_node
);
2533 /* Misc. functions. */
2535 gfor_fndecl_ttynam
=
2536 gfc_build_library_function_decl (get_identifier (PREFIX("ttynam")),
2540 gfc_charlen_type_node
,
2544 gfc_build_library_function_decl (get_identifier (PREFIX("fdate")),
2548 gfc_charlen_type_node
);
2551 gfc_build_library_function_decl (get_identifier (PREFIX("ctime")),
2555 gfc_charlen_type_node
,
2556 gfc_int8_type_node
);
2558 gfor_fndecl_sc_kind
=
2559 gfc_build_library_function_decl (get_identifier
2560 (PREFIX("selected_char_kind")),
2561 gfc_int4_type_node
, 2,
2562 gfc_charlen_type_node
, pchar_type_node
);
2564 gfor_fndecl_si_kind
=
2565 gfc_build_library_function_decl (get_identifier
2566 (PREFIX("selected_int_kind")),
2567 gfc_int4_type_node
, 1, pvoid_type_node
);
2569 gfor_fndecl_sr_kind
=
2570 gfc_build_library_function_decl (get_identifier
2571 (PREFIX("selected_real_kind")),
2572 gfc_int4_type_node
, 2,
2573 pvoid_type_node
, pvoid_type_node
);
2575 /* Power functions. */
2577 tree ctype
, rtype
, itype
, jtype
;
2578 int rkind
, ikind
, jkind
;
2581 static int ikinds
[NIKINDS
] = {4, 8, 16};
2582 static int rkinds
[NRKINDS
] = {4, 8, 10, 16};
2583 char name
[PREFIX_LEN
+ 12]; /* _gfortran_pow_?n_?n */
2585 for (ikind
=0; ikind
< NIKINDS
; ikind
++)
2587 itype
= gfc_get_int_type (ikinds
[ikind
]);
2589 for (jkind
=0; jkind
< NIKINDS
; jkind
++)
2591 jtype
= gfc_get_int_type (ikinds
[jkind
]);
2594 sprintf(name
, PREFIX("pow_i%d_i%d"), ikinds
[ikind
],
2596 gfor_fndecl_math_powi
[jkind
][ikind
].integer
=
2597 gfc_build_library_function_decl (get_identifier (name
),
2598 jtype
, 2, jtype
, itype
);
2599 TREE_READONLY (gfor_fndecl_math_powi
[jkind
][ikind
].integer
) = 1;
2603 for (rkind
= 0; rkind
< NRKINDS
; rkind
++)
2605 rtype
= gfc_get_real_type (rkinds
[rkind
]);
2608 sprintf(name
, PREFIX("pow_r%d_i%d"), rkinds
[rkind
],
2610 gfor_fndecl_math_powi
[rkind
][ikind
].real
=
2611 gfc_build_library_function_decl (get_identifier (name
),
2612 rtype
, 2, rtype
, itype
);
2613 TREE_READONLY (gfor_fndecl_math_powi
[rkind
][ikind
].real
) = 1;
2616 ctype
= gfc_get_complex_type (rkinds
[rkind
]);
2619 sprintf(name
, PREFIX("pow_c%d_i%d"), rkinds
[rkind
],
2621 gfor_fndecl_math_powi
[rkind
][ikind
].cmplx
=
2622 gfc_build_library_function_decl (get_identifier (name
),
2623 ctype
, 2,ctype
, itype
);
2624 TREE_READONLY (gfor_fndecl_math_powi
[rkind
][ikind
].cmplx
) = 1;
2632 gfor_fndecl_math_ishftc4
=
2633 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")),
2635 3, gfc_int4_type_node
,
2636 gfc_int4_type_node
, gfc_int4_type_node
);
2637 gfor_fndecl_math_ishftc8
=
2638 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")),
2640 3, gfc_int8_type_node
,
2641 gfc_int4_type_node
, gfc_int4_type_node
);
2642 if (gfc_int16_type_node
)
2643 gfor_fndecl_math_ishftc16
=
2644 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc16")),
2645 gfc_int16_type_node
, 3,
2646 gfc_int16_type_node
,
2648 gfc_int4_type_node
);
2650 /* BLAS functions. */
2652 tree pint
= build_pointer_type (integer_type_node
);
2653 tree ps
= build_pointer_type (gfc_get_real_type (gfc_default_real_kind
));
2654 tree pd
= build_pointer_type (gfc_get_real_type (gfc_default_double_kind
));
2655 tree pc
= build_pointer_type (gfc_get_complex_type (gfc_default_real_kind
));
2656 tree pz
= build_pointer_type
2657 (gfc_get_complex_type (gfc_default_double_kind
));
2659 gfor_fndecl_sgemm
= gfc_build_library_function_decl
2661 (gfc_option
.flag_underscoring
? "sgemm_"
2663 void_type_node
, 15, pchar_type_node
,
2664 pchar_type_node
, pint
, pint
, pint
, ps
, ps
, pint
,
2665 ps
, pint
, ps
, ps
, pint
, integer_type_node
,
2667 gfor_fndecl_dgemm
= gfc_build_library_function_decl
2669 (gfc_option
.flag_underscoring
? "dgemm_"
2671 void_type_node
, 15, pchar_type_node
,
2672 pchar_type_node
, pint
, pint
, pint
, pd
, pd
, pint
,
2673 pd
, pint
, pd
, pd
, pint
, integer_type_node
,
2675 gfor_fndecl_cgemm
= gfc_build_library_function_decl
2677 (gfc_option
.flag_underscoring
? "cgemm_"
2679 void_type_node
, 15, pchar_type_node
,
2680 pchar_type_node
, pint
, pint
, pint
, pc
, pc
, pint
,
2681 pc
, pint
, pc
, pc
, pint
, integer_type_node
,
2683 gfor_fndecl_zgemm
= gfc_build_library_function_decl
2685 (gfc_option
.flag_underscoring
? "zgemm_"
2687 void_type_node
, 15, pchar_type_node
,
2688 pchar_type_node
, pint
, pint
, pint
, pz
, pz
, pint
,
2689 pz
, pint
, pz
, pz
, pint
, integer_type_node
,
2693 /* Other functions. */
2695 gfc_build_library_function_decl (get_identifier (PREFIX("size0")),
2696 gfc_array_index_type
,
2697 1, pvoid_type_node
);
2699 gfc_build_library_function_decl (get_identifier (PREFIX("size1")),
2700 gfc_array_index_type
,
2702 gfc_array_index_type
);
2705 gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),
2709 if (gfc_type_for_size (128, true))
2711 tree uint128
= gfc_type_for_size (128, true);
2713 gfor_fndecl_clz128
=
2714 gfc_build_library_function_decl (get_identifier (PREFIX ("clz128")),
2715 integer_type_node
, 1, uint128
);
2717 gfor_fndecl_ctz128
=
2718 gfc_build_library_function_decl (get_identifier (PREFIX ("ctz128")),
2719 integer_type_node
, 1, uint128
);
2724 /* Make prototypes for runtime library functions. */
2727 gfc_build_builtin_function_decls (void)
2729 tree gfc_int4_type_node
= gfc_get_int_type (4);
2731 gfor_fndecl_stop_numeric
=
2732 gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
2733 void_type_node
, 1, gfc_int4_type_node
);
2734 /* Stop doesn't return. */
2735 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric
) = 1;
2737 gfor_fndecl_stop_string
=
2738 gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),
2739 void_type_node
, 2, pchar_type_node
,
2740 gfc_int4_type_node
);
2741 /* Stop doesn't return. */
2742 TREE_THIS_VOLATILE (gfor_fndecl_stop_string
) = 1;
2744 gfor_fndecl_error_stop_string
=
2745 gfc_build_library_function_decl (get_identifier (PREFIX("error_stop_string")),
2746 void_type_node
, 2, pchar_type_node
,
2747 gfc_int4_type_node
);
2748 /* ERROR STOP doesn't return. */
2749 TREE_THIS_VOLATILE (gfor_fndecl_error_stop_string
) = 1;
2751 gfor_fndecl_pause_numeric
=
2752 gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
2753 void_type_node
, 1, gfc_int4_type_node
);
2755 gfor_fndecl_pause_string
=
2756 gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")),
2757 void_type_node
, 2, pchar_type_node
,
2758 gfc_int4_type_node
);
2760 gfor_fndecl_runtime_error
=
2761 gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
2762 void_type_node
, -1, pchar_type_node
);
2763 /* The runtime_error function does not return. */
2764 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error
) = 1;
2766 gfor_fndecl_runtime_error_at
=
2767 gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error_at")),
2768 void_type_node
, -2, pchar_type_node
,
2770 /* The runtime_error_at function does not return. */
2771 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at
) = 1;
2773 gfor_fndecl_runtime_warning_at
=
2774 gfc_build_library_function_decl (get_identifier (PREFIX("runtime_warning_at")),
2775 void_type_node
, -2, pchar_type_node
,
2777 gfor_fndecl_generate_error
=
2778 gfc_build_library_function_decl (get_identifier (PREFIX("generate_error")),
2779 void_type_node
, 3, pvoid_type_node
,
2780 integer_type_node
, pchar_type_node
);
2782 gfor_fndecl_os_error
=
2783 gfc_build_library_function_decl (get_identifier (PREFIX("os_error")),
2784 void_type_node
, 1, pchar_type_node
);
2785 /* The runtime_error function does not return. */
2786 TREE_THIS_VOLATILE (gfor_fndecl_os_error
) = 1;
2788 gfor_fndecl_set_args
=
2789 gfc_build_library_function_decl (get_identifier (PREFIX("set_args")),
2790 void_type_node
, 2, integer_type_node
,
2791 build_pointer_type (pchar_type_node
));
2793 gfor_fndecl_set_fpe
=
2794 gfc_build_library_function_decl (get_identifier (PREFIX("set_fpe")),
2795 void_type_node
, 1, integer_type_node
);
2797 /* Keep the array dimension in sync with the call, later in this file. */
2798 gfor_fndecl_set_options
=
2799 gfc_build_library_function_decl (get_identifier (PREFIX("set_options")),
2800 void_type_node
, 2, integer_type_node
,
2801 build_pointer_type (integer_type_node
));
2803 gfor_fndecl_set_convert
=
2804 gfc_build_library_function_decl (get_identifier (PREFIX("set_convert")),
2805 void_type_node
, 1, integer_type_node
);
2807 gfor_fndecl_set_record_marker
=
2808 gfc_build_library_function_decl (get_identifier (PREFIX("set_record_marker")),
2809 void_type_node
, 1, integer_type_node
);
2811 gfor_fndecl_set_max_subrecord_length
=
2812 gfc_build_library_function_decl (get_identifier (PREFIX("set_max_subrecord_length")),
2813 void_type_node
, 1, integer_type_node
);
2815 gfor_fndecl_in_pack
= gfc_build_library_function_decl (
2816 get_identifier (PREFIX("internal_pack")),
2817 pvoid_type_node
, 1, pvoid_type_node
);
2819 gfor_fndecl_in_unpack
= gfc_build_library_function_decl (
2820 get_identifier (PREFIX("internal_unpack")),
2821 void_type_node
, 2, pvoid_type_node
, pvoid_type_node
);
2823 gfor_fndecl_associated
=
2824 gfc_build_library_function_decl (
2825 get_identifier (PREFIX("associated")),
2826 integer_type_node
, 2, ppvoid_type_node
,
2829 gfc_build_intrinsic_function_decls ();
2830 gfc_build_intrinsic_lib_fndecls ();
2831 gfc_build_io_library_fndecls ();
2835 /* Evaluate the length of dummy character variables. */
2838 gfc_trans_dummy_character (gfc_symbol
*sym
, gfc_charlen
*cl
, tree fnbody
)
2842 gfc_finish_decl (cl
->backend_decl
);
2844 gfc_start_block (&body
);
2846 /* Evaluate the string length expression. */
2847 gfc_conv_string_length (cl
, NULL
, &body
);
2849 gfc_trans_vla_type_sizes (sym
, &body
);
2851 gfc_add_expr_to_block (&body
, fnbody
);
2852 return gfc_finish_block (&body
);
2856 /* Allocate and cleanup an automatic character variable. */
2859 gfc_trans_auto_character_variable (gfc_symbol
* sym
, tree fnbody
)
2865 gcc_assert (sym
->backend_decl
);
2866 gcc_assert (sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
);
2868 gfc_start_block (&body
);
2870 /* Evaluate the string length expression. */
2871 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &body
);
2873 gfc_trans_vla_type_sizes (sym
, &body
);
2875 decl
= sym
->backend_decl
;
2877 /* Emit a DECL_EXPR for this variable, which will cause the
2878 gimplifier to allocate storage, and all that good stuff. */
2879 tmp
= fold_build1 (DECL_EXPR
, TREE_TYPE (decl
), decl
);
2880 gfc_add_expr_to_block (&body
, tmp
);
2882 gfc_add_expr_to_block (&body
, fnbody
);
2883 return gfc_finish_block (&body
);
2886 /* Set the initial value of ASSIGN statement auxiliary variable explicitly. */
2889 gfc_trans_assign_aux_var (gfc_symbol
* sym
, tree fnbody
)
2893 gcc_assert (sym
->backend_decl
);
2894 gfc_start_block (&body
);
2896 /* Set the initial value to length. See the comments in
2897 function gfc_add_assign_aux_vars in this file. */
2898 gfc_add_modify (&body
, GFC_DECL_STRING_LEN (sym
->backend_decl
),
2899 build_int_cst (NULL_TREE
, -2));
2901 gfc_add_expr_to_block (&body
, fnbody
);
2902 return gfc_finish_block (&body
);
2906 gfc_trans_vla_one_sizepos (tree
*tp
, stmtblock_t
*body
)
2908 tree t
= *tp
, var
, val
;
2910 if (t
== NULL
|| t
== error_mark_node
)
2912 if (TREE_CONSTANT (t
) || DECL_P (t
))
2915 if (TREE_CODE (t
) == SAVE_EXPR
)
2917 if (SAVE_EXPR_RESOLVED_P (t
))
2919 *tp
= TREE_OPERAND (t
, 0);
2922 val
= TREE_OPERAND (t
, 0);
2927 var
= gfc_create_var_np (TREE_TYPE (t
), NULL
);
2928 gfc_add_decl_to_function (var
);
2929 gfc_add_modify (body
, var
, val
);
2930 if (TREE_CODE (t
) == SAVE_EXPR
)
2931 TREE_OPERAND (t
, 0) = var
;
2936 gfc_trans_vla_type_sizes_1 (tree type
, stmtblock_t
*body
)
2940 if (type
== NULL
|| type
== error_mark_node
)
2943 type
= TYPE_MAIN_VARIANT (type
);
2945 if (TREE_CODE (type
) == INTEGER_TYPE
)
2947 gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type
), body
);
2948 gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type
), body
);
2950 for (t
= TYPE_NEXT_VARIANT (type
); t
; t
= TYPE_NEXT_VARIANT (t
))
2952 TYPE_MIN_VALUE (t
) = TYPE_MIN_VALUE (type
);
2953 TYPE_MAX_VALUE (t
) = TYPE_MAX_VALUE (type
);
2956 else if (TREE_CODE (type
) == ARRAY_TYPE
)
2958 gfc_trans_vla_type_sizes_1 (TREE_TYPE (type
), body
);
2959 gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type
), body
);
2960 gfc_trans_vla_one_sizepos (&TYPE_SIZE (type
), body
);
2961 gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type
), body
);
2963 for (t
= TYPE_NEXT_VARIANT (type
); t
; t
= TYPE_NEXT_VARIANT (t
))
2965 TYPE_SIZE (t
) = TYPE_SIZE (type
);
2966 TYPE_SIZE_UNIT (t
) = TYPE_SIZE_UNIT (type
);
2971 /* Make sure all type sizes and array domains are either constant,
2972 or variable or parameter decls. This is a simplified variant
2973 of gimplify_type_sizes, but we can't use it here, as none of the
2974 variables in the expressions have been gimplified yet.
2975 As type sizes and domains for various variable length arrays
2976 contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
2977 time, without this routine gimplify_type_sizes in the middle-end
2978 could result in the type sizes being gimplified earlier than where
2979 those variables are initialized. */
2982 gfc_trans_vla_type_sizes (gfc_symbol
*sym
, stmtblock_t
*body
)
2984 tree type
= TREE_TYPE (sym
->backend_decl
);
2986 if (TREE_CODE (type
) == FUNCTION_TYPE
2987 && (sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.entry
))
2989 if (! current_fake_result_decl
)
2992 type
= TREE_TYPE (TREE_VALUE (current_fake_result_decl
));
2995 while (POINTER_TYPE_P (type
))
2996 type
= TREE_TYPE (type
);
2998 if (GFC_DESCRIPTOR_TYPE_P (type
))
3000 tree etype
= GFC_TYPE_ARRAY_DATAPTR_TYPE (type
);
3002 while (POINTER_TYPE_P (etype
))
3003 etype
= TREE_TYPE (etype
);
3005 gfc_trans_vla_type_sizes_1 (etype
, body
);
3008 gfc_trans_vla_type_sizes_1 (type
, body
);
3012 /* Initialize a derived type by building an lvalue from the symbol
3013 and using trans_assignment to do the work. Set dealloc to false
3014 if no deallocation prior the assignment is needed. */
3016 gfc_init_default_dt (gfc_symbol
* sym
, tree body
, bool dealloc
)
3018 stmtblock_t fnblock
;
3023 gfc_init_block (&fnblock
);
3024 gcc_assert (!sym
->attr
.allocatable
);
3025 gfc_set_sym_referenced (sym
);
3026 e
= gfc_lval_expr_from_sym (sym
);
3027 tmp
= gfc_trans_assignment (e
, sym
->value
, false, dealloc
);
3028 if (sym
->attr
.dummy
&& (sym
->attr
.optional
3029 || sym
->ns
->proc_name
->attr
.entry_master
))
3031 present
= gfc_conv_expr_present (sym
);
3032 tmp
= build3 (COND_EXPR
, TREE_TYPE (tmp
), present
,
3033 tmp
, build_empty_stmt (input_location
));
3035 gfc_add_expr_to_block (&fnblock
, tmp
);
3038 gfc_add_expr_to_block (&fnblock
, body
);
3039 return gfc_finish_block (&fnblock
);
3043 /* Initialize INTENT(OUT) derived type dummies. As well as giving
3044 them their default initializer, if they do not have allocatable
3045 components, they have their allocatable components deallocated. */
3048 init_intent_out_dt (gfc_symbol
* proc_sym
, tree body
)
3050 stmtblock_t fnblock
;
3051 gfc_formal_arglist
*f
;
3055 gfc_init_block (&fnblock
);
3056 for (f
= proc_sym
->formal
; f
; f
= f
->next
)
3057 if (f
->sym
&& f
->sym
->attr
.intent
== INTENT_OUT
3058 && !f
->sym
->attr
.pointer
3059 && f
->sym
->ts
.type
== BT_DERIVED
)
3061 if (f
->sym
->ts
.u
.derived
->attr
.alloc_comp
&& !f
->sym
->value
)
3063 tmp
= gfc_deallocate_alloc_comp (f
->sym
->ts
.u
.derived
,
3064 f
->sym
->backend_decl
,
3065 f
->sym
->as
? f
->sym
->as
->rank
: 0);
3067 if (f
->sym
->attr
.optional
3068 || f
->sym
->ns
->proc_name
->attr
.entry_master
)
3070 present
= gfc_conv_expr_present (f
->sym
);
3071 tmp
= build3 (COND_EXPR
, TREE_TYPE (tmp
), present
,
3072 tmp
, build_empty_stmt (input_location
));
3075 gfc_add_expr_to_block (&fnblock
, tmp
);
3077 else if (f
->sym
->value
)
3078 body
= gfc_init_default_dt (f
->sym
, body
, true);
3081 gfc_add_expr_to_block (&fnblock
, body
);
3082 return gfc_finish_block (&fnblock
);
3086 /* Generate function entry and exit code, and add it to the function body.
3088 Allocation and initialization of array variables.
3089 Allocation of character string variables.
3090 Initialization and possibly repacking of dummy arrays.
3091 Initialization of ASSIGN statement auxiliary variable.
3092 Automatic deallocation. */
3095 gfc_trans_deferred_vars (gfc_symbol
* proc_sym
, tree fnbody
)
3099 gfc_formal_arglist
*f
;
3101 bool seen_trans_deferred_array
= false;
3103 /* Deal with implicit return variables. Explicit return variables will
3104 already have been added. */
3105 if (gfc_return_by_reference (proc_sym
) && proc_sym
->result
== proc_sym
)
3107 if (!current_fake_result_decl
)
3109 gfc_entry_list
*el
= NULL
;
3110 if (proc_sym
->attr
.entry_master
)
3112 for (el
= proc_sym
->ns
->entries
; el
; el
= el
->next
)
3113 if (el
->sym
!= el
->sym
->result
)
3116 /* TODO: move to the appropriate place in resolve.c. */
3117 if (warn_return_type
&& el
== NULL
)
3118 gfc_warning ("Return value of function '%s' at %L not set",
3119 proc_sym
->name
, &proc_sym
->declared_at
);
3121 else if (proc_sym
->as
)
3123 tree result
= TREE_VALUE (current_fake_result_decl
);
3124 fnbody
= gfc_trans_dummy_array_bias (proc_sym
, result
, fnbody
);
3126 /* An automatic character length, pointer array result. */
3127 if (proc_sym
->ts
.type
== BT_CHARACTER
3128 && TREE_CODE (proc_sym
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
3129 fnbody
= gfc_trans_dummy_character (proc_sym
, proc_sym
->ts
.u
.cl
,
3132 else if (proc_sym
->ts
.type
== BT_CHARACTER
)
3134 if (TREE_CODE (proc_sym
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
3135 fnbody
= gfc_trans_dummy_character (proc_sym
, proc_sym
->ts
.u
.cl
,
3139 gcc_assert (gfc_option
.flag_f2c
3140 && proc_sym
->ts
.type
== BT_COMPLEX
);
3143 /* Initialize the INTENT(OUT) derived type dummy arguments. This
3144 should be done here so that the offsets and lbounds of arrays
3146 fnbody
= init_intent_out_dt (proc_sym
, fnbody
);
3148 for (sym
= proc_sym
->tlink
; sym
!= proc_sym
; sym
= sym
->tlink
)
3150 bool sym_has_alloc_comp
= (sym
->ts
.type
== BT_DERIVED
)
3151 && sym
->ts
.u
.derived
->attr
.alloc_comp
;
3152 if (sym
->attr
.dimension
)
3154 switch (sym
->as
->type
)
3157 if (sym
->attr
.dummy
|| sym
->attr
.result
)
3159 gfc_trans_dummy_array_bias (sym
, sym
->backend_decl
, fnbody
);
3160 else if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3162 if (TREE_STATIC (sym
->backend_decl
))
3163 gfc_trans_static_array_pointer (sym
);
3166 seen_trans_deferred_array
= true;
3167 fnbody
= gfc_trans_deferred_array (sym
, fnbody
);
3172 if (sym_has_alloc_comp
)
3174 seen_trans_deferred_array
= true;
3175 fnbody
= gfc_trans_deferred_array (sym
, fnbody
);
3177 else if (sym
->ts
.type
== BT_DERIVED
3180 && sym
->attr
.save
== SAVE_NONE
)
3181 fnbody
= gfc_init_default_dt (sym
, fnbody
, false);
3183 gfc_get_backend_locus (&loc
);
3184 gfc_set_backend_locus (&sym
->declared_at
);
3185 fnbody
= gfc_trans_auto_array_allocation (sym
->backend_decl
,
3187 gfc_set_backend_locus (&loc
);
3191 case AS_ASSUMED_SIZE
:
3192 /* Must be a dummy parameter. */
3193 gcc_assert (sym
->attr
.dummy
|| sym
->as
->cp_was_assumed
);
3195 /* We should always pass assumed size arrays the g77 way. */
3196 if (sym
->attr
.dummy
)
3197 fnbody
= gfc_trans_g77_array (sym
, fnbody
);
3200 case AS_ASSUMED_SHAPE
:
3201 /* Must be a dummy parameter. */
3202 gcc_assert (sym
->attr
.dummy
);
3204 fnbody
= gfc_trans_dummy_array_bias (sym
, sym
->backend_decl
,
3209 seen_trans_deferred_array
= true;
3210 fnbody
= gfc_trans_deferred_array (sym
, fnbody
);
3216 if (sym_has_alloc_comp
&& !seen_trans_deferred_array
)
3217 fnbody
= gfc_trans_deferred_array (sym
, fnbody
);
3219 else if (sym_has_alloc_comp
)
3220 fnbody
= gfc_trans_deferred_array (sym
, fnbody
);
3221 else if (sym
->attr
.allocatable
3222 || (sym
->ts
.type
== BT_CLASS
3223 && sym
->ts
.u
.derived
->components
->attr
.allocatable
))
3225 if (!sym
->attr
.save
)
3227 /* Nullify and automatic deallocation of allocatable
3234 e
= gfc_lval_expr_from_sym (sym
);
3235 if (sym
->ts
.type
== BT_CLASS
)
3236 gfc_add_component_ref (e
, "$data");
3238 gfc_init_se (&se
, NULL
);
3239 se
.want_pointer
= 1;
3240 gfc_conv_expr (&se
, e
);
3243 /* Nullify when entering the scope. */
3244 gfc_start_block (&block
);
3245 gfc_add_modify (&block
, se
.expr
,
3246 fold_convert (TREE_TYPE (se
.expr
),
3247 null_pointer_node
));
3248 gfc_add_expr_to_block (&block
, fnbody
);
3250 /* Deallocate when leaving the scope. Nullifying is not
3252 tmp
= gfc_deallocate_with_status (se
.expr
, NULL_TREE
, true,
3254 gfc_add_expr_to_block (&block
, tmp
);
3255 fnbody
= gfc_finish_block (&block
);
3258 else if (sym
->ts
.type
== BT_CHARACTER
)
3260 gfc_get_backend_locus (&loc
);
3261 gfc_set_backend_locus (&sym
->declared_at
);
3262 if (sym
->attr
.dummy
|| sym
->attr
.result
)
3263 fnbody
= gfc_trans_dummy_character (sym
, sym
->ts
.u
.cl
, fnbody
);
3265 fnbody
= gfc_trans_auto_character_variable (sym
, fnbody
);
3266 gfc_set_backend_locus (&loc
);
3268 else if (sym
->attr
.assign
)
3270 gfc_get_backend_locus (&loc
);
3271 gfc_set_backend_locus (&sym
->declared_at
);
3272 fnbody
= gfc_trans_assign_aux_var (sym
, fnbody
);
3273 gfc_set_backend_locus (&loc
);
3275 else if (sym
->ts
.type
== BT_DERIVED
3278 && sym
->attr
.save
== SAVE_NONE
)
3279 fnbody
= gfc_init_default_dt (sym
, fnbody
, false);
3284 gfc_init_block (&body
);
3286 for (f
= proc_sym
->formal
; f
; f
= f
->next
)
3288 if (f
->sym
&& f
->sym
->tlink
== NULL
&& f
->sym
->ts
.type
== BT_CHARACTER
)
3290 gcc_assert (f
->sym
->ts
.u
.cl
->backend_decl
!= NULL
);
3291 if (TREE_CODE (f
->sym
->ts
.u
.cl
->backend_decl
) == PARM_DECL
)
3292 gfc_trans_vla_type_sizes (f
->sym
, &body
);
3296 if (gfc_return_by_reference (proc_sym
) && proc_sym
->ts
.type
== BT_CHARACTER
3297 && current_fake_result_decl
!= NULL
)
3299 gcc_assert (proc_sym
->ts
.u
.cl
->backend_decl
!= NULL
);
3300 if (TREE_CODE (proc_sym
->ts
.u
.cl
->backend_decl
) == PARM_DECL
)
3301 gfc_trans_vla_type_sizes (proc_sym
, &body
);
3304 gfc_add_expr_to_block (&body
, fnbody
);
3305 return gfc_finish_block (&body
);
3308 static GTY ((param_is (struct module_htab_entry
))) htab_t module_htab
;
3310 /* Hash and equality functions for module_htab. */
3313 module_htab_do_hash (const void *x
)
3315 return htab_hash_string (((const struct module_htab_entry
*)x
)->name
);
3319 module_htab_eq (const void *x1
, const void *x2
)
3321 return strcmp ((((const struct module_htab_entry
*)x1
)->name
),
3322 (const char *)x2
) == 0;
3325 /* Hash and equality functions for module_htab's decls. */
3328 module_htab_decls_hash (const void *x
)
3330 const_tree t
= (const_tree
) x
;
3331 const_tree n
= DECL_NAME (t
);
3333 n
= TYPE_NAME (TREE_TYPE (t
));
3334 return htab_hash_string (IDENTIFIER_POINTER (n
));
3338 module_htab_decls_eq (const void *x1
, const void *x2
)
3340 const_tree t1
= (const_tree
) x1
;
3341 const_tree n1
= DECL_NAME (t1
);
3342 if (n1
== NULL_TREE
)
3343 n1
= TYPE_NAME (TREE_TYPE (t1
));
3344 return strcmp (IDENTIFIER_POINTER (n1
), (const char *) x2
) == 0;
3347 struct module_htab_entry
*
3348 gfc_find_module (const char *name
)
3353 module_htab
= htab_create_ggc (10, module_htab_do_hash
,
3354 module_htab_eq
, NULL
);
3356 slot
= htab_find_slot_with_hash (module_htab
, name
,
3357 htab_hash_string (name
), INSERT
);
3360 struct module_htab_entry
*entry
= GGC_CNEW (struct module_htab_entry
);
3362 entry
->name
= gfc_get_string (name
);
3363 entry
->decls
= htab_create_ggc (10, module_htab_decls_hash
,
3364 module_htab_decls_eq
, NULL
);
3365 *slot
= (void *) entry
;
3367 return (struct module_htab_entry
*) *slot
;
3371 gfc_module_add_decl (struct module_htab_entry
*entry
, tree decl
)
3376 if (DECL_NAME (decl
))
3377 name
= IDENTIFIER_POINTER (DECL_NAME (decl
));
3380 gcc_assert (TREE_CODE (decl
) == TYPE_DECL
);
3381 name
= IDENTIFIER_POINTER (TYPE_NAME (TREE_TYPE (decl
)));
3383 slot
= htab_find_slot_with_hash (entry
->decls
, name
,
3384 htab_hash_string (name
), INSERT
);
3386 *slot
= (void *) decl
;
3389 static struct module_htab_entry
*cur_module
;
3391 /* Output an initialized decl for a module variable. */
3394 gfc_create_module_variable (gfc_symbol
* sym
)
3398 /* Module functions with alternate entries are dealt with later and
3399 would get caught by the next condition. */
3400 if (sym
->attr
.entry
)
3403 /* Make sure we convert the types of the derived types from iso_c_binding
3405 if (sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.is_iso_c
3406 && sym
->ts
.type
== BT_DERIVED
)
3407 sym
->backend_decl
= gfc_typenode_for_spec (&(sym
->ts
));
3409 if (sym
->attr
.flavor
== FL_DERIVED
3410 && sym
->backend_decl
3411 && TREE_CODE (sym
->backend_decl
) == RECORD_TYPE
)
3413 decl
= sym
->backend_decl
;
3414 gcc_assert (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
);
3416 /* -fwhole-file mixes up the contexts so these asserts are unnecessary. */
3417 if (!(gfc_option
.flag_whole_file
&& sym
->attr
.use_assoc
))
3419 gcc_assert (TYPE_CONTEXT (decl
) == NULL_TREE
3420 || TYPE_CONTEXT (decl
) == sym
->ns
->proc_name
->backend_decl
);
3421 gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl
)) == NULL_TREE
3422 || DECL_CONTEXT (TYPE_STUB_DECL (decl
))
3423 == sym
->ns
->proc_name
->backend_decl
);
3425 TYPE_CONTEXT (decl
) = sym
->ns
->proc_name
->backend_decl
;
3426 DECL_CONTEXT (TYPE_STUB_DECL (decl
)) = sym
->ns
->proc_name
->backend_decl
;
3427 gfc_module_add_decl (cur_module
, TYPE_STUB_DECL (decl
));
3430 /* Only output variables, procedure pointers and array valued,
3431 or derived type, parameters. */
3432 if (sym
->attr
.flavor
!= FL_VARIABLE
3433 && !(sym
->attr
.flavor
== FL_PARAMETER
3434 && (sym
->attr
.dimension
|| sym
->ts
.type
== BT_DERIVED
))
3435 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc_pointer
))
3438 if ((sym
->attr
.in_common
|| sym
->attr
.in_equivalence
) && sym
->backend_decl
)
3440 decl
= sym
->backend_decl
;
3441 gcc_assert (DECL_CONTEXT (decl
) == NULL_TREE
);
3442 gcc_assert (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
);
3443 DECL_CONTEXT (decl
) = sym
->ns
->proc_name
->backend_decl
;
3444 gfc_module_add_decl (cur_module
, decl
);
3447 /* Don't generate variables from other modules. Variables from
3448 COMMONs will already have been generated. */
3449 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
3452 /* Equivalenced variables arrive here after creation. */
3453 if (sym
->backend_decl
3454 && (sym
->equiv_built
|| sym
->attr
.in_equivalence
))
3457 if (sym
->backend_decl
&& !sym
->attr
.vtab
)
3458 internal_error ("backend decl for module variable %s already exists",
3461 /* We always want module variables to be created. */
3462 sym
->attr
.referenced
= 1;
3463 /* Create the decl. */
3464 decl
= gfc_get_symbol_decl (sym
);
3466 /* Create the variable. */
3468 gcc_assert (DECL_CONTEXT (decl
) == NULL_TREE
);
3469 gcc_assert (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
);
3470 DECL_CONTEXT (decl
) = sym
->ns
->proc_name
->backend_decl
;
3471 rest_of_decl_compilation (decl
, 1, 0);
3472 gfc_module_add_decl (cur_module
, decl
);
3474 /* Also add length of strings. */
3475 if (sym
->ts
.type
== BT_CHARACTER
)
3479 length
= sym
->ts
.u
.cl
->backend_decl
;
3480 if (!INTEGER_CST_P (length
))
3483 rest_of_decl_compilation (length
, 1, 0);
3488 /* Emit debug information for USE statements. */
3491 gfc_trans_use_stmts (gfc_namespace
* ns
)
3493 gfc_use_list
*use_stmt
;
3494 for (use_stmt
= ns
->use_stmts
; use_stmt
; use_stmt
= use_stmt
->next
)
3496 struct module_htab_entry
*entry
3497 = gfc_find_module (use_stmt
->module_name
);
3498 gfc_use_rename
*rent
;
3500 if (entry
->namespace_decl
== NULL
)
3502 entry
->namespace_decl
3503 = build_decl (input_location
,
3505 get_identifier (use_stmt
->module_name
),
3507 DECL_EXTERNAL (entry
->namespace_decl
) = 1;
3509 gfc_set_backend_locus (&use_stmt
->where
);
3510 if (!use_stmt
->only_flag
)
3511 (*debug_hooks
->imported_module_or_decl
) (entry
->namespace_decl
,
3513 ns
->proc_name
->backend_decl
,
3515 for (rent
= use_stmt
->rename
; rent
; rent
= rent
->next
)
3517 tree decl
, local_name
;
3520 if (rent
->op
!= INTRINSIC_NONE
)
3523 slot
= htab_find_slot_with_hash (entry
->decls
, rent
->use_name
,
3524 htab_hash_string (rent
->use_name
),
3530 st
= gfc_find_symtree (ns
->sym_root
,
3532 ? rent
->local_name
: rent
->use_name
);
3535 /* Sometimes, generic interfaces wind up being over-ruled by a
3536 local symbol (see PR41062). */
3537 if (!st
->n
.sym
->attr
.use_assoc
)
3540 if (st
->n
.sym
->backend_decl
3541 && DECL_P (st
->n
.sym
->backend_decl
)
3542 && st
->n
.sym
->module
3543 && strcmp (st
->n
.sym
->module
, use_stmt
->module_name
) == 0)
3545 gcc_assert (DECL_EXTERNAL (entry
->namespace_decl
)
3546 || (TREE_CODE (st
->n
.sym
->backend_decl
)
3548 decl
= copy_node (st
->n
.sym
->backend_decl
);
3549 DECL_CONTEXT (decl
) = entry
->namespace_decl
;
3550 DECL_EXTERNAL (decl
) = 1;
3551 DECL_IGNORED_P (decl
) = 0;
3552 DECL_INITIAL (decl
) = NULL_TREE
;
3556 *slot
= error_mark_node
;
3557 htab_clear_slot (entry
->decls
, slot
);
3562 decl
= (tree
) *slot
;
3563 if (rent
->local_name
[0])
3564 local_name
= get_identifier (rent
->local_name
);
3566 local_name
= NULL_TREE
;
3567 gfc_set_backend_locus (&rent
->where
);
3568 (*debug_hooks
->imported_module_or_decl
) (decl
, local_name
,
3569 ns
->proc_name
->backend_decl
,
3570 !use_stmt
->only_flag
);
3576 /* Return true if expr is a constant initializer that gfc_conv_initializer
3580 check_constant_initializer (gfc_expr
*expr
, gfc_typespec
*ts
, bool array
,
3590 if (expr
->expr_type
== EXPR_CONSTANT
|| expr
->expr_type
== EXPR_NULL
)
3592 else if (expr
->expr_type
== EXPR_STRUCTURE
)
3593 return check_constant_initializer (expr
, ts
, false, false);
3594 else if (expr
->expr_type
!= EXPR_ARRAY
)
3596 for (c
= gfc_constructor_first (expr
->value
.constructor
);
3597 c
; c
= gfc_constructor_next (c
))
3601 if (c
->expr
->expr_type
== EXPR_STRUCTURE
)
3603 if (!check_constant_initializer (c
->expr
, ts
, false, false))
3606 else if (c
->expr
->expr_type
!= EXPR_CONSTANT
)
3611 else switch (ts
->type
)
3614 if (expr
->expr_type
!= EXPR_STRUCTURE
)
3616 cm
= expr
->ts
.u
.derived
->components
;
3617 for (c
= gfc_constructor_first (expr
->value
.constructor
);
3618 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
3620 if (!c
->expr
|| cm
->attr
.allocatable
)
3622 if (!check_constant_initializer (c
->expr
, &cm
->ts
,
3629 return expr
->expr_type
== EXPR_CONSTANT
;
3633 /* Emit debug info for parameters and unreferenced variables with
3637 gfc_emit_parameter_debug_info (gfc_symbol
*sym
)
3641 if (sym
->attr
.flavor
!= FL_PARAMETER
3642 && (sym
->attr
.flavor
!= FL_VARIABLE
|| sym
->attr
.referenced
))
3645 if (sym
->backend_decl
!= NULL
3646 || sym
->value
== NULL
3647 || sym
->attr
.use_assoc
3650 || sym
->attr
.function
3651 || sym
->attr
.intrinsic
3652 || sym
->attr
.pointer
3653 || sym
->attr
.allocatable
3654 || sym
->attr
.cray_pointee
3655 || sym
->attr
.threadprivate
3656 || sym
->attr
.is_bind_c
3657 || sym
->attr
.subref_array_pointer
3658 || sym
->attr
.assign
)
3661 if (sym
->ts
.type
== BT_CHARACTER
)
3663 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
3664 if (sym
->ts
.u
.cl
->backend_decl
== NULL
3665 || TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) != INTEGER_CST
)
3668 else if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.alloc_comp
)
3675 if (sym
->as
->type
!= AS_EXPLICIT
)
3677 for (n
= 0; n
< sym
->as
->rank
; n
++)
3678 if (sym
->as
->lower
[n
]->expr_type
!= EXPR_CONSTANT
3679 || sym
->as
->upper
[n
] == NULL
3680 || sym
->as
->upper
[n
]->expr_type
!= EXPR_CONSTANT
)
3684 if (!check_constant_initializer (sym
->value
, &sym
->ts
,
3685 sym
->attr
.dimension
, false))
3688 /* Create the decl for the variable or constant. */
3689 decl
= build_decl (input_location
,
3690 sym
->attr
.flavor
== FL_PARAMETER
? CONST_DECL
: VAR_DECL
,
3691 gfc_sym_identifier (sym
), gfc_sym_type (sym
));
3692 if (sym
->attr
.flavor
== FL_PARAMETER
)
3693 TREE_READONLY (decl
) = 1;
3694 gfc_set_decl_location (decl
, &sym
->declared_at
);
3695 if (sym
->attr
.dimension
)
3696 GFC_DECL_PACKED_ARRAY (decl
) = 1;
3697 DECL_CONTEXT (decl
) = sym
->ns
->proc_name
->backend_decl
;
3698 TREE_STATIC (decl
) = 1;
3699 TREE_USED (decl
) = 1;
3700 if (DECL_CONTEXT (decl
) && TREE_CODE (DECL_CONTEXT (decl
)) == NAMESPACE_DECL
)
3701 TREE_PUBLIC (decl
) = 1;
3703 = gfc_conv_initializer (sym
->value
, &sym
->ts
, TREE_TYPE (decl
),
3704 sym
->attr
.dimension
, 0);
3705 debug_hooks
->global_decl (decl
);
3708 /* Generate all the required code for module variables. */
3711 gfc_generate_module_vars (gfc_namespace
* ns
)
3713 module_namespace
= ns
;
3714 cur_module
= gfc_find_module (ns
->proc_name
->name
);
3716 /* Check if the frontend left the namespace in a reasonable state. */
3717 gcc_assert (ns
->proc_name
&& !ns
->proc_name
->tlink
);
3719 /* Generate COMMON blocks. */
3720 gfc_trans_common (ns
);
3722 /* Create decls for all the module variables. */
3723 gfc_traverse_ns (ns
, gfc_create_module_variable
);
3727 gfc_trans_use_stmts (ns
);
3728 gfc_traverse_ns (ns
, gfc_emit_parameter_debug_info
);
3733 gfc_generate_contained_functions (gfc_namespace
* parent
)
3737 /* We create all the prototypes before generating any code. */
3738 for (ns
= parent
->contained
; ns
; ns
= ns
->sibling
)
3740 /* Skip namespaces from used modules. */
3741 if (ns
->parent
!= parent
)
3744 gfc_create_function_decl (ns
);
3747 for (ns
= parent
->contained
; ns
; ns
= ns
->sibling
)
3749 /* Skip namespaces from used modules. */
3750 if (ns
->parent
!= parent
)
3753 gfc_generate_function_code (ns
);
3758 /* Drill down through expressions for the array specification bounds and
3759 character length calling generate_local_decl for all those variables
3760 that have not already been declared. */
3763 generate_local_decl (gfc_symbol
*);
3765 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
3768 expr_decls (gfc_expr
*e
, gfc_symbol
*sym
,
3769 int *f ATTRIBUTE_UNUSED
)
3771 if (e
->expr_type
!= EXPR_VARIABLE
3772 || sym
== e
->symtree
->n
.sym
3773 || e
->symtree
->n
.sym
->mark
3774 || e
->symtree
->n
.sym
->ns
!= sym
->ns
)
3777 generate_local_decl (e
->symtree
->n
.sym
);
3782 generate_expr_decls (gfc_symbol
*sym
, gfc_expr
*e
)
3784 gfc_traverse_expr (e
, sym
, expr_decls
, 0);
3788 /* Check for dependencies in the character length and array spec. */
3791 generate_dependency_declarations (gfc_symbol
*sym
)
3795 if (sym
->ts
.type
== BT_CHARACTER
3797 && sym
->ts
.u
.cl
->length
3798 && sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
3799 generate_expr_decls (sym
, sym
->ts
.u
.cl
->length
);
3801 if (sym
->as
&& sym
->as
->rank
)
3803 for (i
= 0; i
< sym
->as
->rank
; i
++)
3805 generate_expr_decls (sym
, sym
->as
->lower
[i
]);
3806 generate_expr_decls (sym
, sym
->as
->upper
[i
]);
3812 /* Generate decls for all local variables. We do this to ensure correct
3813 handling of expressions which only appear in the specification of
3817 generate_local_decl (gfc_symbol
* sym
)
3819 if (sym
->attr
.flavor
== FL_VARIABLE
)
3821 if (!sym
->attr
.dummy
&& !sym
->ns
->proc_name
->attr
.entry_master
)
3822 generate_dependency_declarations (sym
);
3824 if (sym
->attr
.referenced
)
3825 gfc_get_symbol_decl (sym
);
3826 /* INTENT(out) dummy arguments are likely meant to be set. */
3827 else if (warn_unused_variable
3829 && sym
->attr
.intent
== INTENT_OUT
)
3831 if (!(sym
->ts
.type
== BT_DERIVED
3832 && sym
->ts
.u
.derived
->components
->initializer
))
3833 gfc_warning ("Dummy argument '%s' at %L was declared INTENT(OUT) "
3834 "but was not set", sym
->name
, &sym
->declared_at
);
3836 /* Specific warning for unused dummy arguments. */
3837 else if (warn_unused_variable
&& sym
->attr
.dummy
)
3838 gfc_warning ("Unused dummy argument '%s' at %L", sym
->name
,
3840 /* Warn for unused variables, but not if they're inside a common
3841 block or are use-associated. */
3842 else if (warn_unused_variable
3843 && !(sym
->attr
.in_common
|| sym
->attr
.use_assoc
|| sym
->mark
))
3844 gfc_warning ("Unused variable '%s' declared at %L", sym
->name
,
3847 /* For variable length CHARACTER parameters, the PARM_DECL already
3848 references the length variable, so force gfc_get_symbol_decl
3849 even when not referenced. If optimize > 0, it will be optimized
3850 away anyway. But do this only after emitting -Wunused-parameter
3851 warning if requested. */
3852 if (sym
->attr
.dummy
&& !sym
->attr
.referenced
3853 && sym
->ts
.type
== BT_CHARACTER
3854 && sym
->ts
.u
.cl
->backend_decl
!= NULL
3855 && TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
3857 sym
->attr
.referenced
= 1;
3858 gfc_get_symbol_decl (sym
);
3861 /* INTENT(out) dummy arguments and result variables with allocatable
3862 components are reset by default and need to be set referenced to
3863 generate the code for nullification and automatic lengths. */
3864 if (!sym
->attr
.referenced
3865 && sym
->ts
.type
== BT_DERIVED
3866 && sym
->ts
.u
.derived
->attr
.alloc_comp
3867 && !sym
->attr
.pointer
3868 && ((sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
)
3870 (sym
->attr
.result
&& sym
!= sym
->result
)))
3872 sym
->attr
.referenced
= 1;
3873 gfc_get_symbol_decl (sym
);
3876 /* Check for dependencies in the array specification and string
3877 length, adding the necessary declarations to the function. We
3878 mark the symbol now, as well as in traverse_ns, to prevent
3879 getting stuck in a circular dependency. */
3882 /* We do not want the middle-end to warn about unused parameters
3883 as this was already done above. */
3884 if (sym
->attr
.dummy
&& sym
->backend_decl
!= NULL_TREE
)
3885 TREE_NO_WARNING(sym
->backend_decl
) = 1;
3887 else if (sym
->attr
.flavor
== FL_PARAMETER
)
3889 if (warn_unused_parameter
3890 && !sym
->attr
.referenced
3891 && !sym
->attr
.use_assoc
)
3892 gfc_warning ("Unused parameter '%s' declared at %L", sym
->name
,
3895 else if (sym
->attr
.flavor
== FL_PROCEDURE
)
3897 /* TODO: move to the appropriate place in resolve.c. */
3898 if (warn_return_type
3899 && sym
->attr
.function
3901 && sym
!= sym
->result
3902 && !sym
->result
->attr
.referenced
3903 && !sym
->attr
.use_assoc
3904 && sym
->attr
.if_source
!= IFSRC_IFBODY
)
3906 gfc_warning ("Return value '%s' of function '%s' declared at "
3907 "%L not set", sym
->result
->name
, sym
->name
,
3908 &sym
->result
->declared_at
);
3910 /* Prevents "Unused variable" warning for RESULT variables. */
3911 sym
->result
->mark
= 1;
3915 if (sym
->attr
.dummy
== 1)
3917 /* Modify the tree type for scalar character dummy arguments of bind(c)
3918 procedures if they are passed by value. The tree type for them will
3919 be promoted to INTEGER_TYPE for the middle end, which appears to be
3920 what C would do with characters passed by-value. The value attribute
3921 implies the dummy is a scalar. */
3922 if (sym
->attr
.value
== 1 && sym
->backend_decl
!= NULL
3923 && sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.is_c_interop
3924 && sym
->ns
->proc_name
!= NULL
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
3925 gfc_conv_scalar_char_value (sym
, NULL
, NULL
);
3928 /* Make sure we convert the types of the derived types from iso_c_binding
3930 if (sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.is_iso_c
3931 && sym
->ts
.type
== BT_DERIVED
)
3932 sym
->backend_decl
= gfc_typenode_for_spec (&(sym
->ts
));
3936 generate_local_vars (gfc_namespace
* ns
)
3938 gfc_traverse_ns (ns
, generate_local_decl
);
3942 /* Generate a switch statement to jump to the correct entry point. Also
3943 creates the label decls for the entry points. */
3946 gfc_trans_entry_master_switch (gfc_entry_list
* el
)
3953 gfc_init_block (&block
);
3954 for (; el
; el
= el
->next
)
3956 /* Add the case label. */
3957 label
= gfc_build_label_decl (NULL_TREE
);
3958 val
= build_int_cst (gfc_array_index_type
, el
->id
);
3959 tmp
= build3_v (CASE_LABEL_EXPR
, val
, NULL_TREE
, label
);
3960 gfc_add_expr_to_block (&block
, tmp
);
3962 /* And jump to the actual entry point. */
3963 label
= gfc_build_label_decl (NULL_TREE
);
3964 tmp
= build1_v (GOTO_EXPR
, label
);
3965 gfc_add_expr_to_block (&block
, tmp
);
3967 /* Save the label decl. */
3970 tmp
= gfc_finish_block (&block
);
3971 /* The first argument selects the entry point. */
3972 val
= DECL_ARGUMENTS (current_function_decl
);
3973 tmp
= build3_v (SWITCH_EXPR
, val
, tmp
, NULL_TREE
);
3978 /* Add code to string lengths of actual arguments passed to a function against
3979 the expected lengths of the dummy arguments. */
3982 add_argument_checking (stmtblock_t
*block
, gfc_symbol
*sym
)
3984 gfc_formal_arglist
*formal
;
3986 for (formal
= sym
->formal
; formal
; formal
= formal
->next
)
3987 if (formal
->sym
&& formal
->sym
->ts
.type
== BT_CHARACTER
)
3989 enum tree_code comparison
;
3994 const char *message
;
4000 gcc_assert (cl
->passed_length
!= NULL_TREE
);
4001 gcc_assert (cl
->backend_decl
!= NULL_TREE
);
4003 /* For POINTER, ALLOCATABLE and assumed-shape dummy arguments, the
4004 string lengths must match exactly. Otherwise, it is only required
4005 that the actual string length is *at least* the expected one.
4006 Sequence association allows for a mismatch of the string length
4007 if the actual argument is (part of) an array, but only if the
4008 dummy argument is an array. (See "Sequence association" in
4009 Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.) */
4010 if (fsym
->attr
.pointer
|| fsym
->attr
.allocatable
4011 || (fsym
->as
&& fsym
->as
->type
== AS_ASSUMED_SHAPE
))
4013 comparison
= NE_EXPR
;
4014 message
= _("Actual string length does not match the declared one"
4015 " for dummy argument '%s' (%ld/%ld)");
4017 else if (fsym
->as
&& fsym
->as
->rank
!= 0)
4021 comparison
= LT_EXPR
;
4022 message
= _("Actual string length is shorter than the declared one"
4023 " for dummy argument '%s' (%ld/%ld)");
4026 /* Build the condition. For optional arguments, an actual length
4027 of 0 is also acceptable if the associated string is NULL, which
4028 means the argument was not passed. */
4029 cond
= fold_build2 (comparison
, boolean_type_node
,
4030 cl
->passed_length
, cl
->backend_decl
);
4031 if (fsym
->attr
.optional
)
4037 not_0length
= fold_build2 (NE_EXPR
, boolean_type_node
,
4039 fold_convert (gfc_charlen_type_node
,
4040 integer_zero_node
));
4041 /* The symbol needs to be referenced for gfc_get_symbol_decl. */
4042 fsym
->attr
.referenced
= 1;
4043 not_absent
= gfc_conv_expr_present (fsym
);
4045 absent_failed
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
,
4046 not_0length
, not_absent
);
4048 cond
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
4049 cond
, absent_failed
);
4052 /* Build the runtime check. */
4053 argname
= gfc_build_cstring_const (fsym
->name
);
4054 argname
= gfc_build_addr_expr (pchar_type_node
, argname
);
4055 gfc_trans_runtime_check (true, false, cond
, block
, &fsym
->declared_at
,
4057 fold_convert (long_integer_type_node
,
4059 fold_convert (long_integer_type_node
,
4066 create_main_function (tree fndecl
)
4070 tree tmp
, decl
, result_decl
, argc
, argv
, typelist
, arglist
;
4073 old_context
= current_function_decl
;
4077 push_function_context ();
4078 saved_parent_function_decls
= saved_function_decls
;
4079 saved_function_decls
= NULL_TREE
;
4082 /* main() function must be declared with global scope. */
4083 gcc_assert (current_function_decl
== NULL_TREE
);
4085 /* Declare the function. */
4086 tmp
= build_function_type_list (integer_type_node
, integer_type_node
,
4087 build_pointer_type (pchar_type_node
),
4089 main_identifier_node
= get_identifier ("main");
4090 ftn_main
= build_decl (input_location
, FUNCTION_DECL
,
4091 main_identifier_node
, tmp
);
4092 DECL_EXTERNAL (ftn_main
) = 0;
4093 TREE_PUBLIC (ftn_main
) = 1;
4094 TREE_STATIC (ftn_main
) = 1;
4095 DECL_ATTRIBUTES (ftn_main
)
4096 = tree_cons (get_identifier("externally_visible"), NULL_TREE
, NULL_TREE
);
4098 /* Setup the result declaration (for "return 0"). */
4099 result_decl
= build_decl (input_location
,
4100 RESULT_DECL
, NULL_TREE
, integer_type_node
);
4101 DECL_ARTIFICIAL (result_decl
) = 1;
4102 DECL_IGNORED_P (result_decl
) = 1;
4103 DECL_CONTEXT (result_decl
) = ftn_main
;
4104 DECL_RESULT (ftn_main
) = result_decl
;
4106 pushdecl (ftn_main
);
4108 /* Get the arguments. */
4110 arglist
= NULL_TREE
;
4111 typelist
= TYPE_ARG_TYPES (TREE_TYPE (ftn_main
));
4113 tmp
= TREE_VALUE (typelist
);
4114 argc
= build_decl (input_location
, PARM_DECL
, get_identifier ("argc"), tmp
);
4115 DECL_CONTEXT (argc
) = ftn_main
;
4116 DECL_ARG_TYPE (argc
) = TREE_VALUE (typelist
);
4117 TREE_READONLY (argc
) = 1;
4118 gfc_finish_decl (argc
);
4119 arglist
= chainon (arglist
, argc
);
4121 typelist
= TREE_CHAIN (typelist
);
4122 tmp
= TREE_VALUE (typelist
);
4123 argv
= build_decl (input_location
, PARM_DECL
, get_identifier ("argv"), tmp
);
4124 DECL_CONTEXT (argv
) = ftn_main
;
4125 DECL_ARG_TYPE (argv
) = TREE_VALUE (typelist
);
4126 TREE_READONLY (argv
) = 1;
4127 DECL_BY_REFERENCE (argv
) = 1;
4128 gfc_finish_decl (argv
);
4129 arglist
= chainon (arglist
, argv
);
4131 DECL_ARGUMENTS (ftn_main
) = arglist
;
4132 current_function_decl
= ftn_main
;
4133 announce_function (ftn_main
);
4135 rest_of_decl_compilation (ftn_main
, 1, 0);
4136 make_decl_rtl (ftn_main
);
4137 init_function_start (ftn_main
);
4140 gfc_init_block (&body
);
4142 /* Call some libgfortran initialization routines, call then MAIN__(). */
4144 /* Call _gfortran_set_args (argc, argv). */
4145 TREE_USED (argc
) = 1;
4146 TREE_USED (argv
) = 1;
4147 tmp
= build_call_expr_loc (input_location
,
4148 gfor_fndecl_set_args
, 2, argc
, argv
);
4149 gfc_add_expr_to_block (&body
, tmp
);
4151 /* Add a call to set_options to set up the runtime library Fortran
4152 language standard parameters. */
4154 tree array_type
, array
, var
;
4156 /* Passing a new option to the library requires four modifications:
4157 + add it to the tree_cons list below
4158 + change the array size in the call to build_array_type
4159 + change the first argument to the library call
4160 gfor_fndecl_set_options
4161 + modify the library (runtime/compile_options.c)! */
4163 array
= tree_cons (NULL_TREE
, build_int_cst (integer_type_node
,
4164 gfc_option
.warn_std
), NULL_TREE
);
4165 array
= tree_cons (NULL_TREE
, build_int_cst (integer_type_node
,
4166 gfc_option
.allow_std
), array
);
4167 array
= tree_cons (NULL_TREE
, build_int_cst (integer_type_node
, pedantic
),
4169 array
= tree_cons (NULL_TREE
, build_int_cst (integer_type_node
,
4170 gfc_option
.flag_dump_core
), array
);
4171 array
= tree_cons (NULL_TREE
, build_int_cst (integer_type_node
,
4172 gfc_option
.flag_backtrace
), array
);
4173 array
= tree_cons (NULL_TREE
, build_int_cst (integer_type_node
,
4174 gfc_option
.flag_sign_zero
), array
);
4176 array
= tree_cons (NULL_TREE
, build_int_cst (integer_type_node
,
4177 (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)), array
);
4179 array
= tree_cons (NULL_TREE
, build_int_cst (integer_type_node
,
4180 gfc_option
.flag_range_check
), array
);
4182 array_type
= build_array_type (integer_type_node
,
4183 build_index_type (build_int_cst (NULL_TREE
, 7)));
4184 array
= build_constructor_from_list (array_type
, nreverse (array
));
4185 TREE_CONSTANT (array
) = 1;
4186 TREE_STATIC (array
) = 1;
4188 /* Create a static variable to hold the jump table. */
4189 var
= gfc_create_var (array_type
, "options");
4190 TREE_CONSTANT (var
) = 1;
4191 TREE_STATIC (var
) = 1;
4192 TREE_READONLY (var
) = 1;
4193 DECL_INITIAL (var
) = array
;
4194 var
= gfc_build_addr_expr (build_pointer_type (integer_type_node
), var
);
4196 tmp
= build_call_expr_loc (input_location
,
4197 gfor_fndecl_set_options
, 2,
4198 build_int_cst (integer_type_node
, 8), var
);
4199 gfc_add_expr_to_block (&body
, tmp
);
4202 /* If -ffpe-trap option was provided, add a call to set_fpe so that
4203 the library will raise a FPE when needed. */
4204 if (gfc_option
.fpe
!= 0)
4206 tmp
= build_call_expr_loc (input_location
,
4207 gfor_fndecl_set_fpe
, 1,
4208 build_int_cst (integer_type_node
,
4210 gfc_add_expr_to_block (&body
, tmp
);
4213 /* If this is the main program and an -fconvert option was provided,
4214 add a call to set_convert. */
4216 if (gfc_option
.convert
!= GFC_CONVERT_NATIVE
)
4218 tmp
= build_call_expr_loc (input_location
,
4219 gfor_fndecl_set_convert
, 1,
4220 build_int_cst (integer_type_node
,
4221 gfc_option
.convert
));
4222 gfc_add_expr_to_block (&body
, tmp
);
4225 /* If this is the main program and an -frecord-marker option was provided,
4226 add a call to set_record_marker. */
4228 if (gfc_option
.record_marker
!= 0)
4230 tmp
= build_call_expr_loc (input_location
,
4231 gfor_fndecl_set_record_marker
, 1,
4232 build_int_cst (integer_type_node
,
4233 gfc_option
.record_marker
));
4234 gfc_add_expr_to_block (&body
, tmp
);
4237 if (gfc_option
.max_subrecord_length
!= 0)
4239 tmp
= build_call_expr_loc (input_location
,
4240 gfor_fndecl_set_max_subrecord_length
, 1,
4241 build_int_cst (integer_type_node
,
4242 gfc_option
.max_subrecord_length
));
4243 gfc_add_expr_to_block (&body
, tmp
);
4246 /* Call MAIN__(). */
4247 tmp
= build_call_expr_loc (input_location
,
4249 gfc_add_expr_to_block (&body
, tmp
);
4251 /* Mark MAIN__ as used. */
4252 TREE_USED (fndecl
) = 1;
4255 tmp
= fold_build2 (MODIFY_EXPR
, integer_type_node
, DECL_RESULT (ftn_main
),
4256 build_int_cst (integer_type_node
, 0));
4257 tmp
= build1_v (RETURN_EXPR
, tmp
);
4258 gfc_add_expr_to_block (&body
, tmp
);
4261 DECL_SAVED_TREE (ftn_main
) = gfc_finish_block (&body
);
4264 /* Finish off this function and send it for code generation. */
4266 BLOCK_SUPERCONTEXT (DECL_INITIAL (ftn_main
)) = ftn_main
;
4268 DECL_SAVED_TREE (ftn_main
)
4269 = build3_v (BIND_EXPR
, decl
, DECL_SAVED_TREE (ftn_main
),
4270 DECL_INITIAL (ftn_main
));
4272 /* Output the GENERIC tree. */
4273 dump_function (TDI_original
, ftn_main
);
4275 cgraph_finalize_function (ftn_main
, true);
4279 pop_function_context ();
4280 saved_function_decls
= saved_parent_function_decls
;
4282 current_function_decl
= old_context
;
4286 /* Generate code for a function. */
4289 gfc_generate_function_code (gfc_namespace
* ns
)
4299 tree recurcheckvar
= NULL_TREE
;
4304 sym
= ns
->proc_name
;
4306 /* Check that the frontend isn't still using this. */
4307 gcc_assert (sym
->tlink
== NULL
);
4310 /* Create the declaration for functions with global scope. */
4311 if (!sym
->backend_decl
)
4312 gfc_create_function_decl (ns
);
4314 fndecl
= sym
->backend_decl
;
4315 old_context
= current_function_decl
;
4319 push_function_context ();
4320 saved_parent_function_decls
= saved_function_decls
;
4321 saved_function_decls
= NULL_TREE
;
4324 trans_function_start (sym
);
4326 gfc_init_block (&block
);
4328 if (ns
->entries
&& ns
->proc_name
->ts
.type
== BT_CHARACTER
)
4330 /* Copy length backend_decls to all entry point result
4335 gfc_conv_const_charlen (ns
->proc_name
->ts
.u
.cl
);
4336 backend_decl
= ns
->proc_name
->result
->ts
.u
.cl
->backend_decl
;
4337 for (el
= ns
->entries
; el
; el
= el
->next
)
4338 el
->sym
->result
->ts
.u
.cl
->backend_decl
= backend_decl
;
4341 /* Translate COMMON blocks. */
4342 gfc_trans_common (ns
);
4344 /* Null the parent fake result declaration if this namespace is
4345 a module function or an external procedures. */
4346 if ((ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
4347 || ns
->parent
== NULL
)
4348 parent_fake_result_decl
= NULL_TREE
;
4350 gfc_generate_contained_functions (ns
);
4352 nonlocal_dummy_decls
= NULL
;
4353 nonlocal_dummy_decl_pset
= NULL
;
4355 generate_local_vars (ns
);
4357 /* Keep the parent fake result declaration in module functions
4358 or external procedures. */
4359 if ((ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
4360 || ns
->parent
== NULL
)
4361 current_fake_result_decl
= parent_fake_result_decl
;
4363 current_fake_result_decl
= NULL_TREE
;
4365 current_function_return_label
= NULL
;
4367 /* Now generate the code for the body of this function. */
4368 gfc_init_block (&body
);
4370 is_recursive
= sym
->attr
.recursive
4371 || (sym
->attr
.entry_master
4372 && sym
->ns
->entries
->sym
->attr
.recursive
);
4373 if ((gfc_option
.rtcheck
& GFC_RTCHECK_RECURSION
)
4375 && !gfc_option
.flag_recursive
)
4379 asprintf (&msg
, "Recursive call to nonrecursive procedure '%s'",
4381 recurcheckvar
= gfc_create_var (boolean_type_node
, "is_recursive");
4382 TREE_STATIC (recurcheckvar
) = 1;
4383 DECL_INITIAL (recurcheckvar
) = boolean_false_node
;
4384 gfc_add_expr_to_block (&block
, recurcheckvar
);
4385 gfc_trans_runtime_check (true, false, recurcheckvar
, &block
,
4386 &sym
->declared_at
, msg
);
4387 gfc_add_modify (&block
, recurcheckvar
, boolean_true_node
);
4391 if (TREE_TYPE (DECL_RESULT (fndecl
)) != void_type_node
4392 && sym
->attr
.subroutine
)
4394 tree alternate_return
;
4395 alternate_return
= gfc_get_fake_result_decl (sym
, 0);
4396 gfc_add_modify (&body
, alternate_return
, integer_zero_node
);
4401 /* Jump to the correct entry point. */
4402 tmp
= gfc_trans_entry_master_switch (ns
->entries
);
4403 gfc_add_expr_to_block (&body
, tmp
);
4406 /* If bounds-checking is enabled, generate code to check passed in actual
4407 arguments against the expected dummy argument attributes (e.g. string
4409 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) && !sym
->attr
.is_bind_c
)
4410 add_argument_checking (&body
, sym
);
4412 tmp
= gfc_trans_code (ns
->code
);
4413 gfc_add_expr_to_block (&body
, tmp
);
4415 /* Add a return label if needed. */
4416 if (current_function_return_label
)
4418 tmp
= build1_v (LABEL_EXPR
, current_function_return_label
);
4419 gfc_add_expr_to_block (&body
, tmp
);
4422 tmp
= gfc_finish_block (&body
);
4423 /* Add code to create and cleanup arrays. */
4424 tmp
= gfc_trans_deferred_vars (sym
, tmp
);
4426 if (TREE_TYPE (DECL_RESULT (fndecl
)) != void_type_node
)
4428 if (sym
->attr
.subroutine
|| sym
== sym
->result
)
4430 if (current_fake_result_decl
!= NULL
)
4431 result
= TREE_VALUE (current_fake_result_decl
);
4434 current_fake_result_decl
= NULL_TREE
;
4437 result
= sym
->result
->backend_decl
;
4439 if (result
!= NULL_TREE
4440 && sym
->attr
.function
4441 && !sym
->attr
.pointer
)
4443 if (sym
->ts
.type
== BT_DERIVED
4444 && sym
->ts
.u
.derived
->attr
.alloc_comp
)
4446 rank
= sym
->as
? sym
->as
->rank
: 0;
4447 tmp2
= gfc_nullify_alloc_comp (sym
->ts
.u
.derived
, result
, rank
);
4448 gfc_add_expr_to_block (&block
, tmp2
);
4450 else if (sym
->attr
.allocatable
&& sym
->attr
.dimension
== 0)
4451 gfc_add_modify (&block
, result
, fold_convert (TREE_TYPE (result
),
4452 null_pointer_node
));
4455 gfc_add_expr_to_block (&block
, tmp
);
4457 /* Reset recursion-check variable. */
4458 if ((gfc_option
.rtcheck
& GFC_RTCHECK_RECURSION
)
4460 && !gfc_option
.flag_openmp
4461 && recurcheckvar
!= NULL_TREE
)
4463 gfc_add_modify (&block
, recurcheckvar
, boolean_false_node
);
4464 recurcheckvar
= NULL
;
4467 if (result
== NULL_TREE
)
4469 /* TODO: move to the appropriate place in resolve.c. */
4470 if (warn_return_type
&& !sym
->attr
.referenced
&& sym
== sym
->result
)
4471 gfc_warning ("Return value of function '%s' at %L not set",
4472 sym
->name
, &sym
->declared_at
);
4474 TREE_NO_WARNING(sym
->backend_decl
) = 1;
4478 /* Set the return value to the dummy result variable. The
4479 types may be different for scalar default REAL functions
4480 with -ff2c, therefore we have to convert. */
4481 tmp
= convert (TREE_TYPE (DECL_RESULT (fndecl
)), result
);
4482 tmp
= fold_build2 (MODIFY_EXPR
, TREE_TYPE (tmp
),
4483 DECL_RESULT (fndecl
), tmp
);
4484 tmp
= build1_v (RETURN_EXPR
, tmp
);
4485 gfc_add_expr_to_block (&block
, tmp
);
4490 gfc_add_expr_to_block (&block
, tmp
);
4491 /* Reset recursion-check variable. */
4492 if ((gfc_option
.rtcheck
& GFC_RTCHECK_RECURSION
)
4494 && !gfc_option
.flag_openmp
4495 && recurcheckvar
!= NULL_TREE
)
4497 gfc_add_modify (&block
, recurcheckvar
, boolean_false_node
);
4498 recurcheckvar
= NULL_TREE
;
4503 /* Add all the decls we created during processing. */
4504 decl
= saved_function_decls
;
4509 next
= TREE_CHAIN (decl
);
4510 TREE_CHAIN (decl
) = NULL_TREE
;
4514 saved_function_decls
= NULL_TREE
;
4516 DECL_SAVED_TREE (fndecl
) = gfc_finish_block (&block
);
4519 /* Finish off this function and send it for code generation. */
4521 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl
)) = fndecl
;
4523 DECL_SAVED_TREE (fndecl
)
4524 = build3_v (BIND_EXPR
, decl
, DECL_SAVED_TREE (fndecl
),
4525 DECL_INITIAL (fndecl
));
4527 if (nonlocal_dummy_decls
)
4529 BLOCK_VARS (DECL_INITIAL (fndecl
))
4530 = chainon (BLOCK_VARS (DECL_INITIAL (fndecl
)), nonlocal_dummy_decls
);
4531 pointer_set_destroy (nonlocal_dummy_decl_pset
);
4532 nonlocal_dummy_decls
= NULL
;
4533 nonlocal_dummy_decl_pset
= NULL
;
4536 /* Output the GENERIC tree. */
4537 dump_function (TDI_original
, fndecl
);
4539 /* Store the end of the function, so that we get good line number
4540 info for the epilogue. */
4541 cfun
->function_end_locus
= input_location
;
4543 /* We're leaving the context of this function, so zap cfun.
4544 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
4545 tree_rest_of_compilation. */
4550 pop_function_context ();
4551 saved_function_decls
= saved_parent_function_decls
;
4553 current_function_decl
= old_context
;
4555 if (decl_function_context (fndecl
))
4556 /* Register this function with cgraph just far enough to get it
4557 added to our parent's nested function list. */
4558 (void) cgraph_node (fndecl
);
4560 cgraph_finalize_function (fndecl
, true);
4562 gfc_trans_use_stmts (ns
);
4563 gfc_traverse_ns (ns
, gfc_emit_parameter_debug_info
);
4565 if (sym
->attr
.is_main_program
)
4566 create_main_function (fndecl
);
4571 gfc_generate_constructors (void)
4573 gcc_assert (gfc_static_ctors
== NULL_TREE
);
4581 if (gfc_static_ctors
== NULL_TREE
)
4584 fnname
= get_file_function_name ("I");
4585 type
= build_function_type (void_type_node
,
4586 gfc_chainon_list (NULL_TREE
, void_type_node
));
4588 fndecl
= build_decl (input_location
,
4589 FUNCTION_DECL
, fnname
, type
);
4590 TREE_PUBLIC (fndecl
) = 1;
4592 decl
= build_decl (input_location
,
4593 RESULT_DECL
, NULL_TREE
, void_type_node
);
4594 DECL_ARTIFICIAL (decl
) = 1;
4595 DECL_IGNORED_P (decl
) = 1;
4596 DECL_CONTEXT (decl
) = fndecl
;
4597 DECL_RESULT (fndecl
) = decl
;
4601 current_function_decl
= fndecl
;
4603 rest_of_decl_compilation (fndecl
, 1, 0);
4605 make_decl_rtl (fndecl
);
4607 init_function_start (fndecl
);
4611 for (; gfc_static_ctors
; gfc_static_ctors
= TREE_CHAIN (gfc_static_ctors
))
4613 tmp
= build_call_expr_loc (input_location
,
4614 TREE_VALUE (gfc_static_ctors
), 0);
4615 DECL_SAVED_TREE (fndecl
) = build_stmt (input_location
, EXPR_STMT
, tmp
);
4621 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl
)) = fndecl
;
4622 DECL_SAVED_TREE (fndecl
)
4623 = build3_v (BIND_EXPR
, decl
, DECL_SAVED_TREE (fndecl
),
4624 DECL_INITIAL (fndecl
));
4626 free_after_parsing (cfun
);
4627 free_after_compilation (cfun
);
4629 tree_rest_of_compilation (fndecl
);
4631 current_function_decl
= NULL_TREE
;
4635 /* Translates a BLOCK DATA program unit. This means emitting the
4636 commons contained therein plus their initializations. We also emit
4637 a globally visible symbol to make sure that each BLOCK DATA program
4638 unit remains unique. */
4641 gfc_generate_block_data (gfc_namespace
* ns
)
4646 /* Tell the backend the source location of the block data. */
4648 gfc_set_backend_locus (&ns
->proc_name
->declared_at
);
4650 gfc_set_backend_locus (&gfc_current_locus
);
4652 /* Process the DATA statements. */
4653 gfc_trans_common (ns
);
4655 /* Create a global symbol with the mane of the block data. This is to
4656 generate linker errors if the same name is used twice. It is never
4659 id
= gfc_sym_mangled_function_id (ns
->proc_name
);
4661 id
= get_identifier ("__BLOCK_DATA__");
4663 decl
= build_decl (input_location
,
4664 VAR_DECL
, id
, gfc_array_index_type
);
4665 TREE_PUBLIC (decl
) = 1;
4666 TREE_STATIC (decl
) = 1;
4667 DECL_IGNORED_P (decl
) = 1;
4670 rest_of_decl_compilation (decl
, 1, 0);
4674 /* Process the local variables of a BLOCK construct. */
4677 gfc_process_block_locals (gfc_namespace
* ns
)
4681 gcc_assert (saved_local_decls
== NULL_TREE
);
4682 generate_local_vars (ns
);
4684 decl
= saved_local_decls
;
4689 next
= TREE_CHAIN (decl
);
4690 TREE_CHAIN (decl
) = NULL_TREE
;
4694 saved_local_decls
= NULL_TREE
;
4698 #include "gt-fortran-trans-decl.h"