1 /* Backend function setup
2 Copyright (C) 2002-2019 Free Software Foundation, Inc.
3 Contributed by Paul Brook
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
21 /* trans-decl.c -- Handling of backend function and variable decls, etc */
25 #include "coretypes.h"
30 #include "gimple-expr.h" /* For create_tmp_var_raw. */
32 #include "stringpool.h"
34 #include "fold-const.h"
35 #include "stor-layout.h"
39 #include "toplev.h" /* For announce_function. */
41 #include "constructor.h"
42 #include "trans-types.h"
43 #include "trans-array.h"
44 #include "trans-const.h"
45 /* Only for gfc_trans_code. Shouldn't need to include this. */
46 #include "trans-stmt.h"
47 #include "gomp-constants.h"
49 #include "omp-general.h"
51 #define MAX_LABEL_VALUE 99999
54 /* Holds the result of the function if no result variable specified. */
56 static GTY(()) tree current_fake_result_decl
;
57 static GTY(()) tree parent_fake_result_decl
;
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 /* Holds the variable DECLs that are locals. */
67 static GTY(()) tree saved_local_decls
;
69 /* The namespace of the module we're currently generating. Only used while
70 outputting decls for module variables. Do not rely on this being set. */
72 static gfc_namespace
*module_namespace
;
74 /* The currently processed procedure symbol. */
75 static gfc_symbol
* current_procedure_symbol
= NULL
;
77 /* The currently processed module. */
78 static struct module_htab_entry
*cur_module
;
80 /* With -fcoarray=lib: For generating the registering call
81 of static coarrays. */
82 static bool has_coarray_vars
;
83 static stmtblock_t caf_init_block
;
86 /* List of static constructor functions. */
88 tree gfc_static_ctors
;
91 /* Whether we've seen a symbol from an IEEE module in the namespace. */
92 static int seen_ieee_symbol
;
94 /* Function declarations for builtin library functions. */
96 tree gfor_fndecl_pause_numeric
;
97 tree gfor_fndecl_pause_string
;
98 tree gfor_fndecl_stop_numeric
;
99 tree gfor_fndecl_stop_string
;
100 tree gfor_fndecl_error_stop_numeric
;
101 tree gfor_fndecl_error_stop_string
;
102 tree gfor_fndecl_runtime_error
;
103 tree gfor_fndecl_runtime_error_at
;
104 tree gfor_fndecl_runtime_warning_at
;
105 tree gfor_fndecl_os_error_at
;
106 tree gfor_fndecl_generate_error
;
107 tree gfor_fndecl_set_args
;
108 tree gfor_fndecl_set_fpe
;
109 tree gfor_fndecl_set_options
;
110 tree gfor_fndecl_set_convert
;
111 tree gfor_fndecl_set_record_marker
;
112 tree gfor_fndecl_set_max_subrecord_length
;
113 tree gfor_fndecl_ctime
;
114 tree gfor_fndecl_fdate
;
115 tree gfor_fndecl_ttynam
;
116 tree gfor_fndecl_in_pack
;
117 tree gfor_fndecl_in_unpack
;
118 tree gfor_fndecl_cfi_to_gfc
;
119 tree gfor_fndecl_gfc_to_cfi
;
120 tree gfor_fndecl_associated
;
121 tree gfor_fndecl_system_clock4
;
122 tree gfor_fndecl_system_clock8
;
123 tree gfor_fndecl_ieee_procedure_entry
;
124 tree gfor_fndecl_ieee_procedure_exit
;
126 /* Coarray run-time library function decls. */
127 tree gfor_fndecl_caf_init
;
128 tree gfor_fndecl_caf_finalize
;
129 tree gfor_fndecl_caf_this_image
;
130 tree gfor_fndecl_caf_num_images
;
131 tree gfor_fndecl_caf_register
;
132 tree gfor_fndecl_caf_deregister
;
133 tree gfor_fndecl_caf_get
;
134 tree gfor_fndecl_caf_send
;
135 tree gfor_fndecl_caf_sendget
;
136 tree gfor_fndecl_caf_get_by_ref
;
137 tree gfor_fndecl_caf_send_by_ref
;
138 tree gfor_fndecl_caf_sendget_by_ref
;
139 tree gfor_fndecl_caf_sync_all
;
140 tree gfor_fndecl_caf_sync_memory
;
141 tree gfor_fndecl_caf_sync_images
;
142 tree gfor_fndecl_caf_stop_str
;
143 tree gfor_fndecl_caf_stop_numeric
;
144 tree gfor_fndecl_caf_error_stop
;
145 tree gfor_fndecl_caf_error_stop_str
;
146 tree gfor_fndecl_caf_atomic_def
;
147 tree gfor_fndecl_caf_atomic_ref
;
148 tree gfor_fndecl_caf_atomic_cas
;
149 tree gfor_fndecl_caf_atomic_op
;
150 tree gfor_fndecl_caf_lock
;
151 tree gfor_fndecl_caf_unlock
;
152 tree gfor_fndecl_caf_event_post
;
153 tree gfor_fndecl_caf_event_wait
;
154 tree gfor_fndecl_caf_event_query
;
155 tree gfor_fndecl_caf_fail_image
;
156 tree gfor_fndecl_caf_failed_images
;
157 tree gfor_fndecl_caf_image_status
;
158 tree gfor_fndecl_caf_stopped_images
;
159 tree gfor_fndecl_caf_form_team
;
160 tree gfor_fndecl_caf_change_team
;
161 tree gfor_fndecl_caf_end_team
;
162 tree gfor_fndecl_caf_sync_team
;
163 tree gfor_fndecl_caf_get_team
;
164 tree gfor_fndecl_caf_team_number
;
165 tree gfor_fndecl_co_broadcast
;
166 tree gfor_fndecl_co_max
;
167 tree gfor_fndecl_co_min
;
168 tree gfor_fndecl_co_reduce
;
169 tree gfor_fndecl_co_sum
;
170 tree gfor_fndecl_caf_is_present
;
173 /* Math functions. Many other math functions are handled in
174 trans-intrinsic.c. */
176 gfc_powdecl_list gfor_fndecl_math_powi
[4][3];
177 tree gfor_fndecl_math_ishftc4
;
178 tree gfor_fndecl_math_ishftc8
;
179 tree gfor_fndecl_math_ishftc16
;
182 /* String functions. */
184 tree gfor_fndecl_compare_string
;
185 tree gfor_fndecl_concat_string
;
186 tree gfor_fndecl_string_len_trim
;
187 tree gfor_fndecl_string_index
;
188 tree gfor_fndecl_string_scan
;
189 tree gfor_fndecl_string_verify
;
190 tree gfor_fndecl_string_trim
;
191 tree gfor_fndecl_string_minmax
;
192 tree gfor_fndecl_adjustl
;
193 tree gfor_fndecl_adjustr
;
194 tree gfor_fndecl_select_string
;
195 tree gfor_fndecl_compare_string_char4
;
196 tree gfor_fndecl_concat_string_char4
;
197 tree gfor_fndecl_string_len_trim_char4
;
198 tree gfor_fndecl_string_index_char4
;
199 tree gfor_fndecl_string_scan_char4
;
200 tree gfor_fndecl_string_verify_char4
;
201 tree gfor_fndecl_string_trim_char4
;
202 tree gfor_fndecl_string_minmax_char4
;
203 tree gfor_fndecl_adjustl_char4
;
204 tree gfor_fndecl_adjustr_char4
;
205 tree gfor_fndecl_select_string_char4
;
208 /* Conversion between character kinds. */
209 tree gfor_fndecl_convert_char1_to_char4
;
210 tree gfor_fndecl_convert_char4_to_char1
;
213 /* Other misc. runtime library functions. */
214 tree gfor_fndecl_size0
;
215 tree gfor_fndecl_size1
;
216 tree gfor_fndecl_iargc
;
217 tree gfor_fndecl_kill
;
218 tree gfor_fndecl_kill_sub
;
219 tree gfor_fndecl_is_contiguous0
;
222 /* Intrinsic functions implemented in Fortran. */
223 tree gfor_fndecl_sc_kind
;
224 tree gfor_fndecl_si_kind
;
225 tree gfor_fndecl_sr_kind
;
227 /* BLAS gemm functions. */
228 tree gfor_fndecl_sgemm
;
229 tree gfor_fndecl_dgemm
;
230 tree gfor_fndecl_cgemm
;
231 tree gfor_fndecl_zgemm
;
233 /* RANDOM_INIT function. */
234 tree gfor_fndecl_random_init
;
237 gfc_add_decl_to_parent_function (tree decl
)
240 DECL_CONTEXT (decl
) = DECL_CONTEXT (current_function_decl
);
241 DECL_NONLOCAL (decl
) = 1;
242 DECL_CHAIN (decl
) = saved_parent_function_decls
;
243 saved_parent_function_decls
= decl
;
247 gfc_add_decl_to_function (tree decl
)
250 TREE_USED (decl
) = 1;
251 DECL_CONTEXT (decl
) = current_function_decl
;
252 DECL_CHAIN (decl
) = saved_function_decls
;
253 saved_function_decls
= decl
;
257 add_decl_as_local (tree decl
)
260 TREE_USED (decl
) = 1;
261 DECL_CONTEXT (decl
) = current_function_decl
;
262 DECL_CHAIN (decl
) = saved_local_decls
;
263 saved_local_decls
= decl
;
267 /* Build a backend label declaration. Set TREE_USED for named labels.
268 The context of the label is always the current_function_decl. All
269 labels are marked artificial. */
272 gfc_build_label_decl (tree label_id
)
274 /* 2^32 temporaries should be enough. */
275 static unsigned int tmp_num
= 1;
279 if (label_id
== NULL_TREE
)
281 /* Build an internal label name. */
282 ASM_FORMAT_PRIVATE_NAME (label_name
, "L", tmp_num
++);
283 label_id
= get_identifier (label_name
);
288 /* Build the LABEL_DECL node. Labels have no type. */
289 label_decl
= build_decl (input_location
,
290 LABEL_DECL
, label_id
, void_type_node
);
291 DECL_CONTEXT (label_decl
) = current_function_decl
;
292 SET_DECL_MODE (label_decl
, VOIDmode
);
294 /* We always define the label as used, even if the original source
295 file never references the label. We don't want all kinds of
296 spurious warnings for old-style Fortran code with too many
298 TREE_USED (label_decl
) = 1;
300 DECL_ARTIFICIAL (label_decl
) = 1;
305 /* Set the backend source location of a decl. */
308 gfc_set_decl_location (tree decl
, locus
* loc
)
310 DECL_SOURCE_LOCATION (decl
) = loc
->lb
->location
;
314 /* Return the backend label declaration for a given label structure,
315 or create it if it doesn't exist yet. */
318 gfc_get_label_decl (gfc_st_label
* lp
)
320 if (lp
->backend_decl
)
321 return lp
->backend_decl
;
324 char label_name
[GFC_MAX_SYMBOL_LEN
+ 1];
327 /* Validate the label declaration from the front end. */
328 gcc_assert (lp
!= NULL
&& lp
->value
<= MAX_LABEL_VALUE
);
330 /* Build a mangled name for the label. */
331 sprintf (label_name
, "__label_%.6d", lp
->value
);
333 /* Build the LABEL_DECL node. */
334 label_decl
= gfc_build_label_decl (get_identifier (label_name
));
336 /* Tell the debugger where the label came from. */
337 if (lp
->value
<= MAX_LABEL_VALUE
) /* An internal label. */
338 gfc_set_decl_location (label_decl
, &lp
->where
);
340 DECL_ARTIFICIAL (label_decl
) = 1;
342 /* Store the label in the label list and return the LABEL_DECL. */
343 lp
->backend_decl
= label_decl
;
348 /* Return the name of an identifier. */
351 sym_identifier (gfc_symbol
*sym
)
353 if (sym
->attr
.is_main_program
&& strcmp (sym
->name
, "main") == 0)
359 /* Convert a gfc_symbol to an identifier of the same name. */
362 gfc_sym_identifier (gfc_symbol
* sym
)
364 return get_identifier (sym_identifier (sym
));
367 /* Construct mangled name from symbol name. */
370 mangled_identifier (gfc_symbol
*sym
)
372 static char name
[GFC_MAX_MANGLED_SYMBOL_LEN
+ 1];
373 /* Prevent the mangling of identifiers that have an assigned
374 binding label (mainly those that are bind(c)). */
376 if (sym
->attr
.is_bind_c
== 1 && sym
->binding_label
)
377 return sym
->binding_label
;
379 if (!sym
->fn_result_spec
)
381 if (sym
->module
== NULL
)
382 return sym_identifier (sym
);
385 snprintf (name
, sizeof name
, "__%s_MOD_%s", sym
->module
, sym
->name
);
391 /* This is an entity that is actually local to a module procedure
392 that appears in the result specification expression. Since
393 sym->module will be a zero length string, we use ns->proc_name
395 if (sym
->ns
->proc_name
&& sym
->ns
->proc_name
->module
)
397 snprintf (name
, sizeof name
, "__%s_MOD__%s_PROC_%s",
398 sym
->ns
->proc_name
->module
,
399 sym
->ns
->proc_name
->name
,
405 snprintf (name
, sizeof name
, "__%s_PROC_%s",
406 sym
->ns
->proc_name
->name
, sym
->name
);
412 /* Get mangled identifier, adding the symbol to the global table if
413 it is not yet already there. */
416 gfc_sym_mangled_identifier (gfc_symbol
* sym
)
422 name
= mangled_identifier (sym
);
423 result
= get_identifier (name
);
425 gsym
= gfc_find_gsymbol (gfc_gsym_root
, name
);
428 gsym
= gfc_get_gsymbol (name
, false);
430 gsym
->sym_name
= sym
->name
;
436 /* Construct mangled function name from symbol name. */
439 gfc_sym_mangled_function_id (gfc_symbol
* sym
)
442 char name
[GFC_MAX_MANGLED_SYMBOL_LEN
+ 1];
444 /* It may be possible to simply use the binding label if it's
445 provided, and remove the other checks. Then we could use it
446 for other things if we wished. */
447 if ((sym
->attr
.is_bind_c
== 1 || sym
->attr
.is_iso_c
== 1) &&
449 /* use the binding label rather than the mangled name */
450 return get_identifier (sym
->binding_label
);
452 if ((sym
->module
== NULL
|| sym
->attr
.proc
== PROC_EXTERNAL
453 || (sym
->module
!= NULL
&& (sym
->attr
.external
454 || sym
->attr
.if_source
== IFSRC_IFBODY
)))
455 && !sym
->attr
.module_procedure
)
457 /* Main program is mangled into MAIN__. */
458 if (sym
->attr
.is_main_program
)
459 return get_identifier ("MAIN__");
461 /* Intrinsic procedures are never mangled. */
462 if (sym
->attr
.proc
== PROC_INTRINSIC
)
463 return get_identifier (sym
->name
);
465 if (flag_underscoring
)
467 has_underscore
= strchr (sym
->name
, '_') != 0;
468 if (flag_second_underscore
&& has_underscore
)
469 snprintf (name
, sizeof name
, "%s__", sym
->name
);
471 snprintf (name
, sizeof name
, "%s_", sym
->name
);
472 return get_identifier (name
);
475 return get_identifier (sym
->name
);
479 snprintf (name
, sizeof name
, "__%s_MOD_%s", sym
->module
, sym
->name
);
480 return get_identifier (name
);
486 gfc_set_decl_assembler_name (tree decl
, tree name
)
488 tree target_mangled
= targetm
.mangle_decl_assembler_name (decl
, name
);
489 SET_DECL_ASSEMBLER_NAME (decl
, target_mangled
);
493 /* Returns true if a variable of specified size should go on the stack. */
496 gfc_can_put_var_on_stack (tree size
)
498 unsigned HOST_WIDE_INT low
;
500 if (!INTEGER_CST_P (size
))
503 if (flag_max_stack_var_size
< 0)
506 if (!tree_fits_uhwi_p (size
))
509 low
= TREE_INT_CST_LOW (size
);
510 if (low
> (unsigned HOST_WIDE_INT
) flag_max_stack_var_size
)
513 /* TODO: Set a per-function stack size limit. */
519 /* gfc_finish_cray_pointee sets DECL_VALUE_EXPR for a Cray pointee to
520 an expression involving its corresponding pointer. There are
521 2 cases; one for variable size arrays, and one for everything else,
522 because variable-sized arrays require one fewer level of
526 gfc_finish_cray_pointee (tree decl
, gfc_symbol
*sym
)
528 tree ptr_decl
= gfc_get_symbol_decl (sym
->cp_pointer
);
531 /* Parameters need to be dereferenced. */
532 if (sym
->cp_pointer
->attr
.dummy
)
533 ptr_decl
= build_fold_indirect_ref_loc (input_location
,
536 /* Check to see if we're dealing with a variable-sized array. */
537 if (sym
->attr
.dimension
538 && TREE_CODE (TREE_TYPE (decl
)) == POINTER_TYPE
)
540 /* These decls will be dereferenced later, so we don't dereference
542 value
= convert (TREE_TYPE (decl
), ptr_decl
);
546 ptr_decl
= convert (build_pointer_type (TREE_TYPE (decl
)),
548 value
= build_fold_indirect_ref_loc (input_location
,
552 SET_DECL_VALUE_EXPR (decl
, value
);
553 DECL_HAS_VALUE_EXPR_P (decl
) = 1;
554 GFC_DECL_CRAY_POINTEE (decl
) = 1;
558 /* Finish processing of a declaration without an initial value. */
561 gfc_finish_decl (tree decl
)
563 gcc_assert (TREE_CODE (decl
) == PARM_DECL
564 || DECL_INITIAL (decl
) == NULL_TREE
);
569 if (DECL_SIZE (decl
) == NULL_TREE
570 && TYPE_SIZE (TREE_TYPE (decl
)) != NULL_TREE
)
571 layout_decl (decl
, 0);
573 /* A few consistency checks. */
574 /* A static variable with an incomplete type is an error if it is
575 initialized. Also if it is not file scope. Otherwise, let it
576 through, but if it is not `extern' then it may cause an error
578 /* An automatic variable with an incomplete type is an error. */
580 /* We should know the storage size. */
581 gcc_assert (DECL_SIZE (decl
) != NULL_TREE
582 || (TREE_STATIC (decl
)
583 ? (!DECL_INITIAL (decl
) || !DECL_CONTEXT (decl
))
584 : DECL_EXTERNAL (decl
)));
586 /* The storage size should be constant. */
587 gcc_assert ((!DECL_EXTERNAL (decl
) && !TREE_STATIC (decl
))
589 || TREE_CODE (DECL_SIZE (decl
)) == INTEGER_CST
);
593 /* Handle setting of GFC_DECL_SCALAR* on DECL. */
596 gfc_finish_decl_attrs (tree decl
, symbol_attribute
*attr
)
598 if (!attr
->dimension
&& !attr
->codimension
)
600 /* Handle scalar allocatable variables. */
601 if (attr
->allocatable
)
603 gfc_allocate_lang_decl (decl
);
604 GFC_DECL_SCALAR_ALLOCATABLE (decl
) = 1;
606 /* Handle scalar pointer variables. */
609 gfc_allocate_lang_decl (decl
);
610 GFC_DECL_SCALAR_POINTER (decl
) = 1;
616 /* Apply symbol attributes to a variable, and add it to the function scope. */
619 gfc_finish_var_decl (tree decl
, gfc_symbol
* sym
)
623 /* Set DECL_VALUE_EXPR for Cray Pointees. */
624 if (sym
->attr
.cray_pointee
)
625 gfc_finish_cray_pointee (decl
, sym
);
627 /* TREE_ADDRESSABLE means the address of this variable is actually needed.
628 This is the equivalent of the TARGET variables.
629 We also need to set this if the variable is passed by reference in a
631 if (sym
->attr
.target
)
632 TREE_ADDRESSABLE (decl
) = 1;
634 /* If it wasn't used we wouldn't be getting it. */
635 TREE_USED (decl
) = 1;
637 if (sym
->attr
.flavor
== FL_PARAMETER
638 && (sym
->attr
.dimension
|| sym
->ts
.type
== BT_DERIVED
))
639 TREE_READONLY (decl
) = 1;
641 /* Chain this decl to the pending declarations. Don't do pushdecl()
642 because this would add them to the current scope rather than the
644 if (current_function_decl
!= NULL_TREE
)
646 if (sym
->ns
->proc_name
647 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
648 || sym
->result
== sym
))
649 gfc_add_decl_to_function (decl
);
650 else if (sym
->ns
->proc_name
651 && sym
->ns
->proc_name
->attr
.flavor
== FL_LABEL
)
652 /* This is a BLOCK construct. */
653 add_decl_as_local (decl
);
655 gfc_add_decl_to_parent_function (decl
);
658 if (sym
->attr
.cray_pointee
)
661 if(sym
->attr
.is_bind_c
== 1 && sym
->binding_label
)
663 /* We need to put variables that are bind(c) into the common
664 segment of the object file, because this is what C would do.
665 gfortran would typically put them in either the BSS or
666 initialized data segments, and only mark them as common if
667 they were part of common blocks. However, if they are not put
668 into common space, then C cannot initialize global Fortran
669 variables that it interoperates with and the draft says that
670 either Fortran or C should be able to initialize it (but not
671 both, of course.) (J3/04-007, section 15.3). */
672 TREE_PUBLIC(decl
) = 1;
673 DECL_COMMON(decl
) = 1;
674 if (sym
->attr
.access
== ACCESS_PRIVATE
&& !sym
->attr
.public_used
)
676 DECL_VISIBILITY (decl
) = VISIBILITY_HIDDEN
;
677 DECL_VISIBILITY_SPECIFIED (decl
) = true;
681 /* If a variable is USE associated, it's always external. */
682 if (sym
->attr
.use_assoc
|| sym
->attr
.used_in_submodule
)
684 DECL_EXTERNAL (decl
) = 1;
685 TREE_PUBLIC (decl
) = 1;
687 else if (sym
->fn_result_spec
&& !sym
->ns
->proc_name
->module
)
690 if (sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_DECL
)
691 DECL_EXTERNAL (decl
) = 1;
693 TREE_STATIC (decl
) = 1;
695 TREE_PUBLIC (decl
) = 1;
697 else if (sym
->module
&& !sym
->attr
.result
&& !sym
->attr
.dummy
)
699 /* TODO: Don't set sym->module for result or dummy variables. */
700 gcc_assert (current_function_decl
== NULL_TREE
|| sym
->result
== sym
);
702 TREE_PUBLIC (decl
) = 1;
703 TREE_STATIC (decl
) = 1;
704 if (sym
->attr
.access
== ACCESS_PRIVATE
&& !sym
->attr
.public_used
)
706 DECL_VISIBILITY (decl
) = VISIBILITY_HIDDEN
;
707 DECL_VISIBILITY_SPECIFIED (decl
) = true;
711 /* Derived types are a bit peculiar because of the possibility of
712 a default initializer; this must be applied each time the variable
713 comes into scope it therefore need not be static. These variables
714 are SAVE_NONE but have an initializer. Otherwise explicitly
715 initialized variables are SAVE_IMPLICIT and explicitly saved are
717 if (!sym
->attr
.use_assoc
718 && (sym
->attr
.save
!= SAVE_NONE
|| sym
->attr
.data
719 || (sym
->value
&& sym
->ns
->proc_name
->attr
.is_main_program
)
720 || (flag_coarray
== GFC_FCOARRAY_LIB
721 && sym
->attr
.codimension
&& !sym
->attr
.allocatable
)))
722 TREE_STATIC (decl
) = 1;
724 /* If derived-type variables with DTIO procedures are not made static
725 some bits of code referencing them get optimized away.
726 TODO Understand why this is so and fix it. */
727 if (!sym
->attr
.use_assoc
728 && ((sym
->ts
.type
== BT_DERIVED
729 && sym
->ts
.u
.derived
->attr
.has_dtio_procs
)
730 || (sym
->ts
.type
== BT_CLASS
731 && CLASS_DATA (sym
)->ts
.u
.derived
->attr
.has_dtio_procs
)))
732 TREE_STATIC (decl
) = 1;
734 /* Treat asynchronous variables the same as volatile, for now. */
735 if (sym
->attr
.volatile_
|| sym
->attr
.asynchronous
)
737 TREE_THIS_VOLATILE (decl
) = 1;
738 TREE_SIDE_EFFECTS (decl
) = 1;
739 new_type
= build_qualified_type (TREE_TYPE (decl
), TYPE_QUAL_VOLATILE
);
740 TREE_TYPE (decl
) = new_type
;
743 /* Keep variables larger than max-stack-var-size off stack. */
744 if (!(sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.recursive
)
745 && !sym
->attr
.automatic
746 && INTEGER_CST_P (DECL_SIZE_UNIT (decl
))
747 && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl
))
748 /* Put variable length auto array pointers always into stack. */
749 && (TREE_CODE (TREE_TYPE (decl
)) != POINTER_TYPE
750 || sym
->attr
.dimension
== 0
751 || sym
->as
->type
!= AS_EXPLICIT
753 || sym
->attr
.allocatable
)
754 && !DECL_ARTIFICIAL (decl
))
756 gfc_warning (OPT_Wsurprising
,
757 "Array %qs at %L is larger than limit set by"
758 " %<-fmax-stack-var-size=%>, moved from stack to static"
759 " storage. This makes the procedure unsafe when called"
760 " recursively, or concurrently from multiple threads."
761 " Consider using %<-frecursive%>, or increase the"
762 " %<-fmax-stack-var-size=%> limit, or change the code to"
763 " use an ALLOCATABLE array.",
764 sym
->name
, &sym
->declared_at
);
766 TREE_STATIC (decl
) = 1;
768 /* Because the size of this variable isn't known until now, we may have
769 greedily added an initializer to this variable (in build_init_assign)
770 even though the max-stack-var-size indicates the variable should be
771 static. Therefore we rip out the automatic initializer here and
772 replace it with a static one. */
773 gfc_symtree
*st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
774 gfc_code
*prev
= NULL
;
775 gfc_code
*code
= sym
->ns
->code
;
776 while (code
&& code
->op
== EXEC_INIT_ASSIGN
)
778 /* Look for an initializer meant for this symbol. */
779 if (code
->expr1
->symtree
== st
)
782 prev
->next
= code
->next
;
784 sym
->ns
->code
= code
->next
;
792 if (code
&& code
->op
== EXEC_INIT_ASSIGN
)
794 /* Keep the init expression for a static initializer. */
795 sym
->value
= code
->expr2
;
796 /* Cleanup the defunct code object, without freeing the init expr. */
798 gfc_free_statement (code
);
803 /* Handle threadprivate variables. */
804 if (sym
->attr
.threadprivate
805 && (TREE_STATIC (decl
) || DECL_EXTERNAL (decl
)))
806 set_decl_tls_model (decl
, decl_default_tls_model (decl
));
808 gfc_finish_decl_attrs (decl
, &sym
->attr
);
812 /* Allocate the lang-specific part of a decl. */
815 gfc_allocate_lang_decl (tree decl
)
817 if (DECL_LANG_SPECIFIC (decl
) == NULL
)
818 DECL_LANG_SPECIFIC (decl
) = ggc_cleared_alloc
<struct lang_decl
> ();
821 /* Remember a symbol to generate initialization/cleanup code at function
825 gfc_defer_symbol_init (gfc_symbol
* sym
)
831 /* Don't add a symbol twice. */
835 last
= head
= sym
->ns
->proc_name
;
838 /* Make sure that setup code for dummy variables which are used in the
839 setup of other variables is generated first. */
842 /* Find the first dummy arg seen after us, or the first non-dummy arg.
843 This is a circular list, so don't go past the head. */
845 && (!p
->attr
.dummy
|| p
->dummy_order
> sym
->dummy_order
))
851 /* Insert in between last and p. */
857 /* Used in gfc_get_symbol_decl and gfc_get_derived_type to obtain the
858 backend_decl for a module symbol, if it all ready exists. If the
859 module gsymbol does not exist, it is created. If the symbol does
860 not exist, it is added to the gsymbol namespace. Returns true if
861 an existing backend_decl is found. */
864 gfc_get_module_backend_decl (gfc_symbol
*sym
)
870 gsym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->module
);
872 if (!gsym
|| (gsym
->ns
&& gsym
->type
== GSYM_MODULE
))
877 /* Check for a symbol with the same name. */
879 gfc_find_symbol (sym
->name
, gsym
->ns
, 0, &s
);
885 gsym
= gfc_get_gsymbol (sym
->module
, false);
886 gsym
->type
= GSYM_MODULE
;
887 gsym
->ns
= gfc_get_namespace (NULL
, 0);
890 st
= gfc_new_symtree (&gsym
->ns
->sym_root
, sym
->name
);
894 else if (gfc_fl_struct (sym
->attr
.flavor
))
896 if (s
&& s
->attr
.flavor
== FL_PROCEDURE
)
899 gcc_assert (s
->attr
.generic
);
900 for (intr
= s
->generic
; intr
; intr
= intr
->next
)
901 if (gfc_fl_struct (intr
->sym
->attr
.flavor
))
908 /* Normally we can assume that s is a derived-type symbol since it
909 shares a name with the derived-type sym. However if sym is a
910 STRUCTURE, it may in fact share a name with any other basic type
911 variable. If s is in fact of derived type then we can continue
912 looking for a duplicate type declaration. */
913 if (sym
->attr
.flavor
== FL_STRUCT
&& s
->ts
.type
== BT_DERIVED
)
918 if (gfc_fl_struct (s
->attr
.flavor
) && !s
->backend_decl
)
920 if (s
->attr
.flavor
== FL_UNION
)
921 s
->backend_decl
= gfc_get_union_type (s
);
923 s
->backend_decl
= gfc_get_derived_type (s
);
925 gfc_copy_dt_decls_ifequal (s
, sym
, true);
928 else if (s
->backend_decl
)
930 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
931 gfc_copy_dt_decls_ifequal (s
->ts
.u
.derived
, sym
->ts
.u
.derived
,
933 else if (sym
->ts
.type
== BT_CHARACTER
)
934 sym
->ts
.u
.cl
->backend_decl
= s
->ts
.u
.cl
->backend_decl
;
935 sym
->backend_decl
= s
->backend_decl
;
943 /* Create an array index type variable with function scope. */
946 create_index_var (const char * pfx
, int nest
)
950 decl
= gfc_create_var_np (gfc_array_index_type
, pfx
);
952 gfc_add_decl_to_parent_function (decl
);
954 gfc_add_decl_to_function (decl
);
959 /* Create variables to hold all the non-constant bits of info for a
960 descriptorless array. Remember these in the lang-specific part of the
964 gfc_build_qualified_array (tree decl
, gfc_symbol
* sym
)
969 gfc_namespace
* procns
;
970 symbol_attribute
*array_attr
;
972 bool is_classarray
= IS_CLASS_ARRAY (sym
);
974 type
= TREE_TYPE (decl
);
975 array_attr
= is_classarray
? &CLASS_DATA (sym
)->attr
: &sym
->attr
;
976 as
= is_classarray
? CLASS_DATA (sym
)->as
: sym
->as
;
978 /* We just use the descriptor, if there is one. */
979 if (GFC_DESCRIPTOR_TYPE_P (type
))
982 gcc_assert (GFC_ARRAY_TYPE_P (type
));
983 procns
= gfc_find_proc_namespace (sym
->ns
);
984 nest
= (procns
->proc_name
->backend_decl
!= current_function_decl
)
985 && !sym
->attr
.contained
;
987 if (array_attr
->codimension
&& flag_coarray
== GFC_FCOARRAY_LIB
988 && as
->type
!= AS_ASSUMED_SHAPE
989 && GFC_TYPE_ARRAY_CAF_TOKEN (type
) == NULL_TREE
)
992 tree token_type
= build_qualified_type (pvoid_type_node
,
995 if (sym
->module
&& (sym
->attr
.use_assoc
996 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
))
999 = get_identifier (gfc_get_string (GFC_PREFIX ("caf_token%s"),
1000 IDENTIFIER_POINTER (gfc_sym_mangled_identifier (sym
))));
1001 token
= build_decl (DECL_SOURCE_LOCATION (decl
), VAR_DECL
, token_name
,
1003 if (sym
->attr
.use_assoc
)
1004 DECL_EXTERNAL (token
) = 1;
1006 TREE_STATIC (token
) = 1;
1008 TREE_PUBLIC (token
) = 1;
1010 if (sym
->attr
.access
== ACCESS_PRIVATE
&& !sym
->attr
.public_used
)
1012 DECL_VISIBILITY (token
) = VISIBILITY_HIDDEN
;
1013 DECL_VISIBILITY_SPECIFIED (token
) = true;
1018 token
= gfc_create_var_np (token_type
, "caf_token");
1019 TREE_STATIC (token
) = 1;
1022 GFC_TYPE_ARRAY_CAF_TOKEN (type
) = token
;
1023 DECL_ARTIFICIAL (token
) = 1;
1024 DECL_NONALIASED (token
) = 1;
1026 if (sym
->module
&& !sym
->attr
.use_assoc
)
1029 DECL_CONTEXT (token
) = sym
->ns
->proc_name
->backend_decl
;
1030 gfc_module_add_decl (cur_module
, token
);
1032 else if (sym
->attr
.host_assoc
1033 && TREE_CODE (DECL_CONTEXT (current_function_decl
))
1034 != TRANSLATION_UNIT_DECL
)
1035 gfc_add_decl_to_parent_function (token
);
1037 gfc_add_decl_to_function (token
);
1040 for (dim
= 0; dim
< GFC_TYPE_ARRAY_RANK (type
); dim
++)
1042 if (GFC_TYPE_ARRAY_LBOUND (type
, dim
) == NULL_TREE
)
1044 GFC_TYPE_ARRAY_LBOUND (type
, dim
) = create_index_var ("lbound", nest
);
1045 TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type
, dim
)) = 1;
1047 /* Don't try to use the unknown bound for assumed shape arrays. */
1048 if (GFC_TYPE_ARRAY_UBOUND (type
, dim
) == NULL_TREE
1049 && (as
->type
!= AS_ASSUMED_SIZE
1050 || dim
< GFC_TYPE_ARRAY_RANK (type
) - 1))
1052 GFC_TYPE_ARRAY_UBOUND (type
, dim
) = create_index_var ("ubound", nest
);
1053 TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type
, dim
)) = 1;
1056 if (GFC_TYPE_ARRAY_STRIDE (type
, dim
) == NULL_TREE
)
1058 GFC_TYPE_ARRAY_STRIDE (type
, dim
) = create_index_var ("stride", nest
);
1059 TREE_NO_WARNING (GFC_TYPE_ARRAY_STRIDE (type
, dim
)) = 1;
1062 for (dim
= GFC_TYPE_ARRAY_RANK (type
);
1063 dim
< GFC_TYPE_ARRAY_RANK (type
) + GFC_TYPE_ARRAY_CORANK (type
); dim
++)
1065 if (GFC_TYPE_ARRAY_LBOUND (type
, dim
) == NULL_TREE
)
1067 GFC_TYPE_ARRAY_LBOUND (type
, dim
) = create_index_var ("lbound", nest
);
1068 TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type
, dim
)) = 1;
1070 /* Don't try to use the unknown ubound for the last coarray dimension. */
1071 if (GFC_TYPE_ARRAY_UBOUND (type
, dim
) == NULL_TREE
1072 && dim
< GFC_TYPE_ARRAY_RANK (type
) + GFC_TYPE_ARRAY_CORANK (type
) - 1)
1074 GFC_TYPE_ARRAY_UBOUND (type
, dim
) = create_index_var ("ubound", nest
);
1075 TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type
, dim
)) = 1;
1078 if (GFC_TYPE_ARRAY_OFFSET (type
) == NULL_TREE
)
1080 GFC_TYPE_ARRAY_OFFSET (type
) = gfc_create_var_np (gfc_array_index_type
,
1082 TREE_NO_WARNING (GFC_TYPE_ARRAY_OFFSET (type
)) = 1;
1085 gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type
));
1087 gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type
));
1090 if (GFC_TYPE_ARRAY_SIZE (type
) == NULL_TREE
1091 && as
->type
!= AS_ASSUMED_SIZE
)
1093 GFC_TYPE_ARRAY_SIZE (type
) = create_index_var ("size", nest
);
1094 TREE_NO_WARNING (GFC_TYPE_ARRAY_SIZE (type
)) = 1;
1097 if (POINTER_TYPE_P (type
))
1099 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (type
)));
1100 gcc_assert (TYPE_LANG_SPECIFIC (type
)
1101 == TYPE_LANG_SPECIFIC (TREE_TYPE (type
)));
1102 type
= TREE_TYPE (type
);
1105 if (! COMPLETE_TYPE_P (type
) && GFC_TYPE_ARRAY_SIZE (type
))
1109 size
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
1110 GFC_TYPE_ARRAY_SIZE (type
), gfc_index_one_node
);
1111 range
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
1113 TYPE_DOMAIN (type
) = range
;
1117 if (TYPE_NAME (type
) != NULL_TREE
&& as
->rank
> 0
1118 && GFC_TYPE_ARRAY_UBOUND (type
, as
->rank
- 1) != NULL_TREE
1119 && VAR_P (GFC_TYPE_ARRAY_UBOUND (type
, as
->rank
- 1)))
1121 tree gtype
= DECL_ORIGINAL_TYPE (TYPE_NAME (type
));
1123 for (dim
= 0; dim
< as
->rank
- 1; dim
++)
1125 gcc_assert (TREE_CODE (gtype
) == ARRAY_TYPE
);
1126 gtype
= TREE_TYPE (gtype
);
1128 gcc_assert (TREE_CODE (gtype
) == ARRAY_TYPE
);
1129 if (TYPE_MAX_VALUE (TYPE_DOMAIN (gtype
)) == NULL
)
1130 TYPE_NAME (type
) = NULL_TREE
;
1133 if (TYPE_NAME (type
) == NULL_TREE
)
1135 tree gtype
= TREE_TYPE (type
), rtype
, type_decl
;
1137 for (dim
= as
->rank
- 1; dim
>= 0; dim
--)
1139 tree lbound
, ubound
;
1140 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
1141 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
1142 rtype
= build_range_type (gfc_array_index_type
, lbound
, ubound
);
1143 gtype
= build_array_type (gtype
, rtype
);
1144 /* Ensure the bound variables aren't optimized out at -O0.
1145 For -O1 and above they often will be optimized out, but
1146 can be tracked by VTA. Also set DECL_NAMELESS, so that
1147 the artificial lbound.N or ubound.N DECL_NAME doesn't
1148 end up in debug info. */
1151 && DECL_ARTIFICIAL (lbound
)
1152 && DECL_IGNORED_P (lbound
))
1154 if (DECL_NAME (lbound
)
1155 && strstr (IDENTIFIER_POINTER (DECL_NAME (lbound
)),
1157 DECL_NAMELESS (lbound
) = 1;
1158 DECL_IGNORED_P (lbound
) = 0;
1162 && DECL_ARTIFICIAL (ubound
)
1163 && DECL_IGNORED_P (ubound
))
1165 if (DECL_NAME (ubound
)
1166 && strstr (IDENTIFIER_POINTER (DECL_NAME (ubound
)),
1168 DECL_NAMELESS (ubound
) = 1;
1169 DECL_IGNORED_P (ubound
) = 0;
1172 TYPE_NAME (type
) = type_decl
= build_decl (input_location
,
1173 TYPE_DECL
, NULL
, gtype
);
1174 DECL_ORIGINAL_TYPE (type_decl
) = gtype
;
1179 /* For some dummy arguments we don't use the actual argument directly.
1180 Instead we create a local decl and use that. This allows us to perform
1181 initialization, and construct full type information. */
1184 gfc_build_dummy_array_decl (gfc_symbol
* sym
, tree dummy
)
1189 symbol_attribute
*array_attr
;
1194 bool is_classarray
= IS_CLASS_ARRAY (sym
);
1196 /* Use the array as and attr. */
1197 as
= is_classarray
? CLASS_DATA (sym
)->as
: sym
->as
;
1198 array_attr
= is_classarray
? &CLASS_DATA (sym
)->attr
: &sym
->attr
;
1200 /* The dummy is returned for pointer, allocatable or assumed rank arrays.
1201 For class arrays the information if sym is an allocatable or pointer
1202 object needs to be checked explicitly (IS_CLASS_ARRAY can be false for
1203 too many reasons to be of use here). */
1204 if ((sym
->ts
.type
!= BT_CLASS
&& sym
->attr
.pointer
)
1205 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->attr
.class_pointer
)
1206 || array_attr
->allocatable
1207 || (as
&& as
->type
== AS_ASSUMED_RANK
))
1210 /* Add to list of variables if not a fake result variable.
1211 These symbols are set on the symbol only, not on the class component. */
1212 if (sym
->attr
.result
|| sym
->attr
.dummy
)
1213 gfc_defer_symbol_init (sym
);
1215 /* For a class array the array descriptor is in the _data component, while
1216 for a regular array the TREE_TYPE of the dummy is a pointer to the
1218 type
= TREE_TYPE (is_classarray
? gfc_class_data_get (dummy
)
1219 : TREE_TYPE (dummy
));
1220 /* type now is the array descriptor w/o any indirection. */
1221 gcc_assert (TREE_CODE (dummy
) == PARM_DECL
1222 && POINTER_TYPE_P (TREE_TYPE (dummy
)));
1224 /* Do we know the element size? */
1225 known_size
= sym
->ts
.type
!= BT_CHARACTER
1226 || INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
);
1228 if (known_size
&& !GFC_DESCRIPTOR_TYPE_P (type
))
1230 /* For descriptorless arrays with known element size the actual
1231 argument is sufficient. */
1232 gfc_build_qualified_array (dummy
, sym
);
1236 if (GFC_DESCRIPTOR_TYPE_P (type
))
1238 /* Create a descriptorless array pointer. */
1241 /* Even when -frepack-arrays is used, symbols with TARGET attribute
1242 are not repacked. */
1243 if (!flag_repack_arrays
|| sym
->attr
.target
)
1245 if (as
->type
== AS_ASSUMED_SIZE
)
1246 packed
= PACKED_FULL
;
1250 if (as
->type
== AS_EXPLICIT
)
1252 packed
= PACKED_FULL
;
1253 for (n
= 0; n
< as
->rank
; n
++)
1257 && as
->upper
[n
]->expr_type
== EXPR_CONSTANT
1258 && as
->lower
[n
]->expr_type
== EXPR_CONSTANT
))
1260 packed
= PACKED_PARTIAL
;
1266 packed
= PACKED_PARTIAL
;
1269 /* For classarrays the element type is required, but
1270 gfc_typenode_for_spec () returns the array descriptor. */
1271 type
= is_classarray
? gfc_get_element_type (type
)
1272 : gfc_typenode_for_spec (&sym
->ts
);
1273 type
= gfc_get_nodesc_array_type (type
, as
, packed
,
1278 /* We now have an expression for the element size, so create a fully
1279 qualified type. Reset sym->backend decl or this will just return the
1281 DECL_ARTIFICIAL (sym
->backend_decl
) = 1;
1282 sym
->backend_decl
= NULL_TREE
;
1283 type
= gfc_sym_type (sym
);
1284 packed
= PACKED_FULL
;
1287 ASM_FORMAT_PRIVATE_NAME (name
, IDENTIFIER_POINTER (DECL_NAME (dummy
)), 0);
1288 decl
= build_decl (input_location
,
1289 VAR_DECL
, get_identifier (name
), type
);
1291 DECL_ARTIFICIAL (decl
) = 1;
1292 DECL_NAMELESS (decl
) = 1;
1293 TREE_PUBLIC (decl
) = 0;
1294 TREE_STATIC (decl
) = 0;
1295 DECL_EXTERNAL (decl
) = 0;
1297 /* Avoid uninitialized warnings for optional dummy arguments. */
1298 if (sym
->attr
.optional
)
1299 TREE_NO_WARNING (decl
) = 1;
1301 /* We should never get deferred shape arrays here. We used to because of
1303 gcc_assert (as
->type
!= AS_DEFERRED
);
1305 if (packed
== PACKED_PARTIAL
)
1306 GFC_DECL_PARTIAL_PACKED_ARRAY (decl
) = 1;
1307 else if (packed
== PACKED_FULL
)
1308 GFC_DECL_PACKED_ARRAY (decl
) = 1;
1310 gfc_build_qualified_array (decl
, sym
);
1312 if (DECL_LANG_SPECIFIC (dummy
))
1313 DECL_LANG_SPECIFIC (decl
) = DECL_LANG_SPECIFIC (dummy
);
1315 gfc_allocate_lang_decl (decl
);
1317 GFC_DECL_SAVED_DESCRIPTOR (decl
) = dummy
;
1319 if (sym
->ns
->proc_name
->backend_decl
== current_function_decl
1320 || sym
->attr
.contained
)
1321 gfc_add_decl_to_function (decl
);
1323 gfc_add_decl_to_parent_function (decl
);
1328 /* Return a constant or a variable to use as a string length. Does not
1329 add the decl to the current scope. */
1332 gfc_create_string_length (gfc_symbol
* sym
)
1334 gcc_assert (sym
->ts
.u
.cl
);
1335 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
1337 if (sym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
1342 /* The string length variable shall be in static memory if it is either
1343 explicitly SAVED, a module variable or with -fno-automatic. Only
1344 relevant is "len=:" - otherwise, it is either a constant length or
1345 it is an automatic variable. */
1346 bool static_length
= sym
->attr
.save
1347 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
1348 || (flag_max_stack_var_size
== 0
1349 && sym
->ts
.deferred
&& !sym
->attr
.dummy
1350 && !sym
->attr
.result
&& !sym
->attr
.function
);
1352 /* Also prefix the mangled name. We need to call GFC_PREFIX for static
1353 variables as some systems do not support the "." in the assembler name.
1354 For nonstatic variables, the "." does not appear in assembler. */
1358 name
= gfc_get_string (GFC_PREFIX ("%s_MOD_%s"), sym
->module
,
1361 name
= gfc_get_string (GFC_PREFIX ("%s"), sym
->name
);
1363 else if (sym
->module
)
1364 name
= gfc_get_string (".__%s_MOD_%s", sym
->module
, sym
->name
);
1366 name
= gfc_get_string (".%s", sym
->name
);
1368 length
= build_decl (input_location
,
1369 VAR_DECL
, get_identifier (name
),
1370 gfc_charlen_type_node
);
1371 DECL_ARTIFICIAL (length
) = 1;
1372 TREE_USED (length
) = 1;
1373 if (sym
->ns
->proc_name
->tlink
!= NULL
)
1374 gfc_defer_symbol_init (sym
);
1376 sym
->ts
.u
.cl
->backend_decl
= length
;
1379 TREE_STATIC (length
) = 1;
1381 if (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
1382 && (sym
->attr
.access
!= ACCESS_PRIVATE
|| sym
->attr
.public_used
))
1383 TREE_PUBLIC (length
) = 1;
1386 gcc_assert (sym
->ts
.u
.cl
->backend_decl
!= NULL_TREE
);
1387 return sym
->ts
.u
.cl
->backend_decl
;
1390 /* If a variable is assigned a label, we add another two auxiliary
1394 gfc_add_assign_aux_vars (gfc_symbol
* sym
)
1400 gcc_assert (sym
->backend_decl
);
1402 decl
= sym
->backend_decl
;
1403 gfc_allocate_lang_decl (decl
);
1404 GFC_DECL_ASSIGN (decl
) = 1;
1405 length
= build_decl (input_location
,
1406 VAR_DECL
, create_tmp_var_name (sym
->name
),
1407 gfc_charlen_type_node
);
1408 addr
= build_decl (input_location
,
1409 VAR_DECL
, create_tmp_var_name (sym
->name
),
1411 gfc_finish_var_decl (length
, sym
);
1412 gfc_finish_var_decl (addr
, sym
);
1413 /* STRING_LENGTH is also used as flag. Less than -1 means that
1414 ASSIGN_ADDR cannot be used. Equal -1 means that ASSIGN_ADDR is the
1415 target label's address. Otherwise, value is the length of a format string
1416 and ASSIGN_ADDR is its address. */
1417 if (TREE_STATIC (length
))
1418 DECL_INITIAL (length
) = build_int_cst (gfc_charlen_type_node
, -2);
1420 gfc_defer_symbol_init (sym
);
1422 GFC_DECL_STRING_LEN (decl
) = length
;
1423 GFC_DECL_ASSIGN_ADDR (decl
) = addr
;
1428 add_attributes_to_decl (symbol_attribute sym_attr
, tree list
)
1433 for (id
= 0; id
< EXT_ATTR_NUM
; id
++)
1434 if (sym_attr
.ext_attr
& (1 << id
))
1436 attr
= build_tree_list (
1437 get_identifier (ext_attr_list
[id
].middle_end_name
),
1439 list
= chainon (list
, attr
);
1442 tree clauses
= NULL_TREE
;
1444 if (sym_attr
.oacc_routine_lop
!= OACC_ROUTINE_LOP_NONE
)
1446 omp_clause_code code
;
1447 switch (sym_attr
.oacc_routine_lop
)
1449 case OACC_ROUTINE_LOP_GANG
:
1450 code
= OMP_CLAUSE_GANG
;
1452 case OACC_ROUTINE_LOP_WORKER
:
1453 code
= OMP_CLAUSE_WORKER
;
1455 case OACC_ROUTINE_LOP_VECTOR
:
1456 code
= OMP_CLAUSE_VECTOR
;
1458 case OACC_ROUTINE_LOP_SEQ
:
1459 code
= OMP_CLAUSE_SEQ
;
1461 case OACC_ROUTINE_LOP_NONE
:
1462 case OACC_ROUTINE_LOP_ERROR
:
1466 tree c
= build_omp_clause (UNKNOWN_LOCATION
, code
);
1467 OMP_CLAUSE_CHAIN (c
) = clauses
;
1470 tree dims
= oacc_build_routine_dims (clauses
);
1471 list
= oacc_replace_fn_attrib_attr (list
, dims
);
1474 if (sym_attr
.omp_declare_target_link
1475 || sym_attr
.oacc_declare_link
)
1476 list
= tree_cons (get_identifier ("omp declare target link"),
1478 else if (sym_attr
.omp_declare_target
1479 || sym_attr
.oacc_declare_create
1480 || sym_attr
.oacc_declare_copyin
1481 || sym_attr
.oacc_declare_deviceptr
1482 || sym_attr
.oacc_declare_device_resident
)
1483 list
= tree_cons (get_identifier ("omp declare target"),
1490 static void build_function_decl (gfc_symbol
* sym
, bool global
);
1493 /* Return the decl for a gfc_symbol, create it if it doesn't already
1497 gfc_get_symbol_decl (gfc_symbol
* sym
)
1500 tree length
= NULL_TREE
;
1503 bool intrinsic_array_parameter
= false;
1506 gcc_assert (sym
->attr
.referenced
1507 || sym
->attr
.flavor
== FL_PROCEDURE
1508 || sym
->attr
.use_assoc
1509 || sym
->attr
.used_in_submodule
1510 || sym
->ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
1511 || (sym
->module
&& sym
->attr
.if_source
!= IFSRC_DECL
1512 && sym
->backend_decl
));
1514 if (sym
->ns
&& sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.function
)
1515 byref
= gfc_return_by_reference (sym
->ns
->proc_name
);
1519 /* Make sure that the vtab for the declared type is completed. */
1520 if (sym
->ts
.type
== BT_CLASS
)
1522 gfc_component
*c
= CLASS_DATA (sym
);
1523 if (!c
->ts
.u
.derived
->backend_decl
)
1525 gfc_find_derived_vtab (c
->ts
.u
.derived
);
1526 gfc_get_derived_type (sym
->ts
.u
.derived
);
1530 /* PDT parameterized array components and string_lengths must have the
1531 'len' parameters substituted for the expressions appearing in the
1532 declaration of the entity and memory allocated/deallocated. */
1533 if ((sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
1534 && sym
->param_list
!= NULL
1535 && !(sym
->attr
.host_assoc
|| sym
->attr
.use_assoc
|| sym
->attr
.dummy
))
1536 gfc_defer_symbol_init (sym
);
1538 /* Dummy PDT 'len' parameters should be checked when they are explicit. */
1539 if ((sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
1540 && (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1541 && sym
->param_list
!= NULL
1543 gfc_defer_symbol_init (sym
);
1545 /* All deferred character length procedures need to retain the backend
1546 decl, which is a pointer to the character length in the caller's
1547 namespace and to declare a local character length. */
1548 if (!byref
&& sym
->attr
.function
1549 && sym
->ts
.type
== BT_CHARACTER
1551 && sym
->ts
.u
.cl
->passed_length
== NULL
1552 && sym
->ts
.u
.cl
->backend_decl
1553 && TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) == PARM_DECL
)
1555 sym
->ts
.u
.cl
->passed_length
= sym
->ts
.u
.cl
->backend_decl
;
1556 gcc_assert (POINTER_TYPE_P (TREE_TYPE (sym
->ts
.u
.cl
->passed_length
)));
1557 sym
->ts
.u
.cl
->backend_decl
= build_fold_indirect_ref (sym
->ts
.u
.cl
->backend_decl
);
1560 fun_or_res
= byref
&& (sym
->attr
.result
1561 || (sym
->attr
.function
&& sym
->ts
.deferred
));
1562 if ((sym
->attr
.dummy
&& ! sym
->attr
.function
) || fun_or_res
)
1564 /* Return via extra parameter. */
1565 if (sym
->attr
.result
&& byref
1566 && !sym
->backend_decl
)
1569 DECL_ARGUMENTS (sym
->ns
->proc_name
->backend_decl
);
1570 /* For entry master function skip over the __entry
1572 if (sym
->ns
->proc_name
->attr
.entry_master
)
1573 sym
->backend_decl
= DECL_CHAIN (sym
->backend_decl
);
1576 /* Dummy variables should already have been created. */
1577 gcc_assert (sym
->backend_decl
);
1579 /* However, the string length of deferred arrays must be set. */
1580 if (sym
->ts
.type
== BT_CHARACTER
1582 && sym
->attr
.dimension
1583 && sym
->attr
.allocatable
)
1584 gfc_defer_symbol_init (sym
);
1586 if (sym
->attr
.pointer
&& sym
->attr
.dimension
&& sym
->ts
.type
!= BT_CLASS
)
1587 GFC_DECL_PTR_ARRAY_P (sym
->backend_decl
) = 1;
1589 /* Create a character length variable. */
1590 if (sym
->ts
.type
== BT_CHARACTER
)
1592 /* For a deferred dummy, make a new string length variable. */
1593 if (sym
->ts
.deferred
1595 (sym
->ts
.u
.cl
->passed_length
== sym
->ts
.u
.cl
->backend_decl
))
1596 sym
->ts
.u
.cl
->backend_decl
= NULL_TREE
;
1598 if (sym
->ts
.deferred
&& byref
)
1600 /* The string length of a deferred char array is stored in the
1601 parameter at sym->ts.u.cl->backend_decl as a reference and
1602 marked as a result. Exempt this variable from generating a
1603 temporary for it. */
1604 if (sym
->attr
.result
)
1606 /* We need to insert a indirect ref for param decls. */
1607 if (sym
->ts
.u
.cl
->backend_decl
1608 && TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) == PARM_DECL
)
1610 sym
->ts
.u
.cl
->passed_length
= sym
->ts
.u
.cl
->backend_decl
;
1611 sym
->ts
.u
.cl
->backend_decl
=
1612 build_fold_indirect_ref (sym
->ts
.u
.cl
->backend_decl
);
1615 /* For all other parameters make sure, that they are copied so
1616 that the value and any modifications are local to the routine
1617 by generating a temporary variable. */
1618 else if (sym
->attr
.function
1619 && sym
->ts
.u
.cl
->passed_length
== NULL
1620 && sym
->ts
.u
.cl
->backend_decl
)
1622 sym
->ts
.u
.cl
->passed_length
= sym
->ts
.u
.cl
->backend_decl
;
1623 if (POINTER_TYPE_P (TREE_TYPE (sym
->ts
.u
.cl
->passed_length
)))
1624 sym
->ts
.u
.cl
->backend_decl
1625 = build_fold_indirect_ref (sym
->ts
.u
.cl
->backend_decl
);
1627 sym
->ts
.u
.cl
->backend_decl
= NULL_TREE
;
1631 if (sym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
1632 length
= gfc_create_string_length (sym
);
1634 length
= sym
->ts
.u
.cl
->backend_decl
;
1635 if (VAR_P (length
) && DECL_FILE_SCOPE_P (length
))
1637 /* Add the string length to the same context as the symbol. */
1638 if (DECL_CONTEXT (length
) == NULL_TREE
)
1640 if (DECL_CONTEXT (sym
->backend_decl
)
1641 == current_function_decl
)
1642 gfc_add_decl_to_function (length
);
1644 gfc_add_decl_to_parent_function (length
);
1647 gcc_assert (DECL_CONTEXT (sym
->backend_decl
)
1648 == DECL_CONTEXT (length
));
1650 gfc_defer_symbol_init (sym
);
1654 /* Use a copy of the descriptor for dummy arrays. */
1655 if ((sym
->attr
.dimension
|| sym
->attr
.codimension
)
1656 && !TREE_USED (sym
->backend_decl
))
1658 decl
= gfc_build_dummy_array_decl (sym
, sym
->backend_decl
);
1659 /* Prevent the dummy from being detected as unused if it is copied. */
1660 if (sym
->backend_decl
!= NULL
&& decl
!= sym
->backend_decl
)
1661 DECL_ARTIFICIAL (sym
->backend_decl
) = 1;
1662 sym
->backend_decl
= decl
;
1665 /* Returning the descriptor for dummy class arrays is hazardous, because
1666 some caller is expecting an expression to apply the component refs to.
1667 Therefore the descriptor is only created and stored in
1668 sym->backend_decl's GFC_DECL_SAVED_DESCRIPTOR. The caller is then
1669 responsible to extract it from there, when the descriptor is
1671 if (IS_CLASS_ARRAY (sym
)
1672 && (!DECL_LANG_SPECIFIC (sym
->backend_decl
)
1673 || !GFC_DECL_SAVED_DESCRIPTOR (sym
->backend_decl
)))
1675 decl
= gfc_build_dummy_array_decl (sym
, sym
->backend_decl
);
1676 /* Prevent the dummy from being detected as unused if it is copied. */
1677 if (sym
->backend_decl
!= NULL
&& decl
!= sym
->backend_decl
)
1678 DECL_ARTIFICIAL (sym
->backend_decl
) = 1;
1679 sym
->backend_decl
= decl
;
1682 TREE_USED (sym
->backend_decl
) = 1;
1683 if (sym
->attr
.assign
&& GFC_DECL_ASSIGN (sym
->backend_decl
) == 0)
1685 gfc_add_assign_aux_vars (sym
);
1688 if (sym
->ts
.type
== BT_CLASS
&& sym
->backend_decl
)
1689 GFC_DECL_CLASS(sym
->backend_decl
) = 1;
1691 return sym
->backend_decl
;
1694 if (sym
->backend_decl
)
1695 return sym
->backend_decl
;
1697 /* Special case for array-valued named constants from intrinsic
1698 procedures; those are inlined. */
1699 if (sym
->attr
.use_assoc
&& sym
->attr
.flavor
== FL_PARAMETER
1700 && (sym
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
1701 || sym
->from_intmod
== INTMOD_ISO_C_BINDING
))
1702 intrinsic_array_parameter
= true;
1704 /* If use associated compilation, use the module
1706 if ((sym
->attr
.flavor
== FL_VARIABLE
1707 || sym
->attr
.flavor
== FL_PARAMETER
)
1708 && (sym
->attr
.use_assoc
|| sym
->attr
.used_in_submodule
)
1709 && !intrinsic_array_parameter
1711 && gfc_get_module_backend_decl (sym
))
1713 if (sym
->ts
.type
== BT_CLASS
&& sym
->backend_decl
)
1714 GFC_DECL_CLASS(sym
->backend_decl
) = 1;
1715 return sym
->backend_decl
;
1718 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1720 /* Catch functions. Only used for actual parameters,
1721 procedure pointers and procptr initialization targets. */
1722 if (sym
->attr
.use_assoc
1723 || sym
->attr
.used_in_submodule
1724 || sym
->attr
.intrinsic
1725 || sym
->attr
.if_source
!= IFSRC_DECL
)
1727 decl
= gfc_get_extern_function_decl (sym
);
1728 gfc_set_decl_location (decl
, &sym
->declared_at
);
1732 if (!sym
->backend_decl
)
1733 build_function_decl (sym
, false);
1734 decl
= sym
->backend_decl
;
1739 if (sym
->attr
.intrinsic
)
1740 gfc_internal_error ("intrinsic variable which isn't a procedure");
1742 /* Create string length decl first so that they can be used in the
1743 type declaration. For associate names, the target character
1744 length is used. Set 'length' to a constant so that if the
1745 string length is a variable, it is not finished a second time. */
1746 if (sym
->ts
.type
== BT_CHARACTER
)
1748 if (sym
->attr
.associate_var
1750 && sym
->assoc
&& sym
->assoc
->target
1751 && ((sym
->assoc
->target
->expr_type
== EXPR_VARIABLE
1752 && sym
->assoc
->target
->symtree
->n
.sym
->ts
.type
!= BT_CHARACTER
)
1753 || sym
->assoc
->target
->expr_type
!= EXPR_VARIABLE
))
1754 sym
->ts
.u
.cl
->backend_decl
= NULL_TREE
;
1756 if (sym
->attr
.associate_var
1757 && sym
->ts
.u
.cl
->backend_decl
1758 && (VAR_P (sym
->ts
.u
.cl
->backend_decl
)
1759 || TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) == PARM_DECL
))
1760 length
= gfc_index_zero_node
;
1762 length
= gfc_create_string_length (sym
);
1765 /* Create the decl for the variable. */
1766 decl
= build_decl (sym
->declared_at
.lb
->location
,
1767 VAR_DECL
, gfc_sym_identifier (sym
), gfc_sym_type (sym
));
1769 /* Add attributes to variables. Functions are handled elsewhere. */
1770 attributes
= add_attributes_to_decl (sym
->attr
, NULL_TREE
);
1771 decl_attributes (&decl
, attributes
, 0);
1773 /* Symbols from modules should have their assembler names mangled.
1774 This is done here rather than in gfc_finish_var_decl because it
1775 is different for string length variables. */
1776 if (sym
->module
|| sym
->fn_result_spec
)
1778 gfc_set_decl_assembler_name (decl
, gfc_sym_mangled_identifier (sym
));
1779 if (sym
->attr
.use_assoc
&& !intrinsic_array_parameter
)
1780 DECL_IGNORED_P (decl
) = 1;
1783 if (sym
->attr
.select_type_temporary
)
1785 DECL_ARTIFICIAL (decl
) = 1;
1786 DECL_IGNORED_P (decl
) = 1;
1789 if (sym
->attr
.dimension
|| sym
->attr
.codimension
)
1791 /* Create variables to hold the non-constant bits of array info. */
1792 gfc_build_qualified_array (decl
, sym
);
1794 if (sym
->attr
.contiguous
1795 || ((sym
->attr
.allocatable
|| !sym
->attr
.dummy
) && !sym
->attr
.pointer
))
1796 GFC_DECL_PACKED_ARRAY (decl
) = 1;
1799 /* Remember this variable for allocation/cleanup. */
1800 if (sym
->attr
.dimension
|| sym
->attr
.allocatable
|| sym
->attr
.codimension
1801 || (sym
->ts
.type
== BT_CLASS
&&
1802 (CLASS_DATA (sym
)->attr
.dimension
1803 || CLASS_DATA (sym
)->attr
.allocatable
))
1804 || (sym
->ts
.type
== BT_DERIVED
1805 && (sym
->ts
.u
.derived
->attr
.alloc_comp
1806 || (!sym
->attr
.pointer
&& !sym
->attr
.artificial
&& !sym
->attr
.save
1807 && !sym
->ns
->proc_name
->attr
.is_main_program
1808 && gfc_is_finalizable (sym
->ts
.u
.derived
, NULL
))))
1809 /* This applies a derived type default initializer. */
1810 || (sym
->ts
.type
== BT_DERIVED
1811 && sym
->attr
.save
== SAVE_NONE
1813 && !sym
->attr
.allocatable
1814 && (sym
->value
&& !sym
->ns
->proc_name
->attr
.is_main_program
)
1815 && !(sym
->attr
.use_assoc
&& !intrinsic_array_parameter
)))
1816 gfc_defer_symbol_init (sym
);
1818 if (sym
->ts
.type
== BT_CHARACTER
1819 && sym
->attr
.allocatable
1820 && !sym
->attr
.dimension
1821 && sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
1822 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_VARIABLE
)
1823 gfc_defer_symbol_init (sym
);
1825 /* Associate names can use the hidden string length variable
1826 of their associated target. */
1827 if (sym
->ts
.type
== BT_CHARACTER
1828 && TREE_CODE (length
) != INTEGER_CST
1829 && TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) != INDIRECT_REF
)
1831 length
= fold_convert (gfc_charlen_type_node
, length
);
1832 gfc_finish_var_decl (length
, sym
);
1833 if (!sym
->attr
.associate_var
1834 && TREE_CODE (length
) == VAR_DECL
1835 && sym
->value
&& sym
->value
->expr_type
!= EXPR_NULL
1836 && sym
->value
->ts
.u
.cl
->length
)
1838 gfc_expr
*len
= sym
->value
->ts
.u
.cl
->length
;
1839 DECL_INITIAL (length
) = gfc_conv_initializer (len
, &len
->ts
,
1841 false, false, false);
1842 DECL_INITIAL (length
) = fold_convert (gfc_charlen_type_node
,
1843 DECL_INITIAL (length
));
1846 gcc_assert (!sym
->value
|| sym
->value
->expr_type
== EXPR_NULL
);
1849 gfc_finish_var_decl (decl
, sym
);
1851 if (sym
->ts
.type
== BT_CHARACTER
)
1852 /* Character variables need special handling. */
1853 gfc_allocate_lang_decl (decl
);
1855 if (sym
->assoc
&& sym
->attr
.subref_array_pointer
)
1856 sym
->attr
.pointer
= 1;
1858 if (sym
->attr
.pointer
&& sym
->attr
.dimension
1859 && !sym
->ts
.deferred
1860 && !(sym
->attr
.select_type_temporary
1861 && !sym
->attr
.subref_array_pointer
))
1862 GFC_DECL_PTR_ARRAY_P (decl
) = 1;
1864 if (sym
->ts
.type
== BT_CLASS
)
1865 GFC_DECL_CLASS(decl
) = 1;
1867 sym
->backend_decl
= decl
;
1869 if (sym
->attr
.assign
)
1870 gfc_add_assign_aux_vars (sym
);
1872 if (intrinsic_array_parameter
)
1874 TREE_STATIC (decl
) = 1;
1875 DECL_EXTERNAL (decl
) = 0;
1878 if (TREE_STATIC (decl
)
1879 && !(sym
->attr
.use_assoc
&& !intrinsic_array_parameter
)
1880 && (sym
->attr
.save
|| sym
->ns
->proc_name
->attr
.is_main_program
1881 || !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl
))
1882 || sym
->attr
.data
|| sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
1883 && (flag_coarray
!= GFC_FCOARRAY_LIB
1884 || !sym
->attr
.codimension
|| sym
->attr
.allocatable
)
1885 && !(sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.pdt_type
)
1886 && !(sym
->ts
.type
== BT_CLASS
1887 && CLASS_DATA (sym
)->ts
.u
.derived
->attr
.pdt_type
))
1889 /* Add static initializer. For procedures, it is only needed if
1890 SAVE is specified otherwise they need to be reinitialized
1891 every time the procedure is entered. The TREE_STATIC is
1892 in this case due to -fmax-stack-var-size=. */
1894 DECL_INITIAL (decl
) = gfc_conv_initializer (sym
->value
, &sym
->ts
,
1895 TREE_TYPE (decl
), sym
->attr
.dimension
1896 || (sym
->attr
.codimension
1897 && sym
->attr
.allocatable
),
1898 sym
->attr
.pointer
|| sym
->attr
.allocatable
1899 || sym
->ts
.type
== BT_CLASS
,
1900 sym
->attr
.proc_pointer
);
1903 if (!TREE_STATIC (decl
)
1904 && POINTER_TYPE_P (TREE_TYPE (decl
))
1905 && !sym
->attr
.pointer
1906 && !sym
->attr
.allocatable
1907 && !sym
->attr
.proc_pointer
1908 && !sym
->attr
.select_type_temporary
)
1909 DECL_BY_REFERENCE (decl
) = 1;
1911 if (sym
->attr
.associate_var
)
1912 GFC_DECL_ASSOCIATE_VAR_P (decl
) = 1;
1914 /* We no longer mark __def_init as read-only so it does not take up
1915 space in the read-only section and dan go into the BSS instead,
1916 see PR 84487. Marking this as artificial means that OpenMP will
1917 treat this as predetermined shared. */
1919 || (sym
->name
[0] == '_' && gfc_str_startswith (sym
->name
, "__def_init")))
1920 DECL_ARTIFICIAL (decl
) = 1;
1926 /* Substitute a temporary variable in place of the real one. */
1929 gfc_shadow_sym (gfc_symbol
* sym
, tree decl
, gfc_saved_var
* save
)
1931 save
->attr
= sym
->attr
;
1932 save
->decl
= sym
->backend_decl
;
1934 gfc_clear_attr (&sym
->attr
);
1935 sym
->attr
.referenced
= 1;
1936 sym
->attr
.flavor
= FL_VARIABLE
;
1938 sym
->backend_decl
= decl
;
1942 /* Restore the original variable. */
1945 gfc_restore_sym (gfc_symbol
* sym
, gfc_saved_var
* save
)
1947 sym
->attr
= save
->attr
;
1948 sym
->backend_decl
= save
->decl
;
1952 /* Declare a procedure pointer. */
1955 get_proc_pointer_decl (gfc_symbol
*sym
)
1960 if (sym
->module
|| sym
->fn_result_spec
)
1965 name
= mangled_identifier (sym
);
1966 gsym
= gfc_find_gsymbol (gfc_gsym_root
, name
);
1970 gfc_find_symbol (sym
->name
, gsym
->ns
, 0, &s
);
1971 if (s
&& s
->backend_decl
)
1972 return s
->backend_decl
;
1976 decl
= sym
->backend_decl
;
1980 decl
= build_decl (input_location
,
1981 VAR_DECL
, get_identifier (sym
->name
),
1982 build_pointer_type (gfc_get_function_type (sym
)));
1986 /* Apply name mangling. */
1987 gfc_set_decl_assembler_name (decl
, gfc_sym_mangled_identifier (sym
));
1988 if (sym
->attr
.use_assoc
)
1989 DECL_IGNORED_P (decl
) = 1;
1992 if ((sym
->ns
->proc_name
1993 && sym
->ns
->proc_name
->backend_decl
== current_function_decl
)
1994 || sym
->attr
.contained
)
1995 gfc_add_decl_to_function (decl
);
1996 else if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
1997 gfc_add_decl_to_parent_function (decl
);
1999 sym
->backend_decl
= decl
;
2001 /* If a variable is USE associated, it's always external. */
2002 if (sym
->attr
.use_assoc
)
2004 DECL_EXTERNAL (decl
) = 1;
2005 TREE_PUBLIC (decl
) = 1;
2007 else if (sym
->module
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2009 /* This is the declaration of a module variable. */
2010 TREE_PUBLIC (decl
) = 1;
2011 if (sym
->attr
.access
== ACCESS_PRIVATE
&& !sym
->attr
.public_used
)
2013 DECL_VISIBILITY (decl
) = VISIBILITY_HIDDEN
;
2014 DECL_VISIBILITY_SPECIFIED (decl
) = true;
2016 TREE_STATIC (decl
) = 1;
2019 if (!sym
->attr
.use_assoc
2020 && (sym
->attr
.save
!= SAVE_NONE
|| sym
->attr
.data
2021 || (sym
->value
&& sym
->ns
->proc_name
->attr
.is_main_program
)))
2022 TREE_STATIC (decl
) = 1;
2024 if (TREE_STATIC (decl
) && sym
->value
)
2026 /* Add static initializer. */
2027 DECL_INITIAL (decl
) = gfc_conv_initializer (sym
->value
, &sym
->ts
,
2029 sym
->attr
.dimension
,
2033 /* Handle threadprivate procedure pointers. */
2034 if (sym
->attr
.threadprivate
2035 && (TREE_STATIC (decl
) || DECL_EXTERNAL (decl
)))
2036 set_decl_tls_model (decl
, decl_default_tls_model (decl
));
2038 attributes
= add_attributes_to_decl (sym
->attr
, NULL_TREE
);
2039 decl_attributes (&decl
, attributes
, 0);
2045 /* Get a basic decl for an external function. */
2048 gfc_get_extern_function_decl (gfc_symbol
* sym
, gfc_actual_arglist
*actual_args
)
2054 gfc_intrinsic_sym
*isym
;
2056 char s
[GFC_MAX_SYMBOL_LEN
+ 23]; /* "_gfortran_f2c_specific" and '\0'. */
2061 if (sym
->backend_decl
)
2062 return sym
->backend_decl
;
2064 /* We should never be creating external decls for alternate entry points.
2065 The procedure may be an alternate entry point, but we don't want/need
2067 gcc_assert (!(sym
->attr
.entry
|| sym
->attr
.entry_master
));
2069 if (sym
->attr
.proc_pointer
)
2070 return get_proc_pointer_decl (sym
);
2072 /* See if this is an external procedure from the same file. If so,
2073 return the backend_decl. If we are looking at a BIND(C)
2074 procedure and the symbol is not BIND(C), or vice versa, we
2075 haven't found the right procedure. */
2077 if (sym
->binding_label
)
2079 gsym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->binding_label
);
2080 if (gsym
&& !gsym
->bind_c
)
2085 gsym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->name
);
2086 if (gsym
&& gsym
->bind_c
)
2090 if (gsym
&& !gsym
->defined
)
2093 /* This can happen because of C binding. */
2094 if (gsym
&& gsym
->ns
&& gsym
->ns
->proc_name
2095 && gsym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2098 if ((!sym
->attr
.use_assoc
|| sym
->attr
.if_source
!= IFSRC_DECL
)
2099 && !sym
->backend_decl
2101 && ((gsym
->type
== GSYM_SUBROUTINE
) || (gsym
->type
== GSYM_FUNCTION
))
2102 && (gsym
->ns
->proc_name
->backend_decl
|| !sym
->attr
.intrinsic
))
2104 if (!gsym
->ns
->proc_name
->backend_decl
)
2106 /* By construction, the external function cannot be
2107 a contained procedure. */
2110 gfc_save_backend_locus (&old_loc
);
2113 gfc_create_function_decl (gsym
->ns
, true);
2116 gfc_restore_backend_locus (&old_loc
);
2119 /* If the namespace has entries, the proc_name is the
2120 entry master. Find the entry and use its backend_decl.
2121 otherwise, use the proc_name backend_decl. */
2122 if (gsym
->ns
->entries
)
2124 gfc_entry_list
*entry
= gsym
->ns
->entries
;
2126 for (; entry
; entry
= entry
->next
)
2128 if (strcmp (gsym
->name
, entry
->sym
->name
) == 0)
2130 sym
->backend_decl
= entry
->sym
->backend_decl
;
2136 sym
->backend_decl
= gsym
->ns
->proc_name
->backend_decl
;
2138 if (sym
->backend_decl
)
2140 /* Avoid problems of double deallocation of the backend declaration
2141 later in gfc_trans_use_stmts; cf. PR 45087. */
2142 if (sym
->attr
.if_source
!= IFSRC_DECL
&& sym
->attr
.use_assoc
)
2143 sym
->attr
.use_assoc
= 0;
2145 return sym
->backend_decl
;
2149 /* See if this is a module procedure from the same file. If so,
2150 return the backend_decl. */
2152 gsym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->module
);
2155 if (gsym
&& gsym
->ns
2156 && (gsym
->type
== GSYM_MODULE
2157 || (gsym
->ns
->proc_name
&& gsym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)))
2162 if (gsym
->type
== GSYM_MODULE
)
2163 gfc_find_symbol (sym
->name
, gsym
->ns
, 0, &s
);
2165 gfc_find_symbol (gsym
->sym_name
, gsym
->ns
, 0, &s
);
2167 if (s
&& s
->backend_decl
)
2169 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
2170 gfc_copy_dt_decls_ifequal (s
->ts
.u
.derived
, sym
->ts
.u
.derived
,
2172 else if (sym
->ts
.type
== BT_CHARACTER
)
2173 sym
->ts
.u
.cl
->backend_decl
= s
->ts
.u
.cl
->backend_decl
;
2174 sym
->backend_decl
= s
->backend_decl
;
2175 return sym
->backend_decl
;
2179 if (sym
->attr
.intrinsic
)
2181 /* Call the resolution function to get the actual name. This is
2182 a nasty hack which relies on the resolution functions only looking
2183 at the first argument. We pass NULL for the second argument
2184 otherwise things like AINT get confused. */
2185 isym
= gfc_find_function (sym
->name
);
2186 gcc_assert (isym
->resolve
.f0
!= NULL
);
2188 memset (&e
, 0, sizeof (e
));
2189 e
.expr_type
= EXPR_FUNCTION
;
2191 memset (&argexpr
, 0, sizeof (argexpr
));
2192 gcc_assert (isym
->formal
);
2193 argexpr
.ts
= isym
->formal
->ts
;
2195 if (isym
->formal
->next
== NULL
)
2196 isym
->resolve
.f1 (&e
, &argexpr
);
2199 if (isym
->formal
->next
->next
== NULL
)
2200 isym
->resolve
.f2 (&e
, &argexpr
, NULL
);
2203 if (isym
->formal
->next
->next
->next
== NULL
)
2204 isym
->resolve
.f3 (&e
, &argexpr
, NULL
, NULL
);
2207 /* All specific intrinsics take less than 5 arguments. */
2208 gcc_assert (isym
->formal
->next
->next
->next
->next
== NULL
);
2209 isym
->resolve
.f4 (&e
, &argexpr
, NULL
, NULL
, NULL
);
2215 && ((e
.ts
.type
== BT_REAL
&& e
.ts
.kind
== gfc_default_real_kind
)
2216 || e
.ts
.type
== BT_COMPLEX
))
2218 /* Specific which needs a different implementation if f2c
2219 calling conventions are used. */
2220 sprintf (s
, "_gfortran_f2c_specific%s", e
.value
.function
.name
);
2223 sprintf (s
, "_gfortran_specific%s", e
.value
.function
.name
);
2225 name
= get_identifier (s
);
2226 mangled_name
= name
;
2230 name
= gfc_sym_identifier (sym
);
2231 mangled_name
= gfc_sym_mangled_function_id (sym
);
2234 type
= gfc_get_function_type (sym
, actual_args
);
2235 fndecl
= build_decl (input_location
,
2236 FUNCTION_DECL
, name
, type
);
2238 /* Initialize DECL_EXTERNAL and TREE_PUBLIC before calling decl_attributes;
2239 TREE_PUBLIC specifies whether a function is globally addressable (i.e.
2240 the opposite of declaring a function as static in C). */
2241 DECL_EXTERNAL (fndecl
) = 1;
2242 TREE_PUBLIC (fndecl
) = 1;
2244 attributes
= add_attributes_to_decl (sym
->attr
, NULL_TREE
);
2245 decl_attributes (&fndecl
, attributes
, 0);
2247 gfc_set_decl_assembler_name (fndecl
, mangled_name
);
2249 /* Set the context of this decl. */
2250 if (0 && sym
->ns
&& sym
->ns
->proc_name
)
2252 /* TODO: Add external decls to the appropriate scope. */
2253 DECL_CONTEXT (fndecl
) = sym
->ns
->proc_name
->backend_decl
;
2257 /* Global declaration, e.g. intrinsic subroutine. */
2258 DECL_CONTEXT (fndecl
) = NULL_TREE
;
2261 /* Set attributes for PURE functions. A call to PURE function in the
2262 Fortran 95 sense is both pure and without side effects in the C
2264 if (sym
->attr
.pure
|| sym
->attr
.implicit_pure
)
2266 if (sym
->attr
.function
&& !gfc_return_by_reference (sym
))
2267 DECL_PURE_P (fndecl
) = 1;
2268 /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
2269 parameters and don't use alternate returns (is this
2270 allowed?). In that case, calls to them are meaningless, and
2271 can be optimized away. See also in build_function_decl(). */
2272 TREE_SIDE_EFFECTS (fndecl
) = 0;
2275 /* Mark non-returning functions. */
2276 if (sym
->attr
.noreturn
)
2277 TREE_THIS_VOLATILE(fndecl
) = 1;
2279 sym
->backend_decl
= fndecl
;
2281 if (DECL_CONTEXT (fndecl
) == NULL_TREE
)
2282 pushdecl_top_level (fndecl
);
2285 && sym
->formal_ns
->proc_name
== sym
2286 && sym
->formal_ns
->omp_declare_simd
)
2287 gfc_trans_omp_declare_simd (sym
->formal_ns
);
2293 /* Create a declaration for a procedure. For external functions (in the C
2294 sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is
2295 a master function with alternate entry points. */
2298 build_function_decl (gfc_symbol
* sym
, bool global
)
2300 tree fndecl
, type
, attributes
;
2301 symbol_attribute attr
;
2303 gfc_formal_arglist
*f
;
2305 bool module_procedure
= sym
->attr
.module_procedure
2307 && sym
->ns
->proc_name
2308 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
;
2310 gcc_assert (!sym
->attr
.external
|| module_procedure
);
2312 if (sym
->backend_decl
)
2315 /* Set the line and filename. sym->declared_at seems to point to the
2316 last statement for subroutines, but it'll do for now. */
2317 gfc_set_backend_locus (&sym
->declared_at
);
2319 /* Allow only one nesting level. Allow public declarations. */
2320 gcc_assert (current_function_decl
== NULL_TREE
2321 || DECL_FILE_SCOPE_P (current_function_decl
)
2322 || (TREE_CODE (DECL_CONTEXT (current_function_decl
))
2323 == NAMESPACE_DECL
));
2325 type
= gfc_get_function_type (sym
);
2326 fndecl
= build_decl (input_location
,
2327 FUNCTION_DECL
, gfc_sym_identifier (sym
), type
);
2331 /* Initialize DECL_EXTERNAL and TREE_PUBLIC before calling decl_attributes;
2332 TREE_PUBLIC specifies whether a function is globally addressable (i.e.
2333 the opposite of declaring a function as static in C). */
2334 DECL_EXTERNAL (fndecl
) = 0;
2336 if (sym
->attr
.access
== ACCESS_UNKNOWN
&& sym
->module
2337 && (sym
->ns
->default_access
== ACCESS_PRIVATE
2338 || (sym
->ns
->default_access
== ACCESS_UNKNOWN
2339 && flag_module_private
)))
2340 sym
->attr
.access
= ACCESS_PRIVATE
;
2342 if (!current_function_decl
2343 && !sym
->attr
.entry_master
&& !sym
->attr
.is_main_program
2344 && (sym
->attr
.access
!= ACCESS_PRIVATE
|| sym
->binding_label
2345 || sym
->attr
.public_used
))
2346 TREE_PUBLIC (fndecl
) = 1;
2348 if (sym
->attr
.referenced
|| sym
->attr
.entry_master
)
2349 TREE_USED (fndecl
) = 1;
2351 attributes
= add_attributes_to_decl (attr
, NULL_TREE
);
2352 decl_attributes (&fndecl
, attributes
, 0);
2354 /* Figure out the return type of the declared function, and build a
2355 RESULT_DECL for it. If this is a subroutine with alternate
2356 returns, build a RESULT_DECL for it. */
2357 result_decl
= NULL_TREE
;
2358 /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
2361 if (gfc_return_by_reference (sym
))
2362 type
= void_type_node
;
2365 if (sym
->result
!= sym
)
2366 result_decl
= gfc_sym_identifier (sym
->result
);
2368 type
= TREE_TYPE (TREE_TYPE (fndecl
));
2373 /* Look for alternate return placeholders. */
2374 int has_alternate_returns
= 0;
2375 for (f
= gfc_sym_get_dummy_args (sym
); f
; f
= f
->next
)
2379 has_alternate_returns
= 1;
2384 if (has_alternate_returns
)
2385 type
= integer_type_node
;
2387 type
= void_type_node
;
2390 result_decl
= build_decl (input_location
,
2391 RESULT_DECL
, result_decl
, type
);
2392 DECL_ARTIFICIAL (result_decl
) = 1;
2393 DECL_IGNORED_P (result_decl
) = 1;
2394 DECL_CONTEXT (result_decl
) = fndecl
;
2395 DECL_RESULT (fndecl
) = result_decl
;
2397 /* Don't call layout_decl for a RESULT_DECL.
2398 layout_decl (result_decl, 0); */
2400 /* TREE_STATIC means the function body is defined here. */
2401 TREE_STATIC (fndecl
) = 1;
2403 /* Set attributes for PURE functions. A call to a PURE function in the
2404 Fortran 95 sense is both pure and without side effects in the C
2406 if (attr
.pure
|| attr
.implicit_pure
)
2408 /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
2409 including an alternate return. In that case it can also be
2410 marked as PURE. See also in gfc_get_extern_function_decl(). */
2411 if (attr
.function
&& !gfc_return_by_reference (sym
))
2412 DECL_PURE_P (fndecl
) = 1;
2413 TREE_SIDE_EFFECTS (fndecl
) = 0;
2417 /* Layout the function declaration and put it in the binding level
2418 of the current function. */
2421 pushdecl_top_level (fndecl
);
2425 /* Perform name mangling if this is a top level or module procedure. */
2426 if (current_function_decl
== NULL_TREE
)
2427 gfc_set_decl_assembler_name (fndecl
, gfc_sym_mangled_function_id (sym
));
2429 sym
->backend_decl
= fndecl
;
2433 /* Create the DECL_ARGUMENTS for a procedure. */
2436 create_function_arglist (gfc_symbol
* sym
)
2439 gfc_formal_arglist
*f
;
2440 tree typelist
, hidden_typelist
;
2441 tree arglist
, hidden_arglist
;
2445 fndecl
= sym
->backend_decl
;
2447 /* Build formal argument list. Make sure that their TREE_CONTEXT is
2448 the new FUNCTION_DECL node. */
2449 arglist
= NULL_TREE
;
2450 hidden_arglist
= NULL_TREE
;
2451 typelist
= TYPE_ARG_TYPES (TREE_TYPE (fndecl
));
2453 if (sym
->attr
.entry_master
)
2455 type
= TREE_VALUE (typelist
);
2456 parm
= build_decl (input_location
,
2457 PARM_DECL
, get_identifier ("__entry"), type
);
2459 DECL_CONTEXT (parm
) = fndecl
;
2460 DECL_ARG_TYPE (parm
) = type
;
2461 TREE_READONLY (parm
) = 1;
2462 gfc_finish_decl (parm
);
2463 DECL_ARTIFICIAL (parm
) = 1;
2465 arglist
= chainon (arglist
, parm
);
2466 typelist
= TREE_CHAIN (typelist
);
2469 if (gfc_return_by_reference (sym
))
2471 tree type
= TREE_VALUE (typelist
), length
= NULL
;
2473 if (sym
->ts
.type
== BT_CHARACTER
)
2475 /* Length of character result. */
2476 tree len_type
= TREE_VALUE (TREE_CHAIN (typelist
));
2478 length
= build_decl (input_location
,
2480 get_identifier (".__result"),
2482 if (POINTER_TYPE_P (len_type
))
2484 sym
->ts
.u
.cl
->passed_length
= length
;
2485 TREE_USED (length
) = 1;
2487 else if (!sym
->ts
.u
.cl
->length
)
2489 sym
->ts
.u
.cl
->backend_decl
= length
;
2490 TREE_USED (length
) = 1;
2492 gcc_assert (TREE_CODE (length
) == PARM_DECL
);
2493 DECL_CONTEXT (length
) = fndecl
;
2494 DECL_ARG_TYPE (length
) = len_type
;
2495 TREE_READONLY (length
) = 1;
2496 DECL_ARTIFICIAL (length
) = 1;
2497 gfc_finish_decl (length
);
2498 if (sym
->ts
.u
.cl
->backend_decl
== NULL
2499 || sym
->ts
.u
.cl
->backend_decl
== length
)
2504 if (sym
->ts
.u
.cl
->backend_decl
== NULL
)
2506 tree len
= build_decl (input_location
,
2508 get_identifier ("..__result"),
2509 gfc_charlen_type_node
);
2510 DECL_ARTIFICIAL (len
) = 1;
2511 TREE_USED (len
) = 1;
2512 sym
->ts
.u
.cl
->backend_decl
= len
;
2515 /* Make sure PARM_DECL type doesn't point to incomplete type. */
2516 arg
= sym
->result
? sym
->result
: sym
;
2517 backend_decl
= arg
->backend_decl
;
2518 /* Temporary clear it, so that gfc_sym_type creates complete
2520 arg
->backend_decl
= NULL
;
2521 type
= gfc_sym_type (arg
);
2522 arg
->backend_decl
= backend_decl
;
2523 type
= build_reference_type (type
);
2527 parm
= build_decl (input_location
,
2528 PARM_DECL
, get_identifier ("__result"), type
);
2530 DECL_CONTEXT (parm
) = fndecl
;
2531 DECL_ARG_TYPE (parm
) = TREE_VALUE (typelist
);
2532 TREE_READONLY (parm
) = 1;
2533 DECL_ARTIFICIAL (parm
) = 1;
2534 gfc_finish_decl (parm
);
2536 arglist
= chainon (arglist
, parm
);
2537 typelist
= TREE_CHAIN (typelist
);
2539 if (sym
->ts
.type
== BT_CHARACTER
)
2541 gfc_allocate_lang_decl (parm
);
2542 arglist
= chainon (arglist
, length
);
2543 typelist
= TREE_CHAIN (typelist
);
2547 hidden_typelist
= typelist
;
2548 for (f
= gfc_sym_get_dummy_args (sym
); f
; f
= f
->next
)
2549 if (f
->sym
!= NULL
) /* Ignore alternate returns. */
2550 hidden_typelist
= TREE_CHAIN (hidden_typelist
);
2552 for (f
= gfc_sym_get_dummy_args (sym
); f
; f
= f
->next
)
2554 char name
[GFC_MAX_SYMBOL_LEN
+ 2];
2556 /* Ignore alternate returns. */
2560 type
= TREE_VALUE (typelist
);
2562 if (f
->sym
->ts
.type
== BT_CHARACTER
2563 && (!sym
->attr
.is_bind_c
|| sym
->attr
.entry_master
))
2565 tree len_type
= TREE_VALUE (hidden_typelist
);
2566 tree length
= NULL_TREE
;
2567 if (!f
->sym
->ts
.deferred
)
2568 gcc_assert (len_type
== gfc_charlen_type_node
);
2570 gcc_assert (POINTER_TYPE_P (len_type
));
2572 strcpy (&name
[1], f
->sym
->name
);
2574 length
= build_decl (input_location
,
2575 PARM_DECL
, get_identifier (name
), len_type
);
2577 hidden_arglist
= chainon (hidden_arglist
, length
);
2578 DECL_CONTEXT (length
) = fndecl
;
2579 DECL_ARTIFICIAL (length
) = 1;
2580 DECL_ARG_TYPE (length
) = len_type
;
2581 TREE_READONLY (length
) = 1;
2582 gfc_finish_decl (length
);
2584 /* Marking the length DECL_HIDDEN_STRING_LENGTH will lead
2585 to tail calls being disabled. Only do that if we
2586 potentially have broken callers. */
2587 if (flag_tail_call_workaround
2589 && f
->sym
->ts
.u
.cl
->length
2590 && f
->sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
2591 && (flag_tail_call_workaround
== 2
2592 || f
->sym
->ns
->implicit_interface_calls
))
2593 DECL_HIDDEN_STRING_LENGTH (length
) = 1;
2595 /* Remember the passed value. */
2596 if (!f
->sym
->ts
.u
.cl
|| f
->sym
->ts
.u
.cl
->passed_length
)
2598 /* This can happen if the same type is used for multiple
2599 arguments. We need to copy cl as otherwise
2600 cl->passed_length gets overwritten. */
2601 f
->sym
->ts
.u
.cl
= gfc_new_charlen (f
->sym
->ns
, f
->sym
->ts
.u
.cl
);
2603 f
->sym
->ts
.u
.cl
->passed_length
= length
;
2605 /* Use the passed value for assumed length variables. */
2606 if (!f
->sym
->ts
.u
.cl
->length
)
2608 TREE_USED (length
) = 1;
2609 gcc_assert (!f
->sym
->ts
.u
.cl
->backend_decl
);
2610 f
->sym
->ts
.u
.cl
->backend_decl
= length
;
2613 hidden_typelist
= TREE_CHAIN (hidden_typelist
);
2615 if (f
->sym
->ts
.u
.cl
->backend_decl
== NULL
2616 || f
->sym
->ts
.u
.cl
->backend_decl
== length
)
2618 if (POINTER_TYPE_P (len_type
))
2619 f
->sym
->ts
.u
.cl
->backend_decl
=
2620 build_fold_indirect_ref_loc (input_location
, length
);
2621 else if (f
->sym
->ts
.u
.cl
->backend_decl
== NULL
)
2622 gfc_create_string_length (f
->sym
);
2624 /* Make sure PARM_DECL type doesn't point to incomplete type. */
2625 if (f
->sym
->attr
.flavor
== FL_PROCEDURE
)
2626 type
= build_pointer_type (gfc_get_function_type (f
->sym
));
2628 type
= gfc_sym_type (f
->sym
);
2631 /* For noncharacter scalar intrinsic types, VALUE passes the value,
2632 hence, the optional status cannot be transferred via a NULL pointer.
2633 Thus, we will use a hidden argument in that case. */
2634 else if (f
->sym
->attr
.optional
&& f
->sym
->attr
.value
2635 && !f
->sym
->attr
.dimension
&& f
->sym
->ts
.type
!= BT_CLASS
2636 && !gfc_bt_struct (f
->sym
->ts
.type
))
2639 strcpy (&name
[1], f
->sym
->name
);
2641 tmp
= build_decl (input_location
,
2642 PARM_DECL
, get_identifier (name
),
2645 hidden_arglist
= chainon (hidden_arglist
, tmp
);
2646 DECL_CONTEXT (tmp
) = fndecl
;
2647 DECL_ARTIFICIAL (tmp
) = 1;
2648 DECL_ARG_TYPE (tmp
) = boolean_type_node
;
2649 TREE_READONLY (tmp
) = 1;
2650 gfc_finish_decl (tmp
);
2653 /* For non-constant length array arguments, make sure they use
2654 a different type node from TYPE_ARG_TYPES type. */
2655 if (f
->sym
->attr
.dimension
2656 && type
== TREE_VALUE (typelist
)
2657 && TREE_CODE (type
) == POINTER_TYPE
2658 && GFC_ARRAY_TYPE_P (type
)
2659 && f
->sym
->as
->type
!= AS_ASSUMED_SIZE
2660 && ! COMPLETE_TYPE_P (TREE_TYPE (type
)))
2662 if (f
->sym
->attr
.flavor
== FL_PROCEDURE
)
2663 type
= build_pointer_type (gfc_get_function_type (f
->sym
));
2665 type
= gfc_sym_type (f
->sym
);
2668 if (f
->sym
->attr
.proc_pointer
)
2669 type
= build_pointer_type (type
);
2671 if (f
->sym
->attr
.volatile_
)
2672 type
= build_qualified_type (type
, TYPE_QUAL_VOLATILE
);
2674 /* Build the argument declaration. */
2675 parm
= build_decl (input_location
,
2676 PARM_DECL
, gfc_sym_identifier (f
->sym
), type
);
2678 if (f
->sym
->attr
.volatile_
)
2680 TREE_THIS_VOLATILE (parm
) = 1;
2681 TREE_SIDE_EFFECTS (parm
) = 1;
2684 /* Fill in arg stuff. */
2685 DECL_CONTEXT (parm
) = fndecl
;
2686 DECL_ARG_TYPE (parm
) = TREE_VALUE (typelist
);
2687 /* All implementation args except for VALUE are read-only. */
2688 if (!f
->sym
->attr
.value
)
2689 TREE_READONLY (parm
) = 1;
2690 if (POINTER_TYPE_P (type
)
2691 && (!f
->sym
->attr
.proc_pointer
2692 && f
->sym
->attr
.flavor
!= FL_PROCEDURE
))
2693 DECL_BY_REFERENCE (parm
) = 1;
2694 if (f
->sym
->attr
.optional
&& !f
->sym
->attr
.value
)
2696 /* With value, the argument is passed as is. */
2697 gfc_allocate_lang_decl (parm
);
2698 GFC_DECL_OPTIONAL_ARGUMENT (parm
) = 1;
2701 gfc_finish_decl (parm
);
2702 gfc_finish_decl_attrs (parm
, &f
->sym
->attr
);
2704 f
->sym
->backend_decl
= parm
;
2706 /* Coarrays which are descriptorless or assumed-shape pass with
2707 -fcoarray=lib the token and the offset as hidden arguments. */
2708 if (flag_coarray
== GFC_FCOARRAY_LIB
2709 && ((f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.codimension
2710 && !f
->sym
->attr
.allocatable
)
2711 || (f
->sym
->ts
.type
== BT_CLASS
2712 && CLASS_DATA (f
->sym
)->attr
.codimension
2713 && !CLASS_DATA (f
->sym
)->attr
.allocatable
)))
2719 gcc_assert (f
->sym
->backend_decl
!= NULL_TREE
2720 && !sym
->attr
.is_bind_c
);
2721 caf_type
= f
->sym
->ts
.type
== BT_CLASS
2722 ? TREE_TYPE (CLASS_DATA (f
->sym
)->backend_decl
)
2723 : TREE_TYPE (f
->sym
->backend_decl
);
2725 token
= build_decl (input_location
, PARM_DECL
,
2726 create_tmp_var_name ("caf_token"),
2727 build_qualified_type (pvoid_type_node
,
2728 TYPE_QUAL_RESTRICT
));
2729 if ((f
->sym
->ts
.type
!= BT_CLASS
2730 && f
->sym
->as
->type
!= AS_DEFERRED
)
2731 || (f
->sym
->ts
.type
== BT_CLASS
2732 && CLASS_DATA (f
->sym
)->as
->type
!= AS_DEFERRED
))
2734 gcc_assert (DECL_LANG_SPECIFIC (f
->sym
->backend_decl
) == NULL
2735 || GFC_DECL_TOKEN (f
->sym
->backend_decl
) == NULL_TREE
);
2736 if (DECL_LANG_SPECIFIC (f
->sym
->backend_decl
) == NULL
)
2737 gfc_allocate_lang_decl (f
->sym
->backend_decl
);
2738 GFC_DECL_TOKEN (f
->sym
->backend_decl
) = token
;
2742 gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) == NULL_TREE
);
2743 GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) = token
;
2746 DECL_CONTEXT (token
) = fndecl
;
2747 DECL_ARTIFICIAL (token
) = 1;
2748 DECL_ARG_TYPE (token
) = TREE_VALUE (typelist
);
2749 TREE_READONLY (token
) = 1;
2750 hidden_arglist
= chainon (hidden_arglist
, token
);
2751 gfc_finish_decl (token
);
2753 offset
= build_decl (input_location
, PARM_DECL
,
2754 create_tmp_var_name ("caf_offset"),
2755 gfc_array_index_type
);
2757 if ((f
->sym
->ts
.type
!= BT_CLASS
2758 && f
->sym
->as
->type
!= AS_DEFERRED
)
2759 || (f
->sym
->ts
.type
== BT_CLASS
2760 && CLASS_DATA (f
->sym
)->as
->type
!= AS_DEFERRED
))
2762 gcc_assert (GFC_DECL_CAF_OFFSET (f
->sym
->backend_decl
)
2764 GFC_DECL_CAF_OFFSET (f
->sym
->backend_decl
) = offset
;
2768 gcc_assert (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) == NULL_TREE
);
2769 GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) = offset
;
2771 DECL_CONTEXT (offset
) = fndecl
;
2772 DECL_ARTIFICIAL (offset
) = 1;
2773 DECL_ARG_TYPE (offset
) = TREE_VALUE (typelist
);
2774 TREE_READONLY (offset
) = 1;
2775 hidden_arglist
= chainon (hidden_arglist
, offset
);
2776 gfc_finish_decl (offset
);
2779 arglist
= chainon (arglist
, parm
);
2780 typelist
= TREE_CHAIN (typelist
);
2783 /* Add the hidden string length parameters, unless the procedure
2785 if (!sym
->attr
.is_bind_c
)
2786 arglist
= chainon (arglist
, hidden_arglist
);
2788 gcc_assert (hidden_typelist
== NULL_TREE
2789 || TREE_VALUE (hidden_typelist
) == void_type_node
);
2790 DECL_ARGUMENTS (fndecl
) = arglist
;
2793 /* Do the setup necessary before generating the body of a function. */
2796 trans_function_start (gfc_symbol
* sym
)
2800 fndecl
= sym
->backend_decl
;
2802 /* Let GCC know the current scope is this function. */
2803 current_function_decl
= fndecl
;
2805 /* Let the world know what we're about to do. */
2806 announce_function (fndecl
);
2808 if (DECL_FILE_SCOPE_P (fndecl
))
2810 /* Create RTL for function declaration. */
2811 rest_of_decl_compilation (fndecl
, 1, 0);
2814 /* Create RTL for function definition. */
2815 make_decl_rtl (fndecl
);
2817 allocate_struct_function (fndecl
, false);
2819 /* function.c requires a push at the start of the function. */
2823 /* Create thunks for alternate entry points. */
2826 build_entry_thunks (gfc_namespace
* ns
, bool global
)
2828 gfc_formal_arglist
*formal
;
2829 gfc_formal_arglist
*thunk_formal
;
2831 gfc_symbol
*thunk_sym
;
2837 /* This should always be a toplevel function. */
2838 gcc_assert (current_function_decl
== NULL_TREE
);
2840 gfc_save_backend_locus (&old_loc
);
2841 for (el
= ns
->entries
; el
; el
= el
->next
)
2843 vec
<tree
, va_gc
> *args
= NULL
;
2844 vec
<tree
, va_gc
> *string_args
= NULL
;
2846 thunk_sym
= el
->sym
;
2848 build_function_decl (thunk_sym
, global
);
2849 create_function_arglist (thunk_sym
);
2851 trans_function_start (thunk_sym
);
2853 thunk_fndecl
= thunk_sym
->backend_decl
;
2855 gfc_init_block (&body
);
2857 /* Pass extra parameter identifying this entry point. */
2858 tmp
= build_int_cst (gfc_array_index_type
, el
->id
);
2859 vec_safe_push (args
, tmp
);
2861 if (thunk_sym
->attr
.function
)
2863 if (gfc_return_by_reference (ns
->proc_name
))
2865 tree ref
= DECL_ARGUMENTS (current_function_decl
);
2866 vec_safe_push (args
, ref
);
2867 if (ns
->proc_name
->ts
.type
== BT_CHARACTER
)
2868 vec_safe_push (args
, DECL_CHAIN (ref
));
2872 for (formal
= gfc_sym_get_dummy_args (ns
->proc_name
); formal
;
2873 formal
= formal
->next
)
2875 /* Ignore alternate returns. */
2876 if (formal
->sym
== NULL
)
2879 /* We don't have a clever way of identifying arguments, so resort to
2880 a brute-force search. */
2881 for (thunk_formal
= gfc_sym_get_dummy_args (thunk_sym
);
2883 thunk_formal
= thunk_formal
->next
)
2885 if (thunk_formal
->sym
== formal
->sym
)
2891 /* Pass the argument. */
2892 DECL_ARTIFICIAL (thunk_formal
->sym
->backend_decl
) = 1;
2893 vec_safe_push (args
, thunk_formal
->sym
->backend_decl
);
2894 if (formal
->sym
->ts
.type
== BT_CHARACTER
)
2896 tmp
= thunk_formal
->sym
->ts
.u
.cl
->backend_decl
;
2897 vec_safe_push (string_args
, tmp
);
2902 /* Pass NULL for a missing argument. */
2903 vec_safe_push (args
, null_pointer_node
);
2904 if (formal
->sym
->ts
.type
== BT_CHARACTER
)
2906 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
2907 vec_safe_push (string_args
, tmp
);
2912 /* Call the master function. */
2913 vec_safe_splice (args
, string_args
);
2914 tmp
= ns
->proc_name
->backend_decl
;
2915 tmp
= build_call_expr_loc_vec (input_location
, tmp
, args
);
2916 if (ns
->proc_name
->attr
.mixed_entry_master
)
2918 tree union_decl
, field
;
2919 tree master_type
= TREE_TYPE (ns
->proc_name
->backend_decl
);
2921 union_decl
= build_decl (input_location
,
2922 VAR_DECL
, get_identifier ("__result"),
2923 TREE_TYPE (master_type
));
2924 DECL_ARTIFICIAL (union_decl
) = 1;
2925 DECL_EXTERNAL (union_decl
) = 0;
2926 TREE_PUBLIC (union_decl
) = 0;
2927 TREE_USED (union_decl
) = 1;
2928 layout_decl (union_decl
, 0);
2929 pushdecl (union_decl
);
2931 DECL_CONTEXT (union_decl
) = current_function_decl
;
2932 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
2933 TREE_TYPE (union_decl
), union_decl
, tmp
);
2934 gfc_add_expr_to_block (&body
, tmp
);
2936 for (field
= TYPE_FIELDS (TREE_TYPE (union_decl
));
2937 field
; field
= DECL_CHAIN (field
))
2938 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field
)),
2939 thunk_sym
->result
->name
) == 0)
2941 gcc_assert (field
!= NULL_TREE
);
2942 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
2943 TREE_TYPE (field
), union_decl
, field
,
2945 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
2946 TREE_TYPE (DECL_RESULT (current_function_decl
)),
2947 DECL_RESULT (current_function_decl
), tmp
);
2948 tmp
= build1_v (RETURN_EXPR
, tmp
);
2950 else if (TREE_TYPE (DECL_RESULT (current_function_decl
))
2953 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
2954 TREE_TYPE (DECL_RESULT (current_function_decl
)),
2955 DECL_RESULT (current_function_decl
), tmp
);
2956 tmp
= build1_v (RETURN_EXPR
, tmp
);
2958 gfc_add_expr_to_block (&body
, tmp
);
2960 /* Finish off this function and send it for code generation. */
2961 DECL_SAVED_TREE (thunk_fndecl
) = gfc_finish_block (&body
);
2964 BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl
)) = thunk_fndecl
;
2965 DECL_SAVED_TREE (thunk_fndecl
)
2966 = build3_v (BIND_EXPR
, tmp
, DECL_SAVED_TREE (thunk_fndecl
),
2967 DECL_INITIAL (thunk_fndecl
));
2969 /* Output the GENERIC tree. */
2970 dump_function (TDI_original
, thunk_fndecl
);
2972 /* Store the end of the function, so that we get good line number
2973 info for the epilogue. */
2974 cfun
->function_end_locus
= input_location
;
2976 /* We're leaving the context of this function, so zap cfun.
2977 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
2978 tree_rest_of_compilation. */
2981 current_function_decl
= NULL_TREE
;
2983 cgraph_node::finalize_function (thunk_fndecl
, true);
2985 /* We share the symbols in the formal argument list with other entry
2986 points and the master function. Clear them so that they are
2987 recreated for each function. */
2988 for (formal
= gfc_sym_get_dummy_args (thunk_sym
); formal
;
2989 formal
= formal
->next
)
2990 if (formal
->sym
!= NULL
) /* Ignore alternate returns. */
2992 formal
->sym
->backend_decl
= NULL_TREE
;
2993 if (formal
->sym
->ts
.type
== BT_CHARACTER
)
2994 formal
->sym
->ts
.u
.cl
->backend_decl
= NULL_TREE
;
2997 if (thunk_sym
->attr
.function
)
2999 if (thunk_sym
->ts
.type
== BT_CHARACTER
)
3000 thunk_sym
->ts
.u
.cl
->backend_decl
= NULL_TREE
;
3001 if (thunk_sym
->result
->ts
.type
== BT_CHARACTER
)
3002 thunk_sym
->result
->ts
.u
.cl
->backend_decl
= NULL_TREE
;
3006 gfc_restore_backend_locus (&old_loc
);
3010 /* Create a decl for a function, and create any thunks for alternate entry
3011 points. If global is true, generate the function in the global binding
3012 level, otherwise in the current binding level (which can be global). */
3015 gfc_create_function_decl (gfc_namespace
* ns
, bool global
)
3017 /* Create a declaration for the master function. */
3018 build_function_decl (ns
->proc_name
, global
);
3020 /* Compile the entry thunks. */
3022 build_entry_thunks (ns
, global
);
3024 /* Now create the read argument list. */
3025 create_function_arglist (ns
->proc_name
);
3027 if (ns
->omp_declare_simd
)
3028 gfc_trans_omp_declare_simd (ns
);
3031 /* Return the decl used to hold the function return value. If
3032 parent_flag is set, the context is the parent_scope. */
3035 gfc_get_fake_result_decl (gfc_symbol
* sym
, int parent_flag
)
3039 tree this_fake_result_decl
;
3040 tree this_function_decl
;
3042 char name
[GFC_MAX_SYMBOL_LEN
+ 10];
3046 this_fake_result_decl
= parent_fake_result_decl
;
3047 this_function_decl
= DECL_CONTEXT (current_function_decl
);
3051 this_fake_result_decl
= current_fake_result_decl
;
3052 this_function_decl
= current_function_decl
;
3056 && sym
->ns
->proc_name
->backend_decl
== this_function_decl
3057 && sym
->ns
->proc_name
->attr
.entry_master
3058 && sym
!= sym
->ns
->proc_name
)
3061 if (this_fake_result_decl
!= NULL
)
3062 for (t
= TREE_CHAIN (this_fake_result_decl
); t
; t
= TREE_CHAIN (t
))
3063 if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t
)), sym
->name
) == 0)
3066 return TREE_VALUE (t
);
3067 decl
= gfc_get_fake_result_decl (sym
->ns
->proc_name
, parent_flag
);
3070 this_fake_result_decl
= parent_fake_result_decl
;
3072 this_fake_result_decl
= current_fake_result_decl
;
3074 if (decl
&& sym
->ns
->proc_name
->attr
.mixed_entry_master
)
3078 for (field
= TYPE_FIELDS (TREE_TYPE (decl
));
3079 field
; field
= DECL_CHAIN (field
))
3080 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field
)),
3084 gcc_assert (field
!= NULL_TREE
);
3085 decl
= fold_build3_loc (input_location
, COMPONENT_REF
,
3086 TREE_TYPE (field
), decl
, field
, NULL_TREE
);
3089 var
= create_tmp_var_raw (TREE_TYPE (decl
), sym
->name
);
3091 gfc_add_decl_to_parent_function (var
);
3093 gfc_add_decl_to_function (var
);
3095 SET_DECL_VALUE_EXPR (var
, decl
);
3096 DECL_HAS_VALUE_EXPR_P (var
) = 1;
3097 GFC_DECL_RESULT (var
) = 1;
3099 TREE_CHAIN (this_fake_result_decl
)
3100 = tree_cons (get_identifier (sym
->name
), var
,
3101 TREE_CHAIN (this_fake_result_decl
));
3105 if (this_fake_result_decl
!= NULL_TREE
)
3106 return TREE_VALUE (this_fake_result_decl
);
3108 /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
3113 if (sym
->ts
.type
== BT_CHARACTER
)
3115 if (sym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
3116 length
= gfc_create_string_length (sym
);
3118 length
= sym
->ts
.u
.cl
->backend_decl
;
3119 if (VAR_P (length
) && DECL_CONTEXT (length
) == NULL_TREE
)
3120 gfc_add_decl_to_function (length
);
3123 if (gfc_return_by_reference (sym
))
3125 decl
= DECL_ARGUMENTS (this_function_decl
);
3127 if (sym
->ns
->proc_name
->backend_decl
== this_function_decl
3128 && sym
->ns
->proc_name
->attr
.entry_master
)
3129 decl
= DECL_CHAIN (decl
);
3131 TREE_USED (decl
) = 1;
3133 decl
= gfc_build_dummy_array_decl (sym
, decl
);
3137 sprintf (name
, "__result_%.20s",
3138 IDENTIFIER_POINTER (DECL_NAME (this_function_decl
)));
3140 if (!sym
->attr
.mixed_entry_master
&& sym
->attr
.function
)
3141 decl
= build_decl (DECL_SOURCE_LOCATION (this_function_decl
),
3142 VAR_DECL
, get_identifier (name
),
3143 gfc_sym_type (sym
));
3145 decl
= build_decl (DECL_SOURCE_LOCATION (this_function_decl
),
3146 VAR_DECL
, get_identifier (name
),
3147 TREE_TYPE (TREE_TYPE (this_function_decl
)));
3148 DECL_ARTIFICIAL (decl
) = 1;
3149 DECL_EXTERNAL (decl
) = 0;
3150 TREE_PUBLIC (decl
) = 0;
3151 TREE_USED (decl
) = 1;
3152 GFC_DECL_RESULT (decl
) = 1;
3153 TREE_ADDRESSABLE (decl
) = 1;
3155 layout_decl (decl
, 0);
3156 gfc_finish_decl_attrs (decl
, &sym
->attr
);
3159 gfc_add_decl_to_parent_function (decl
);
3161 gfc_add_decl_to_function (decl
);
3165 parent_fake_result_decl
= build_tree_list (NULL
, decl
);
3167 current_fake_result_decl
= build_tree_list (NULL
, decl
);
3173 /* Builds a function decl. The remaining parameters are the types of the
3174 function arguments. Negative nargs indicates a varargs function. */
3177 build_library_function_decl_1 (tree name
, const char *spec
,
3178 tree rettype
, int nargs
, va_list p
)
3180 vec
<tree
, va_gc
> *arglist
;
3185 /* Library functions must be declared with global scope. */
3186 gcc_assert (current_function_decl
== NULL_TREE
);
3188 /* Create a list of the argument types. */
3189 vec_alloc (arglist
, abs (nargs
));
3190 for (n
= abs (nargs
); n
> 0; n
--)
3192 tree argtype
= va_arg (p
, tree
);
3193 arglist
->quick_push (argtype
);
3196 /* Build the function type and decl. */
3198 fntype
= build_function_type_vec (rettype
, arglist
);
3200 fntype
= build_varargs_function_type_vec (rettype
, arglist
);
3203 tree attr_args
= build_tree_list (NULL_TREE
,
3204 build_string (strlen (spec
), spec
));
3205 tree attrs
= tree_cons (get_identifier ("fn spec"),
3206 attr_args
, TYPE_ATTRIBUTES (fntype
));
3207 fntype
= build_type_attribute_variant (fntype
, attrs
);
3209 fndecl
= build_decl (input_location
,
3210 FUNCTION_DECL
, name
, fntype
);
3212 /* Mark this decl as external. */
3213 DECL_EXTERNAL (fndecl
) = 1;
3214 TREE_PUBLIC (fndecl
) = 1;
3218 rest_of_decl_compilation (fndecl
, 1, 0);
3223 /* Builds a function decl. The remaining parameters are the types of the
3224 function arguments. Negative nargs indicates a varargs function. */
3227 gfc_build_library_function_decl (tree name
, tree rettype
, int nargs
, ...)
3231 va_start (args
, nargs
);
3232 ret
= build_library_function_decl_1 (name
, NULL
, rettype
, nargs
, args
);
3237 /* Builds a function decl. The remaining parameters are the types of the
3238 function arguments. Negative nargs indicates a varargs function.
3239 The SPEC parameter specifies the function argument and return type
3240 specification according to the fnspec function type attribute. */
3243 gfc_build_library_function_decl_with_spec (tree name
, const char *spec
,
3244 tree rettype
, int nargs
, ...)
3248 va_start (args
, nargs
);
3249 ret
= build_library_function_decl_1 (name
, spec
, rettype
, nargs
, args
);
3255 gfc_build_intrinsic_function_decls (void)
3257 tree gfc_int4_type_node
= gfc_get_int_type (4);
3258 tree gfc_pint4_type_node
= build_pointer_type (gfc_int4_type_node
);
3259 tree gfc_int8_type_node
= gfc_get_int_type (8);
3260 tree gfc_pint8_type_node
= build_pointer_type (gfc_int8_type_node
);
3261 tree gfc_int16_type_node
= gfc_get_int_type (16);
3262 tree gfc_logical4_type_node
= gfc_get_logical_type (4);
3263 tree pchar1_type_node
= gfc_get_pchar_type (1);
3264 tree pchar4_type_node
= gfc_get_pchar_type (4);
3266 /* String functions. */
3267 gfor_fndecl_compare_string
= gfc_build_library_function_decl_with_spec (
3268 get_identifier (PREFIX("compare_string")), "..R.R",
3269 integer_type_node
, 4, gfc_charlen_type_node
, pchar1_type_node
,
3270 gfc_charlen_type_node
, pchar1_type_node
);
3271 DECL_PURE_P (gfor_fndecl_compare_string
) = 1;
3272 TREE_NOTHROW (gfor_fndecl_compare_string
) = 1;
3274 gfor_fndecl_concat_string
= gfc_build_library_function_decl_with_spec (
3275 get_identifier (PREFIX("concat_string")), "..W.R.R",
3276 void_type_node
, 6, gfc_charlen_type_node
, pchar1_type_node
,
3277 gfc_charlen_type_node
, pchar1_type_node
,
3278 gfc_charlen_type_node
, pchar1_type_node
);
3279 TREE_NOTHROW (gfor_fndecl_concat_string
) = 1;
3281 gfor_fndecl_string_len_trim
= gfc_build_library_function_decl_with_spec (
3282 get_identifier (PREFIX("string_len_trim")), "..R",
3283 gfc_charlen_type_node
, 2, gfc_charlen_type_node
, pchar1_type_node
);
3284 DECL_PURE_P (gfor_fndecl_string_len_trim
) = 1;
3285 TREE_NOTHROW (gfor_fndecl_string_len_trim
) = 1;
3287 gfor_fndecl_string_index
= gfc_build_library_function_decl_with_spec (
3288 get_identifier (PREFIX("string_index")), "..R.R.",
3289 gfc_charlen_type_node
, 5, gfc_charlen_type_node
, pchar1_type_node
,
3290 gfc_charlen_type_node
, pchar1_type_node
, gfc_logical4_type_node
);
3291 DECL_PURE_P (gfor_fndecl_string_index
) = 1;
3292 TREE_NOTHROW (gfor_fndecl_string_index
) = 1;
3294 gfor_fndecl_string_scan
= gfc_build_library_function_decl_with_spec (
3295 get_identifier (PREFIX("string_scan")), "..R.R.",
3296 gfc_charlen_type_node
, 5, gfc_charlen_type_node
, pchar1_type_node
,
3297 gfc_charlen_type_node
, pchar1_type_node
, gfc_logical4_type_node
);
3298 DECL_PURE_P (gfor_fndecl_string_scan
) = 1;
3299 TREE_NOTHROW (gfor_fndecl_string_scan
) = 1;
3301 gfor_fndecl_string_verify
= gfc_build_library_function_decl_with_spec (
3302 get_identifier (PREFIX("string_verify")), "..R.R.",
3303 gfc_charlen_type_node
, 5, gfc_charlen_type_node
, pchar1_type_node
,
3304 gfc_charlen_type_node
, pchar1_type_node
, gfc_logical4_type_node
);
3305 DECL_PURE_P (gfor_fndecl_string_verify
) = 1;
3306 TREE_NOTHROW (gfor_fndecl_string_verify
) = 1;
3308 gfor_fndecl_string_trim
= gfc_build_library_function_decl_with_spec (
3309 get_identifier (PREFIX("string_trim")), ".Ww.R",
3310 void_type_node
, 4, build_pointer_type (gfc_charlen_type_node
),
3311 build_pointer_type (pchar1_type_node
), gfc_charlen_type_node
,
3314 gfor_fndecl_string_minmax
= gfc_build_library_function_decl_with_spec (
3315 get_identifier (PREFIX("string_minmax")), ".Ww.R",
3316 void_type_node
, -4, build_pointer_type (gfc_charlen_type_node
),
3317 build_pointer_type (pchar1_type_node
), integer_type_node
,
3320 gfor_fndecl_adjustl
= gfc_build_library_function_decl_with_spec (
3321 get_identifier (PREFIX("adjustl")), ".W.R",
3322 void_type_node
, 3, pchar1_type_node
, gfc_charlen_type_node
,
3324 TREE_NOTHROW (gfor_fndecl_adjustl
) = 1;
3326 gfor_fndecl_adjustr
= gfc_build_library_function_decl_with_spec (
3327 get_identifier (PREFIX("adjustr")), ".W.R",
3328 void_type_node
, 3, pchar1_type_node
, gfc_charlen_type_node
,
3330 TREE_NOTHROW (gfor_fndecl_adjustr
) = 1;
3332 gfor_fndecl_select_string
= gfc_build_library_function_decl_with_spec (
3333 get_identifier (PREFIX("select_string")), ".R.R.",
3334 integer_type_node
, 4, pvoid_type_node
, integer_type_node
,
3335 pchar1_type_node
, gfc_charlen_type_node
);
3336 DECL_PURE_P (gfor_fndecl_select_string
) = 1;
3337 TREE_NOTHROW (gfor_fndecl_select_string
) = 1;
3339 gfor_fndecl_compare_string_char4
= gfc_build_library_function_decl_with_spec (
3340 get_identifier (PREFIX("compare_string_char4")), "..R.R",
3341 integer_type_node
, 4, gfc_charlen_type_node
, pchar4_type_node
,
3342 gfc_charlen_type_node
, pchar4_type_node
);
3343 DECL_PURE_P (gfor_fndecl_compare_string_char4
) = 1;
3344 TREE_NOTHROW (gfor_fndecl_compare_string_char4
) = 1;
3346 gfor_fndecl_concat_string_char4
= gfc_build_library_function_decl_with_spec (
3347 get_identifier (PREFIX("concat_string_char4")), "..W.R.R",
3348 void_type_node
, 6, gfc_charlen_type_node
, pchar4_type_node
,
3349 gfc_charlen_type_node
, pchar4_type_node
, gfc_charlen_type_node
,
3351 TREE_NOTHROW (gfor_fndecl_concat_string_char4
) = 1;
3353 gfor_fndecl_string_len_trim_char4
= gfc_build_library_function_decl_with_spec (
3354 get_identifier (PREFIX("string_len_trim_char4")), "..R",
3355 gfc_charlen_type_node
, 2, gfc_charlen_type_node
, pchar4_type_node
);
3356 DECL_PURE_P (gfor_fndecl_string_len_trim_char4
) = 1;
3357 TREE_NOTHROW (gfor_fndecl_string_len_trim_char4
) = 1;
3359 gfor_fndecl_string_index_char4
= gfc_build_library_function_decl_with_spec (
3360 get_identifier (PREFIX("string_index_char4")), "..R.R.",
3361 gfc_charlen_type_node
, 5, gfc_charlen_type_node
, pchar4_type_node
,
3362 gfc_charlen_type_node
, pchar4_type_node
, gfc_logical4_type_node
);
3363 DECL_PURE_P (gfor_fndecl_string_index_char4
) = 1;
3364 TREE_NOTHROW (gfor_fndecl_string_index_char4
) = 1;
3366 gfor_fndecl_string_scan_char4
= gfc_build_library_function_decl_with_spec (
3367 get_identifier (PREFIX("string_scan_char4")), "..R.R.",
3368 gfc_charlen_type_node
, 5, gfc_charlen_type_node
, pchar4_type_node
,
3369 gfc_charlen_type_node
, pchar4_type_node
, gfc_logical4_type_node
);
3370 DECL_PURE_P (gfor_fndecl_string_scan_char4
) = 1;
3371 TREE_NOTHROW (gfor_fndecl_string_scan_char4
) = 1;
3373 gfor_fndecl_string_verify_char4
= gfc_build_library_function_decl_with_spec (
3374 get_identifier (PREFIX("string_verify_char4")), "..R.R.",
3375 gfc_charlen_type_node
, 5, gfc_charlen_type_node
, pchar4_type_node
,
3376 gfc_charlen_type_node
, pchar4_type_node
, gfc_logical4_type_node
);
3377 DECL_PURE_P (gfor_fndecl_string_verify_char4
) = 1;
3378 TREE_NOTHROW (gfor_fndecl_string_verify_char4
) = 1;
3380 gfor_fndecl_string_trim_char4
= gfc_build_library_function_decl_with_spec (
3381 get_identifier (PREFIX("string_trim_char4")), ".Ww.R",
3382 void_type_node
, 4, build_pointer_type (gfc_charlen_type_node
),
3383 build_pointer_type (pchar4_type_node
), gfc_charlen_type_node
,
3386 gfor_fndecl_string_minmax_char4
= gfc_build_library_function_decl_with_spec (
3387 get_identifier (PREFIX("string_minmax_char4")), ".Ww.R",
3388 void_type_node
, -4, build_pointer_type (gfc_charlen_type_node
),
3389 build_pointer_type (pchar4_type_node
), integer_type_node
,
3392 gfor_fndecl_adjustl_char4
= gfc_build_library_function_decl_with_spec (
3393 get_identifier (PREFIX("adjustl_char4")), ".W.R",
3394 void_type_node
, 3, pchar4_type_node
, gfc_charlen_type_node
,
3396 TREE_NOTHROW (gfor_fndecl_adjustl_char4
) = 1;
3398 gfor_fndecl_adjustr_char4
= gfc_build_library_function_decl_with_spec (
3399 get_identifier (PREFIX("adjustr_char4")), ".W.R",
3400 void_type_node
, 3, pchar4_type_node
, gfc_charlen_type_node
,
3402 TREE_NOTHROW (gfor_fndecl_adjustr_char4
) = 1;
3404 gfor_fndecl_select_string_char4
= gfc_build_library_function_decl_with_spec (
3405 get_identifier (PREFIX("select_string_char4")), ".R.R.",
3406 integer_type_node
, 4, pvoid_type_node
, integer_type_node
,
3407 pvoid_type_node
, gfc_charlen_type_node
);
3408 DECL_PURE_P (gfor_fndecl_select_string_char4
) = 1;
3409 TREE_NOTHROW (gfor_fndecl_select_string_char4
) = 1;
3412 /* Conversion between character kinds. */
3414 gfor_fndecl_convert_char1_to_char4
= gfc_build_library_function_decl_with_spec (
3415 get_identifier (PREFIX("convert_char1_to_char4")), ".w.R",
3416 void_type_node
, 3, build_pointer_type (pchar4_type_node
),
3417 gfc_charlen_type_node
, pchar1_type_node
);
3419 gfor_fndecl_convert_char4_to_char1
= gfc_build_library_function_decl_with_spec (
3420 get_identifier (PREFIX("convert_char4_to_char1")), ".w.R",
3421 void_type_node
, 3, build_pointer_type (pchar1_type_node
),
3422 gfc_charlen_type_node
, pchar4_type_node
);
3424 /* Misc. functions. */
3426 gfor_fndecl_ttynam
= gfc_build_library_function_decl_with_spec (
3427 get_identifier (PREFIX("ttynam")), ".W",
3428 void_type_node
, 3, pchar_type_node
, gfc_charlen_type_node
,
3431 gfor_fndecl_fdate
= gfc_build_library_function_decl_with_spec (
3432 get_identifier (PREFIX("fdate")), ".W",
3433 void_type_node
, 2, pchar_type_node
, gfc_charlen_type_node
);
3435 gfor_fndecl_ctime
= gfc_build_library_function_decl_with_spec (
3436 get_identifier (PREFIX("ctime")), ".W",
3437 void_type_node
, 3, pchar_type_node
, gfc_charlen_type_node
,
3438 gfc_int8_type_node
);
3440 gfor_fndecl_random_init
= gfc_build_library_function_decl (
3441 get_identifier (PREFIX("random_init")),
3442 void_type_node
, 3, gfc_logical4_type_node
, gfc_logical4_type_node
,
3443 gfc_int4_type_node
);
3445 gfor_fndecl_sc_kind
= gfc_build_library_function_decl_with_spec (
3446 get_identifier (PREFIX("selected_char_kind")), "..R",
3447 gfc_int4_type_node
, 2, gfc_charlen_type_node
, pchar_type_node
);
3448 DECL_PURE_P (gfor_fndecl_sc_kind
) = 1;
3449 TREE_NOTHROW (gfor_fndecl_sc_kind
) = 1;
3451 gfor_fndecl_si_kind
= gfc_build_library_function_decl_with_spec (
3452 get_identifier (PREFIX("selected_int_kind")), ".R",
3453 gfc_int4_type_node
, 1, pvoid_type_node
);
3454 DECL_PURE_P (gfor_fndecl_si_kind
) = 1;
3455 TREE_NOTHROW (gfor_fndecl_si_kind
) = 1;
3457 gfor_fndecl_sr_kind
= gfc_build_library_function_decl_with_spec (
3458 get_identifier (PREFIX("selected_real_kind2008")), ".RR",
3459 gfc_int4_type_node
, 3, pvoid_type_node
, pvoid_type_node
,
3461 DECL_PURE_P (gfor_fndecl_sr_kind
) = 1;
3462 TREE_NOTHROW (gfor_fndecl_sr_kind
) = 1;
3464 gfor_fndecl_system_clock4
= gfc_build_library_function_decl (
3465 get_identifier (PREFIX("system_clock_4")),
3466 void_type_node
, 3, gfc_pint4_type_node
, gfc_pint4_type_node
,
3467 gfc_pint4_type_node
);
3469 gfor_fndecl_system_clock8
= gfc_build_library_function_decl (
3470 get_identifier (PREFIX("system_clock_8")),
3471 void_type_node
, 3, gfc_pint8_type_node
, gfc_pint8_type_node
,
3472 gfc_pint8_type_node
);
3474 /* Power functions. */
3476 tree ctype
, rtype
, itype
, jtype
;
3477 int rkind
, ikind
, jkind
;
3480 static int ikinds
[NIKINDS
] = {4, 8, 16};
3481 static int rkinds
[NRKINDS
] = {4, 8, 10, 16};
3482 char name
[PREFIX_LEN
+ 12]; /* _gfortran_pow_?n_?n */
3484 for (ikind
=0; ikind
< NIKINDS
; ikind
++)
3486 itype
= gfc_get_int_type (ikinds
[ikind
]);
3488 for (jkind
=0; jkind
< NIKINDS
; jkind
++)
3490 jtype
= gfc_get_int_type (ikinds
[jkind
]);
3493 sprintf (name
, PREFIX("pow_i%d_i%d"), ikinds
[ikind
],
3495 gfor_fndecl_math_powi
[jkind
][ikind
].integer
=
3496 gfc_build_library_function_decl (get_identifier (name
),
3497 jtype
, 2, jtype
, itype
);
3498 TREE_READONLY (gfor_fndecl_math_powi
[jkind
][ikind
].integer
) = 1;
3499 TREE_NOTHROW (gfor_fndecl_math_powi
[jkind
][ikind
].integer
) = 1;
3503 for (rkind
= 0; rkind
< NRKINDS
; rkind
++)
3505 rtype
= gfc_get_real_type (rkinds
[rkind
]);
3508 sprintf (name
, PREFIX("pow_r%d_i%d"), rkinds
[rkind
],
3510 gfor_fndecl_math_powi
[rkind
][ikind
].real
=
3511 gfc_build_library_function_decl (get_identifier (name
),
3512 rtype
, 2, rtype
, itype
);
3513 TREE_READONLY (gfor_fndecl_math_powi
[rkind
][ikind
].real
) = 1;
3514 TREE_NOTHROW (gfor_fndecl_math_powi
[rkind
][ikind
].real
) = 1;
3517 ctype
= gfc_get_complex_type (rkinds
[rkind
]);
3520 sprintf (name
, PREFIX("pow_c%d_i%d"), rkinds
[rkind
],
3522 gfor_fndecl_math_powi
[rkind
][ikind
].cmplx
=
3523 gfc_build_library_function_decl (get_identifier (name
),
3524 ctype
, 2,ctype
, itype
);
3525 TREE_READONLY (gfor_fndecl_math_powi
[rkind
][ikind
].cmplx
) = 1;
3526 TREE_NOTHROW (gfor_fndecl_math_powi
[rkind
][ikind
].cmplx
) = 1;
3534 gfor_fndecl_math_ishftc4
= gfc_build_library_function_decl (
3535 get_identifier (PREFIX("ishftc4")),
3536 gfc_int4_type_node
, 3, gfc_int4_type_node
, gfc_int4_type_node
,
3537 gfc_int4_type_node
);
3538 TREE_READONLY (gfor_fndecl_math_ishftc4
) = 1;
3539 TREE_NOTHROW (gfor_fndecl_math_ishftc4
) = 1;
3541 gfor_fndecl_math_ishftc8
= gfc_build_library_function_decl (
3542 get_identifier (PREFIX("ishftc8")),
3543 gfc_int8_type_node
, 3, gfc_int8_type_node
, gfc_int4_type_node
,
3544 gfc_int4_type_node
);
3545 TREE_READONLY (gfor_fndecl_math_ishftc8
) = 1;
3546 TREE_NOTHROW (gfor_fndecl_math_ishftc8
) = 1;
3548 if (gfc_int16_type_node
)
3550 gfor_fndecl_math_ishftc16
= gfc_build_library_function_decl (
3551 get_identifier (PREFIX("ishftc16")),
3552 gfc_int16_type_node
, 3, gfc_int16_type_node
, gfc_int4_type_node
,
3553 gfc_int4_type_node
);
3554 TREE_READONLY (gfor_fndecl_math_ishftc16
) = 1;
3555 TREE_NOTHROW (gfor_fndecl_math_ishftc16
) = 1;
3558 /* BLAS functions. */
3560 tree pint
= build_pointer_type (integer_type_node
);
3561 tree ps
= build_pointer_type (gfc_get_real_type (gfc_default_real_kind
));
3562 tree pd
= build_pointer_type (gfc_get_real_type (gfc_default_double_kind
));
3563 tree pc
= build_pointer_type (gfc_get_complex_type (gfc_default_real_kind
));
3564 tree pz
= build_pointer_type
3565 (gfc_get_complex_type (gfc_default_double_kind
));
3567 gfor_fndecl_sgemm
= gfc_build_library_function_decl
3569 (flag_underscoring
? "sgemm_" : "sgemm"),
3570 void_type_node
, 15, pchar_type_node
,
3571 pchar_type_node
, pint
, pint
, pint
, ps
, ps
, pint
,
3572 ps
, pint
, ps
, ps
, pint
, integer_type_node
,
3574 gfor_fndecl_dgemm
= gfc_build_library_function_decl
3576 (flag_underscoring
? "dgemm_" : "dgemm"),
3577 void_type_node
, 15, pchar_type_node
,
3578 pchar_type_node
, pint
, pint
, pint
, pd
, pd
, pint
,
3579 pd
, pint
, pd
, pd
, pint
, integer_type_node
,
3581 gfor_fndecl_cgemm
= gfc_build_library_function_decl
3583 (flag_underscoring
? "cgemm_" : "cgemm"),
3584 void_type_node
, 15, pchar_type_node
,
3585 pchar_type_node
, pint
, pint
, pint
, pc
, pc
, pint
,
3586 pc
, pint
, pc
, pc
, pint
, integer_type_node
,
3588 gfor_fndecl_zgemm
= gfc_build_library_function_decl
3590 (flag_underscoring
? "zgemm_" : "zgemm"),
3591 void_type_node
, 15, pchar_type_node
,
3592 pchar_type_node
, pint
, pint
, pint
, pz
, pz
, pint
,
3593 pz
, pint
, pz
, pz
, pint
, integer_type_node
,
3597 /* Other functions. */
3598 gfor_fndecl_size0
= gfc_build_library_function_decl_with_spec (
3599 get_identifier (PREFIX("size0")), ".R",
3600 gfc_array_index_type
, 1, pvoid_type_node
);
3601 DECL_PURE_P (gfor_fndecl_size0
) = 1;
3602 TREE_NOTHROW (gfor_fndecl_size0
) = 1;
3604 gfor_fndecl_size1
= gfc_build_library_function_decl_with_spec (
3605 get_identifier (PREFIX("size1")), ".R",
3606 gfc_array_index_type
, 2, pvoid_type_node
, gfc_array_index_type
);
3607 DECL_PURE_P (gfor_fndecl_size1
) = 1;
3608 TREE_NOTHROW (gfor_fndecl_size1
) = 1;
3610 gfor_fndecl_iargc
= gfc_build_library_function_decl (
3611 get_identifier (PREFIX ("iargc")), gfc_int4_type_node
, 0);
3612 TREE_NOTHROW (gfor_fndecl_iargc
) = 1;
3614 gfor_fndecl_kill_sub
= gfc_build_library_function_decl (
3615 get_identifier (PREFIX ("kill_sub")), void_type_node
,
3616 3, gfc_int4_type_node
, gfc_int4_type_node
, gfc_pint4_type_node
);
3618 gfor_fndecl_kill
= gfc_build_library_function_decl (
3619 get_identifier (PREFIX ("kill")), gfc_int4_type_node
,
3620 2, gfc_int4_type_node
, gfc_int4_type_node
);
3622 gfor_fndecl_is_contiguous0
= gfc_build_library_function_decl_with_spec (
3623 get_identifier (PREFIX("is_contiguous0")), ".R",
3624 gfc_int4_type_node
, 1, pvoid_type_node
);
3625 DECL_PURE_P (gfor_fndecl_is_contiguous0
) = 1;
3626 TREE_NOTHROW (gfor_fndecl_is_contiguous0
) = 1;
3630 /* Make prototypes for runtime library functions. */
3633 gfc_build_builtin_function_decls (void)
3635 tree gfc_int8_type_node
= gfc_get_int_type (8);
3637 gfor_fndecl_stop_numeric
= gfc_build_library_function_decl (
3638 get_identifier (PREFIX("stop_numeric")),
3639 void_type_node
, 2, integer_type_node
, boolean_type_node
);
3640 /* STOP doesn't return. */
3641 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric
) = 1;
3643 gfor_fndecl_stop_string
= gfc_build_library_function_decl_with_spec (
3644 get_identifier (PREFIX("stop_string")), ".R.",
3645 void_type_node
, 3, pchar_type_node
, size_type_node
,
3647 /* STOP doesn't return. */
3648 TREE_THIS_VOLATILE (gfor_fndecl_stop_string
) = 1;
3650 gfor_fndecl_error_stop_numeric
= gfc_build_library_function_decl (
3651 get_identifier (PREFIX("error_stop_numeric")),
3652 void_type_node
, 2, integer_type_node
, boolean_type_node
);
3653 /* ERROR STOP doesn't return. */
3654 TREE_THIS_VOLATILE (gfor_fndecl_error_stop_numeric
) = 1;
3656 gfor_fndecl_error_stop_string
= gfc_build_library_function_decl_with_spec (
3657 get_identifier (PREFIX("error_stop_string")), ".R.",
3658 void_type_node
, 3, pchar_type_node
, size_type_node
,
3660 /* ERROR STOP doesn't return. */
3661 TREE_THIS_VOLATILE (gfor_fndecl_error_stop_string
) = 1;
3663 gfor_fndecl_pause_numeric
= gfc_build_library_function_decl (
3664 get_identifier (PREFIX("pause_numeric")),
3665 void_type_node
, 1, gfc_int8_type_node
);
3667 gfor_fndecl_pause_string
= gfc_build_library_function_decl_with_spec (
3668 get_identifier (PREFIX("pause_string")), ".R.",
3669 void_type_node
, 2, pchar_type_node
, size_type_node
);
3671 gfor_fndecl_runtime_error
= gfc_build_library_function_decl_with_spec (
3672 get_identifier (PREFIX("runtime_error")), ".R",
3673 void_type_node
, -1, pchar_type_node
);
3674 /* The runtime_error function does not return. */
3675 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error
) = 1;
3677 gfor_fndecl_runtime_error_at
= gfc_build_library_function_decl_with_spec (
3678 get_identifier (PREFIX("runtime_error_at")), ".RR",
3679 void_type_node
, -2, pchar_type_node
, pchar_type_node
);
3680 /* The runtime_error_at function does not return. */
3681 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at
) = 1;
3683 gfor_fndecl_runtime_warning_at
= gfc_build_library_function_decl_with_spec (
3684 get_identifier (PREFIX("runtime_warning_at")), ".RR",
3685 void_type_node
, -2, pchar_type_node
, pchar_type_node
);
3687 gfor_fndecl_generate_error
= gfc_build_library_function_decl_with_spec (
3688 get_identifier (PREFIX("generate_error")), ".R.R",
3689 void_type_node
, 3, pvoid_type_node
, integer_type_node
,
3692 gfor_fndecl_os_error_at
= gfc_build_library_function_decl_with_spec (
3693 get_identifier (PREFIX("os_error_at")), ".RR",
3694 void_type_node
, -2, pchar_type_node
, pchar_type_node
);
3695 /* The os_error_at function does not return. */
3696 TREE_THIS_VOLATILE (gfor_fndecl_os_error_at
) = 1;
3698 gfor_fndecl_set_args
= gfc_build_library_function_decl (
3699 get_identifier (PREFIX("set_args")),
3700 void_type_node
, 2, integer_type_node
,
3701 build_pointer_type (pchar_type_node
));
3703 gfor_fndecl_set_fpe
= gfc_build_library_function_decl (
3704 get_identifier (PREFIX("set_fpe")),
3705 void_type_node
, 1, integer_type_node
);
3707 gfor_fndecl_ieee_procedure_entry
= gfc_build_library_function_decl (
3708 get_identifier (PREFIX("ieee_procedure_entry")),
3709 void_type_node
, 1, pvoid_type_node
);
3711 gfor_fndecl_ieee_procedure_exit
= gfc_build_library_function_decl (
3712 get_identifier (PREFIX("ieee_procedure_exit")),
3713 void_type_node
, 1, pvoid_type_node
);
3715 /* Keep the array dimension in sync with the call, later in this file. */
3716 gfor_fndecl_set_options
= gfc_build_library_function_decl_with_spec (
3717 get_identifier (PREFIX("set_options")), "..R",
3718 void_type_node
, 2, integer_type_node
,
3719 build_pointer_type (integer_type_node
));
3721 gfor_fndecl_set_convert
= gfc_build_library_function_decl (
3722 get_identifier (PREFIX("set_convert")),
3723 void_type_node
, 1, integer_type_node
);
3725 gfor_fndecl_set_record_marker
= gfc_build_library_function_decl (
3726 get_identifier (PREFIX("set_record_marker")),
3727 void_type_node
, 1, integer_type_node
);
3729 gfor_fndecl_set_max_subrecord_length
= gfc_build_library_function_decl (
3730 get_identifier (PREFIX("set_max_subrecord_length")),
3731 void_type_node
, 1, integer_type_node
);
3733 gfor_fndecl_in_pack
= gfc_build_library_function_decl_with_spec (
3734 get_identifier (PREFIX("internal_pack")), ".r",
3735 pvoid_type_node
, 1, pvoid_type_node
);
3737 gfor_fndecl_in_unpack
= gfc_build_library_function_decl_with_spec (
3738 get_identifier (PREFIX("internal_unpack")), ".wR",
3739 void_type_node
, 2, pvoid_type_node
, pvoid_type_node
);
3741 gfor_fndecl_cfi_to_gfc
= gfc_build_library_function_decl_with_spec (
3742 get_identifier (PREFIX("cfi_desc_to_gfc_desc")), ".ww",
3743 void_type_node
, 2, pvoid_type_node
, ppvoid_type_node
);
3745 gfor_fndecl_gfc_to_cfi
= gfc_build_library_function_decl_with_spec (
3746 get_identifier (PREFIX("gfc_desc_to_cfi_desc")), ".wR",
3747 void_type_node
, 2, ppvoid_type_node
, pvoid_type_node
);
3749 gfor_fndecl_associated
= gfc_build_library_function_decl_with_spec (
3750 get_identifier (PREFIX("associated")), ".RR",
3751 integer_type_node
, 2, ppvoid_type_node
, ppvoid_type_node
);
3752 DECL_PURE_P (gfor_fndecl_associated
) = 1;
3753 TREE_NOTHROW (gfor_fndecl_associated
) = 1;
3755 /* Coarray library calls. */
3756 if (flag_coarray
== GFC_FCOARRAY_LIB
)
3758 tree pint_type
, pppchar_type
;
3760 pint_type
= build_pointer_type (integer_type_node
);
3762 = build_pointer_type (build_pointer_type (pchar_type_node
));
3764 gfor_fndecl_caf_init
= gfc_build_library_function_decl (
3765 get_identifier (PREFIX("caf_init")), void_type_node
,
3766 2, pint_type
, pppchar_type
);
3768 gfor_fndecl_caf_finalize
= gfc_build_library_function_decl (
3769 get_identifier (PREFIX("caf_finalize")), void_type_node
, 0);
3771 gfor_fndecl_caf_this_image
= gfc_build_library_function_decl (
3772 get_identifier (PREFIX("caf_this_image")), integer_type_node
,
3773 1, integer_type_node
);
3775 gfor_fndecl_caf_num_images
= gfc_build_library_function_decl (
3776 get_identifier (PREFIX("caf_num_images")), integer_type_node
,
3777 2, integer_type_node
, integer_type_node
);
3779 gfor_fndecl_caf_register
= gfc_build_library_function_decl_with_spec (
3780 get_identifier (PREFIX("caf_register")), "RRWWWWR", void_type_node
, 7,
3781 size_type_node
, integer_type_node
, ppvoid_type_node
, pvoid_type_node
,
3782 pint_type
, pchar_type_node
, size_type_node
);
3784 gfor_fndecl_caf_deregister
= gfc_build_library_function_decl_with_spec (
3785 get_identifier (PREFIX("caf_deregister")), "WRWWR", void_type_node
, 5,
3786 ppvoid_type_node
, integer_type_node
, pint_type
, pchar_type_node
,
3789 gfor_fndecl_caf_get
= gfc_build_library_function_decl_with_spec (
3790 get_identifier (PREFIX("caf_get")), ".R.RRWRRRW", void_type_node
, 10,
3791 pvoid_type_node
, size_type_node
, integer_type_node
, pvoid_type_node
,
3792 pvoid_type_node
, pvoid_type_node
, integer_type_node
, integer_type_node
,
3793 boolean_type_node
, pint_type
);
3795 gfor_fndecl_caf_send
= gfc_build_library_function_decl_with_spec (
3796 get_identifier (PREFIX("caf_send")), ".R.RRRRRRWR", void_type_node
, 11,
3797 pvoid_type_node
, size_type_node
, integer_type_node
, pvoid_type_node
,
3798 pvoid_type_node
, pvoid_type_node
, integer_type_node
, integer_type_node
,
3799 boolean_type_node
, pint_type
, pvoid_type_node
);
3801 gfor_fndecl_caf_sendget
= gfc_build_library_function_decl_with_spec (
3802 get_identifier (PREFIX("caf_sendget")), ".R.RRRR.RRRRRR",
3803 void_type_node
, 14, pvoid_type_node
, size_type_node
, integer_type_node
,
3804 pvoid_type_node
, pvoid_type_node
, pvoid_type_node
, size_type_node
,
3805 integer_type_node
, pvoid_type_node
, pvoid_type_node
, integer_type_node
,
3806 integer_type_node
, boolean_type_node
, integer_type_node
);
3808 gfor_fndecl_caf_get_by_ref
= gfc_build_library_function_decl_with_spec (
3809 get_identifier (PREFIX("caf_get_by_ref")), ".RWRRRRRWR", void_type_node
,
3810 10, pvoid_type_node
, integer_type_node
, pvoid_type_node
,
3811 pvoid_type_node
, integer_type_node
, integer_type_node
,
3812 boolean_type_node
, boolean_type_node
, pint_type
, integer_type_node
);
3814 gfor_fndecl_caf_send_by_ref
= gfc_build_library_function_decl_with_spec (
3815 get_identifier (PREFIX("caf_send_by_ref")), ".RRRRRRRWR",
3816 void_type_node
, 10, pvoid_type_node
, integer_type_node
, pvoid_type_node
,
3817 pvoid_type_node
, integer_type_node
, integer_type_node
,
3818 boolean_type_node
, boolean_type_node
, pint_type
, integer_type_node
);
3820 gfor_fndecl_caf_sendget_by_ref
3821 = gfc_build_library_function_decl_with_spec (
3822 get_identifier (PREFIX("caf_sendget_by_ref")), ".RR.RRRRRWWRR",
3823 void_type_node
, 13, pvoid_type_node
, integer_type_node
,
3824 pvoid_type_node
, pvoid_type_node
, integer_type_node
,
3825 pvoid_type_node
, integer_type_node
, integer_type_node
,
3826 boolean_type_node
, pint_type
, pint_type
, integer_type_node
,
3829 gfor_fndecl_caf_sync_all
= gfc_build_library_function_decl_with_spec (
3830 get_identifier (PREFIX("caf_sync_all")), ".WW", void_type_node
,
3831 3, pint_type
, pchar_type_node
, size_type_node
);
3833 gfor_fndecl_caf_sync_memory
= gfc_build_library_function_decl_with_spec (
3834 get_identifier (PREFIX("caf_sync_memory")), ".WW", void_type_node
,
3835 3, pint_type
, pchar_type_node
, size_type_node
);
3837 gfor_fndecl_caf_sync_images
= gfc_build_library_function_decl_with_spec (
3838 get_identifier (PREFIX("caf_sync_images")), ".RRWW", void_type_node
,
3839 5, integer_type_node
, pint_type
, pint_type
,
3840 pchar_type_node
, size_type_node
);
3842 gfor_fndecl_caf_error_stop
= gfc_build_library_function_decl (
3843 get_identifier (PREFIX("caf_error_stop")),
3844 void_type_node
, 1, integer_type_node
);
3845 /* CAF's ERROR STOP doesn't return. */
3846 TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop
) = 1;
3848 gfor_fndecl_caf_error_stop_str
= gfc_build_library_function_decl_with_spec (
3849 get_identifier (PREFIX("caf_error_stop_str")), ".R.",
3850 void_type_node
, 2, pchar_type_node
, size_type_node
);
3851 /* CAF's ERROR STOP doesn't return. */
3852 TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop_str
) = 1;
3854 gfor_fndecl_caf_stop_numeric
= gfc_build_library_function_decl_with_spec (
3855 get_identifier (PREFIX("caf_stop_numeric")), ".R.",
3856 void_type_node
, 1, integer_type_node
);
3857 /* CAF's STOP doesn't return. */
3858 TREE_THIS_VOLATILE (gfor_fndecl_caf_stop_numeric
) = 1;
3860 gfor_fndecl_caf_stop_str
= gfc_build_library_function_decl_with_spec (
3861 get_identifier (PREFIX("caf_stop_str")), ".R.",
3862 void_type_node
, 2, pchar_type_node
, size_type_node
);
3863 /* CAF's STOP doesn't return. */
3864 TREE_THIS_VOLATILE (gfor_fndecl_caf_stop_str
) = 1;
3866 gfor_fndecl_caf_atomic_def
= gfc_build_library_function_decl_with_spec (
3867 get_identifier (PREFIX("caf_atomic_define")), "R..RW",
3868 void_type_node
, 7, pvoid_type_node
, size_type_node
, integer_type_node
,
3869 pvoid_type_node
, pint_type
, integer_type_node
, integer_type_node
);
3871 gfor_fndecl_caf_atomic_ref
= gfc_build_library_function_decl_with_spec (
3872 get_identifier (PREFIX("caf_atomic_ref")), "R..WW",
3873 void_type_node
, 7, pvoid_type_node
, size_type_node
, integer_type_node
,
3874 pvoid_type_node
, pint_type
, integer_type_node
, integer_type_node
);
3876 gfor_fndecl_caf_atomic_cas
= gfc_build_library_function_decl_with_spec (
3877 get_identifier (PREFIX("caf_atomic_cas")), "R..WRRW",
3878 void_type_node
, 9, pvoid_type_node
, size_type_node
, integer_type_node
,
3879 pvoid_type_node
, pvoid_type_node
, pvoid_type_node
, pint_type
,
3880 integer_type_node
, integer_type_node
);
3882 gfor_fndecl_caf_atomic_op
= gfc_build_library_function_decl_with_spec (
3883 get_identifier (PREFIX("caf_atomic_op")), ".R..RWW",
3884 void_type_node
, 9, integer_type_node
, pvoid_type_node
, size_type_node
,
3885 integer_type_node
, pvoid_type_node
, pvoid_type_node
, pint_type
,
3886 integer_type_node
, integer_type_node
);
3888 gfor_fndecl_caf_lock
= gfc_build_library_function_decl_with_spec (
3889 get_identifier (PREFIX("caf_lock")), "R..WWW",
3890 void_type_node
, 7, pvoid_type_node
, size_type_node
, integer_type_node
,
3891 pint_type
, pint_type
, pchar_type_node
, size_type_node
);
3893 gfor_fndecl_caf_unlock
= gfc_build_library_function_decl_with_spec (
3894 get_identifier (PREFIX("caf_unlock")), "R..WW",
3895 void_type_node
, 6, pvoid_type_node
, size_type_node
, integer_type_node
,
3896 pint_type
, pchar_type_node
, size_type_node
);
3898 gfor_fndecl_caf_event_post
= gfc_build_library_function_decl_with_spec (
3899 get_identifier (PREFIX("caf_event_post")), "R..WW",
3900 void_type_node
, 6, pvoid_type_node
, size_type_node
, integer_type_node
,
3901 pint_type
, pchar_type_node
, size_type_node
);
3903 gfor_fndecl_caf_event_wait
= gfc_build_library_function_decl_with_spec (
3904 get_identifier (PREFIX("caf_event_wait")), "R..WW",
3905 void_type_node
, 6, pvoid_type_node
, size_type_node
, integer_type_node
,
3906 pint_type
, pchar_type_node
, size_type_node
);
3908 gfor_fndecl_caf_event_query
= gfc_build_library_function_decl_with_spec (
3909 get_identifier (PREFIX("caf_event_query")), "R..WW",
3910 void_type_node
, 5, pvoid_type_node
, size_type_node
, integer_type_node
,
3911 pint_type
, pint_type
);
3913 gfor_fndecl_caf_fail_image
= gfc_build_library_function_decl (
3914 get_identifier (PREFIX("caf_fail_image")), void_type_node
, 0);
3915 /* CAF's FAIL doesn't return. */
3916 TREE_THIS_VOLATILE (gfor_fndecl_caf_fail_image
) = 1;
3918 gfor_fndecl_caf_failed_images
3919 = gfc_build_library_function_decl_with_spec (
3920 get_identifier (PREFIX("caf_failed_images")), "WRR",
3921 void_type_node
, 3, pvoid_type_node
, ppvoid_type_node
,
3924 gfor_fndecl_caf_form_team
3925 = gfc_build_library_function_decl_with_spec (
3926 get_identifier (PREFIX("caf_form_team")), "RWR",
3927 void_type_node
, 3, integer_type_node
, ppvoid_type_node
,
3930 gfor_fndecl_caf_change_team
3931 = gfc_build_library_function_decl_with_spec (
3932 get_identifier (PREFIX("caf_change_team")), "RR",
3933 void_type_node
, 2, ppvoid_type_node
,
3936 gfor_fndecl_caf_end_team
3937 = gfc_build_library_function_decl (
3938 get_identifier (PREFIX("caf_end_team")), void_type_node
, 0);
3940 gfor_fndecl_caf_get_team
3941 = gfc_build_library_function_decl_with_spec (
3942 get_identifier (PREFIX("caf_get_team")), "R",
3943 void_type_node
, 1, integer_type_node
);
3945 gfor_fndecl_caf_sync_team
3946 = gfc_build_library_function_decl_with_spec (
3947 get_identifier (PREFIX("caf_sync_team")), "RR",
3948 void_type_node
, 2, ppvoid_type_node
,
3951 gfor_fndecl_caf_team_number
3952 = gfc_build_library_function_decl_with_spec (
3953 get_identifier (PREFIX("caf_team_number")), "R",
3954 integer_type_node
, 1, integer_type_node
);
3956 gfor_fndecl_caf_image_status
3957 = gfc_build_library_function_decl_with_spec (
3958 get_identifier (PREFIX("caf_image_status")), "RR",
3959 integer_type_node
, 2, integer_type_node
, ppvoid_type_node
);
3961 gfor_fndecl_caf_stopped_images
3962 = gfc_build_library_function_decl_with_spec (
3963 get_identifier (PREFIX("caf_stopped_images")), "WRR",
3964 void_type_node
, 3, pvoid_type_node
, ppvoid_type_node
,
3967 gfor_fndecl_co_broadcast
= gfc_build_library_function_decl_with_spec (
3968 get_identifier (PREFIX("caf_co_broadcast")), "W.WW",
3969 void_type_node
, 5, pvoid_type_node
, integer_type_node
,
3970 pint_type
, pchar_type_node
, size_type_node
);
3972 gfor_fndecl_co_max
= gfc_build_library_function_decl_with_spec (
3973 get_identifier (PREFIX("caf_co_max")), "W.WW",
3974 void_type_node
, 6, pvoid_type_node
, integer_type_node
,
3975 pint_type
, pchar_type_node
, integer_type_node
, size_type_node
);
3977 gfor_fndecl_co_min
= gfc_build_library_function_decl_with_spec (
3978 get_identifier (PREFIX("caf_co_min")), "W.WW",
3979 void_type_node
, 6, pvoid_type_node
, integer_type_node
,
3980 pint_type
, pchar_type_node
, integer_type_node
, size_type_node
);
3982 gfor_fndecl_co_reduce
= gfc_build_library_function_decl_with_spec (
3983 get_identifier (PREFIX("caf_co_reduce")), "W.R.WW",
3984 void_type_node
, 8, pvoid_type_node
,
3985 build_pointer_type (build_varargs_function_type_list (void_type_node
,
3987 integer_type_node
, integer_type_node
, pint_type
, pchar_type_node
,
3988 integer_type_node
, size_type_node
);
3990 gfor_fndecl_co_sum
= gfc_build_library_function_decl_with_spec (
3991 get_identifier (PREFIX("caf_co_sum")), "W.WW",
3992 void_type_node
, 5, pvoid_type_node
, integer_type_node
,
3993 pint_type
, pchar_type_node
, size_type_node
);
3995 gfor_fndecl_caf_is_present
= gfc_build_library_function_decl_with_spec (
3996 get_identifier (PREFIX("caf_is_present")), "RRR",
3997 integer_type_node
, 3, pvoid_type_node
, integer_type_node
,
4001 gfc_build_intrinsic_function_decls ();
4002 gfc_build_intrinsic_lib_fndecls ();
4003 gfc_build_io_library_fndecls ();
4007 /* Evaluate the length of dummy character variables. */
4010 gfc_trans_dummy_character (gfc_symbol
*sym
, gfc_charlen
*cl
,
4011 gfc_wrapped_block
*block
)
4015 gfc_finish_decl (cl
->backend_decl
);
4017 gfc_start_block (&init
);
4019 /* Evaluate the string length expression. */
4020 gfc_conv_string_length (cl
, NULL
, &init
);
4022 gfc_trans_vla_type_sizes (sym
, &init
);
4024 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
4028 /* Allocate and cleanup an automatic character variable. */
4031 gfc_trans_auto_character_variable (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
4037 gcc_assert (sym
->backend_decl
);
4038 gcc_assert (sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
);
4040 gfc_init_block (&init
);
4042 /* Evaluate the string length expression. */
4043 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
4045 gfc_trans_vla_type_sizes (sym
, &init
);
4047 decl
= sym
->backend_decl
;
4049 /* Emit a DECL_EXPR for this variable, which will cause the
4050 gimplifier to allocate storage, and all that good stuff. */
4051 tmp
= fold_build1_loc (input_location
, DECL_EXPR
, TREE_TYPE (decl
), decl
);
4052 gfc_add_expr_to_block (&init
, tmp
);
4054 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
4057 /* Set the initial value of ASSIGN statement auxiliary variable explicitly. */
4060 gfc_trans_assign_aux_var (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
4064 gcc_assert (sym
->backend_decl
);
4065 gfc_start_block (&init
);
4067 /* Set the initial value to length. See the comments in
4068 function gfc_add_assign_aux_vars in this file. */
4069 gfc_add_modify (&init
, GFC_DECL_STRING_LEN (sym
->backend_decl
),
4070 build_int_cst (gfc_charlen_type_node
, -2));
4072 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
4076 gfc_trans_vla_one_sizepos (tree
*tp
, stmtblock_t
*body
)
4078 tree t
= *tp
, var
, val
;
4080 if (t
== NULL
|| t
== error_mark_node
)
4082 if (TREE_CONSTANT (t
) || DECL_P (t
))
4085 if (TREE_CODE (t
) == SAVE_EXPR
)
4087 if (SAVE_EXPR_RESOLVED_P (t
))
4089 *tp
= TREE_OPERAND (t
, 0);
4092 val
= TREE_OPERAND (t
, 0);
4097 var
= gfc_create_var_np (TREE_TYPE (t
), NULL
);
4098 gfc_add_decl_to_function (var
);
4099 gfc_add_modify (body
, var
, unshare_expr (val
));
4100 if (TREE_CODE (t
) == SAVE_EXPR
)
4101 TREE_OPERAND (t
, 0) = var
;
4106 gfc_trans_vla_type_sizes_1 (tree type
, stmtblock_t
*body
)
4110 if (type
== NULL
|| type
== error_mark_node
)
4113 type
= TYPE_MAIN_VARIANT (type
);
4115 if (TREE_CODE (type
) == INTEGER_TYPE
)
4117 gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type
), body
);
4118 gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type
), body
);
4120 for (t
= TYPE_NEXT_VARIANT (type
); t
; t
= TYPE_NEXT_VARIANT (t
))
4122 TYPE_MIN_VALUE (t
) = TYPE_MIN_VALUE (type
);
4123 TYPE_MAX_VALUE (t
) = TYPE_MAX_VALUE (type
);
4126 else if (TREE_CODE (type
) == ARRAY_TYPE
)
4128 gfc_trans_vla_type_sizes_1 (TREE_TYPE (type
), body
);
4129 gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type
), body
);
4130 gfc_trans_vla_one_sizepos (&TYPE_SIZE (type
), body
);
4131 gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type
), body
);
4133 for (t
= TYPE_NEXT_VARIANT (type
); t
; t
= TYPE_NEXT_VARIANT (t
))
4135 TYPE_SIZE (t
) = TYPE_SIZE (type
);
4136 TYPE_SIZE_UNIT (t
) = TYPE_SIZE_UNIT (type
);
4141 /* Make sure all type sizes and array domains are either constant,
4142 or variable or parameter decls. This is a simplified variant
4143 of gimplify_type_sizes, but we can't use it here, as none of the
4144 variables in the expressions have been gimplified yet.
4145 As type sizes and domains for various variable length arrays
4146 contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
4147 time, without this routine gimplify_type_sizes in the middle-end
4148 could result in the type sizes being gimplified earlier than where
4149 those variables are initialized. */
4152 gfc_trans_vla_type_sizes (gfc_symbol
*sym
, stmtblock_t
*body
)
4154 tree type
= TREE_TYPE (sym
->backend_decl
);
4156 if (TREE_CODE (type
) == FUNCTION_TYPE
4157 && (sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.entry
))
4159 if (! current_fake_result_decl
)
4162 type
= TREE_TYPE (TREE_VALUE (current_fake_result_decl
));
4165 while (POINTER_TYPE_P (type
))
4166 type
= TREE_TYPE (type
);
4168 if (GFC_DESCRIPTOR_TYPE_P (type
))
4170 tree etype
= GFC_TYPE_ARRAY_DATAPTR_TYPE (type
);
4172 while (POINTER_TYPE_P (etype
))
4173 etype
= TREE_TYPE (etype
);
4175 gfc_trans_vla_type_sizes_1 (etype
, body
);
4178 gfc_trans_vla_type_sizes_1 (type
, body
);
4182 /* Initialize a derived type by building an lvalue from the symbol
4183 and using trans_assignment to do the work. Set dealloc to false
4184 if no deallocation prior the assignment is needed. */
4186 gfc_init_default_dt (gfc_symbol
* sym
, stmtblock_t
* block
, bool dealloc
)
4194 /* Initialization of PDTs is done elsewhere. */
4195 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.pdt_type
)
4198 gcc_assert (!sym
->attr
.allocatable
);
4199 gfc_set_sym_referenced (sym
);
4200 e
= gfc_lval_expr_from_sym (sym
);
4201 tmp
= gfc_trans_assignment (e
, sym
->value
, false, dealloc
);
4202 if (sym
->attr
.dummy
&& (sym
->attr
.optional
4203 || sym
->ns
->proc_name
->attr
.entry_master
))
4205 present
= gfc_conv_expr_present (sym
);
4206 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), present
,
4207 tmp
, build_empty_stmt (input_location
));
4209 gfc_add_expr_to_block (block
, tmp
);
4214 /* Initialize INTENT(OUT) derived type dummies. As well as giving
4215 them their default initializer, if they do not have allocatable
4216 components, they have their allocatable components deallocated. */
4219 init_intent_out_dt (gfc_symbol
* proc_sym
, gfc_wrapped_block
* block
)
4222 gfc_formal_arglist
*f
;
4226 gfc_init_block (&init
);
4227 for (f
= gfc_sym_get_dummy_args (proc_sym
); f
; f
= f
->next
)
4228 if (f
->sym
&& f
->sym
->attr
.intent
== INTENT_OUT
4229 && !f
->sym
->attr
.pointer
4230 && f
->sym
->ts
.type
== BT_DERIVED
)
4234 /* Note: Allocatables are excluded as they are already handled
4236 if (!f
->sym
->attr
.allocatable
4237 && gfc_is_finalizable (f
->sym
->ts
.u
.derived
, NULL
))
4242 gfc_init_block (&block
);
4243 f
->sym
->attr
.referenced
= 1;
4244 e
= gfc_lval_expr_from_sym (f
->sym
);
4245 gfc_add_finalizer_call (&block
, e
);
4247 tmp
= gfc_finish_block (&block
);
4250 if (tmp
== NULL_TREE
&& !f
->sym
->attr
.allocatable
4251 && f
->sym
->ts
.u
.derived
->attr
.alloc_comp
&& !f
->sym
->value
)
4252 tmp
= gfc_deallocate_alloc_comp (f
->sym
->ts
.u
.derived
,
4253 f
->sym
->backend_decl
,
4254 f
->sym
->as
? f
->sym
->as
->rank
: 0);
4256 if (tmp
!= NULL_TREE
&& (f
->sym
->attr
.optional
4257 || f
->sym
->ns
->proc_name
->attr
.entry_master
))
4259 present
= gfc_conv_expr_present (f
->sym
);
4260 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
4261 present
, tmp
, build_empty_stmt (input_location
));
4264 if (tmp
!= NULL_TREE
)
4265 gfc_add_expr_to_block (&init
, tmp
);
4266 else if (f
->sym
->value
&& !f
->sym
->attr
.allocatable
)
4267 gfc_init_default_dt (f
->sym
, &init
, true);
4269 else if (f
->sym
&& f
->sym
->attr
.intent
== INTENT_OUT
4270 && f
->sym
->ts
.type
== BT_CLASS
4271 && !CLASS_DATA (f
->sym
)->attr
.class_pointer
4272 && !CLASS_DATA (f
->sym
)->attr
.allocatable
)
4277 gfc_init_block (&block
);
4278 f
->sym
->attr
.referenced
= 1;
4279 e
= gfc_lval_expr_from_sym (f
->sym
);
4280 gfc_add_finalizer_call (&block
, e
);
4282 tmp
= gfc_finish_block (&block
);
4284 if (f
->sym
->attr
.optional
|| f
->sym
->ns
->proc_name
->attr
.entry_master
)
4286 present
= gfc_conv_expr_present (f
->sym
);
4287 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
4289 build_empty_stmt (input_location
));
4292 gfc_add_expr_to_block (&init
, tmp
);
4295 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
4299 /* Helper function to manage deferred string lengths. */
4302 gfc_null_and_pass_deferred_len (gfc_symbol
*sym
, stmtblock_t
*init
,
4307 /* Character length passed by reference. */
4308 tmp
= sym
->ts
.u
.cl
->passed_length
;
4309 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
4310 tmp
= fold_convert (gfc_charlen_type_node
, tmp
);
4312 if (!sym
->attr
.dummy
|| sym
->attr
.intent
== INTENT_OUT
)
4313 /* Zero the string length when entering the scope. */
4314 gfc_add_modify (init
, sym
->ts
.u
.cl
->backend_decl
,
4315 build_int_cst (gfc_charlen_type_node
, 0));
4320 tmp2
= fold_build2_loc (input_location
, MODIFY_EXPR
,
4321 gfc_charlen_type_node
,
4322 sym
->ts
.u
.cl
->backend_decl
, tmp
);
4323 if (sym
->attr
.optional
)
4325 tree present
= gfc_conv_expr_present (sym
);
4326 tmp2
= build3_loc (input_location
, COND_EXPR
,
4327 void_type_node
, present
, tmp2
,
4328 build_empty_stmt (input_location
));
4330 gfc_add_expr_to_block (init
, tmp2
);
4333 gfc_restore_backend_locus (loc
);
4335 /* Pass the final character length back. */
4336 if (sym
->attr
.intent
!= INTENT_IN
)
4338 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
4339 gfc_charlen_type_node
, tmp
,
4340 sym
->ts
.u
.cl
->backend_decl
);
4341 if (sym
->attr
.optional
)
4343 tree present
= gfc_conv_expr_present (sym
);
4344 tmp
= build3_loc (input_location
, COND_EXPR
,
4345 void_type_node
, present
, tmp
,
4346 build_empty_stmt (input_location
));
4356 /* Convert CFI descriptor dummies into gfc types and back again. */
4358 convert_CFI_desc (gfc_wrapped_block
* block
, gfc_symbol
*sym
)
4369 stmtblock_t outer_block
;
4370 stmtblock_t tmpblock
;
4372 /* dummy_ptr will be the pointer to the passed array descriptor,
4373 while CFI_desc is the descriptor itself. */
4374 if (DECL_LANG_SPECIFIC (sym
->backend_decl
))
4375 CFI_desc
= GFC_DECL_SAVED_DESCRIPTOR (sym
->backend_decl
);
4379 dummy_ptr
= CFI_desc
;
4383 CFI_desc
= build_fold_indirect_ref_loc (input_location
, CFI_desc
);
4385 /* The compiler will have given CFI_desc the correct gfortran
4386 type. Use this new variable to store the converted
4388 gfc_desc
= gfc_create_var (TREE_TYPE (CFI_desc
), "gfc_desc");
4389 tmp
= build_pointer_type (TREE_TYPE (gfc_desc
));
4390 gfc_desc_ptr
= gfc_create_var (tmp
, "gfc_desc_ptr");
4391 CFI_desc_ptr
= gfc_create_var (pvoid_type_node
, "CFI_desc_ptr");
4393 /* Fix the condition for the presence of the argument. */
4394 gfc_init_block (&outer_block
);
4395 present
= fold_build2_loc (input_location
, NE_EXPR
,
4396 logical_type_node
, dummy_ptr
,
4397 build_int_cst (TREE_TYPE (dummy_ptr
), 0));
4399 gfc_init_block (&tmpblock
);
4400 /* Pointer to the gfc descriptor. */
4401 gfc_add_modify (&tmpblock
, gfc_desc_ptr
,
4402 gfc_build_addr_expr (NULL
, gfc_desc
));
4403 /* Store the pointer to the CFI descriptor. */
4404 gfc_add_modify (&tmpblock
, CFI_desc_ptr
,
4405 fold_convert (pvoid_type_node
, dummy_ptr
));
4406 tmp
= gfc_build_addr_expr (ppvoid_type_node
, CFI_desc_ptr
);
4407 /* Convert the CFI descriptor. */
4408 incoming
= build_call_expr_loc (input_location
,
4409 gfor_fndecl_cfi_to_gfc
, 2, gfc_desc_ptr
, tmp
);
4410 gfc_add_expr_to_block (&tmpblock
, incoming
);
4411 /* Set the dummy pointer to point to the gfc_descriptor. */
4412 gfc_add_modify (&tmpblock
, dummy_ptr
,
4413 fold_convert (TREE_TYPE (dummy_ptr
), gfc_desc_ptr
));
4415 /* The hidden string length is not passed to bind(C) procedures so set
4416 it from the descriptor element length. */
4417 if (sym
->ts
.type
== BT_CHARACTER
4418 && sym
->ts
.u
.cl
->backend_decl
4419 && VAR_P (sym
->ts
.u
.cl
->backend_decl
))
4421 tmp
= build_fold_indirect_ref_loc (input_location
, dummy_ptr
);
4422 tmp
= gfc_conv_descriptor_elem_len (tmp
);
4423 gfc_add_modify (&tmpblock
, sym
->ts
.u
.cl
->backend_decl
,
4424 fold_convert (TREE_TYPE (sym
->ts
.u
.cl
->backend_decl
),
4428 /* Check that the argument is present before executing the above. */
4429 incoming
= build3_v (COND_EXPR
, present
,
4430 gfc_finish_block (&tmpblock
),
4431 build_empty_stmt (input_location
));
4432 gfc_add_expr_to_block (&outer_block
, incoming
);
4433 incoming
= gfc_finish_block (&outer_block
);
4436 /* Convert the gfc descriptor back to the CFI type before going
4437 out of scope, if the CFI type was present at entry. */
4438 gfc_init_block (&outer_block
);
4439 gfc_init_block (&tmpblock
);
4441 tmp
= gfc_build_addr_expr (ppvoid_type_node
, CFI_desc_ptr
);
4442 outgoing
= build_call_expr_loc (input_location
,
4443 gfor_fndecl_gfc_to_cfi
, 2, tmp
, gfc_desc_ptr
);
4444 gfc_add_expr_to_block (&tmpblock
, outgoing
);
4446 outgoing
= build3_v (COND_EXPR
, present
,
4447 gfc_finish_block (&tmpblock
),
4448 build_empty_stmt (input_location
));
4449 gfc_add_expr_to_block (&outer_block
, outgoing
);
4450 outgoing
= gfc_finish_block (&outer_block
);
4452 /* Add the lot to the procedure init and finally blocks. */
4453 gfc_add_init_cleanup (block
, incoming
, outgoing
);
4457 /* Get the result expression for a procedure. */
4460 get_proc_result (gfc_symbol
* sym
)
4462 if (sym
->attr
.subroutine
|| sym
== sym
->result
)
4464 if (current_fake_result_decl
!= NULL
)
4465 return TREE_VALUE (current_fake_result_decl
);
4470 return sym
->result
->backend_decl
;
4474 /* Generate function entry and exit code, and add it to the function body.
4476 Allocation and initialization of array variables.
4477 Allocation of character string variables.
4478 Initialization and possibly repacking of dummy arrays.
4479 Initialization of ASSIGN statement auxiliary variable.
4480 Initialization of ASSOCIATE names.
4481 Automatic deallocation. */
4484 gfc_trans_deferred_vars (gfc_symbol
* proc_sym
, gfc_wrapped_block
* block
)
4488 gfc_formal_arglist
*f
;
4489 stmtblock_t tmpblock
;
4490 bool seen_trans_deferred_array
= false;
4491 bool is_pdt_type
= false;
4497 /* Deal with implicit return variables. Explicit return variables will
4498 already have been added. */
4499 if (gfc_return_by_reference (proc_sym
) && proc_sym
->result
== proc_sym
)
4501 if (!current_fake_result_decl
)
4503 gfc_entry_list
*el
= NULL
;
4504 if (proc_sym
->attr
.entry_master
)
4506 for (el
= proc_sym
->ns
->entries
; el
; el
= el
->next
)
4507 if (el
->sym
!= el
->sym
->result
)
4510 /* TODO: move to the appropriate place in resolve.c. */
4511 if (warn_return_type
> 0 && el
== NULL
)
4512 gfc_warning (OPT_Wreturn_type
,
4513 "Return value of function %qs at %L not set",
4514 proc_sym
->name
, &proc_sym
->declared_at
);
4516 else if (proc_sym
->as
)
4518 tree result
= TREE_VALUE (current_fake_result_decl
);
4519 gfc_save_backend_locus (&loc
);
4520 gfc_set_backend_locus (&proc_sym
->declared_at
);
4521 gfc_trans_dummy_array_bias (proc_sym
, result
, block
);
4523 /* An automatic character length, pointer array result. */
4524 if (proc_sym
->ts
.type
== BT_CHARACTER
4525 && VAR_P (proc_sym
->ts
.u
.cl
->backend_decl
))
4528 if (proc_sym
->ts
.deferred
)
4530 gfc_start_block (&init
);
4531 tmp
= gfc_null_and_pass_deferred_len (proc_sym
, &init
, &loc
);
4532 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), tmp
);
4535 gfc_trans_dummy_character (proc_sym
, proc_sym
->ts
.u
.cl
, block
);
4538 else if (proc_sym
->ts
.type
== BT_CHARACTER
)
4540 if (proc_sym
->ts
.deferred
)
4543 gfc_save_backend_locus (&loc
);
4544 gfc_set_backend_locus (&proc_sym
->declared_at
);
4545 gfc_start_block (&init
);
4546 /* Zero the string length on entry. */
4547 gfc_add_modify (&init
, proc_sym
->ts
.u
.cl
->backend_decl
,
4548 build_int_cst (gfc_charlen_type_node
, 0));
4549 /* Null the pointer. */
4550 e
= gfc_lval_expr_from_sym (proc_sym
);
4551 gfc_init_se (&se
, NULL
);
4552 se
.want_pointer
= 1;
4553 gfc_conv_expr (&se
, e
);
4556 gfc_add_modify (&init
, tmp
,
4557 fold_convert (TREE_TYPE (se
.expr
),
4558 null_pointer_node
));
4559 gfc_restore_backend_locus (&loc
);
4561 /* Pass back the string length on exit. */
4562 tmp
= proc_sym
->ts
.u
.cl
->backend_decl
;
4563 if (TREE_CODE (tmp
) != INDIRECT_REF
4564 && proc_sym
->ts
.u
.cl
->passed_length
)
4566 tmp
= proc_sym
->ts
.u
.cl
->passed_length
;
4567 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
4568 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
4569 TREE_TYPE (tmp
), tmp
,
4572 proc_sym
->ts
.u
.cl
->backend_decl
));
4577 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), tmp
);
4579 else if (VAR_P (proc_sym
->ts
.u
.cl
->backend_decl
))
4580 gfc_trans_dummy_character (proc_sym
, proc_sym
->ts
.u
.cl
, block
);
4583 gcc_assert (flag_f2c
&& proc_sym
->ts
.type
== BT_COMPLEX
);
4585 else if (proc_sym
== proc_sym
->result
&& IS_CLASS_ARRAY (proc_sym
))
4587 /* Nullify explicit return class arrays on entry. */
4589 tmp
= get_proc_result (proc_sym
);
4590 if (tmp
&& GFC_CLASS_TYPE_P (TREE_TYPE (tmp
)))
4592 gfc_start_block (&init
);
4593 tmp
= gfc_class_data_get (tmp
);
4594 type
= TREE_TYPE (gfc_conv_descriptor_data_get (tmp
));
4595 gfc_conv_descriptor_data_set (&init
, tmp
, build_int_cst (type
, 0));
4596 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
4601 /* Initialize the INTENT(OUT) derived type dummy arguments. This
4602 should be done here so that the offsets and lbounds of arrays
4604 gfc_save_backend_locus (&loc
);
4605 gfc_set_backend_locus (&proc_sym
->declared_at
);
4606 init_intent_out_dt (proc_sym
, block
);
4607 gfc_restore_backend_locus (&loc
);
4609 for (sym
= proc_sym
->tlink
; sym
!= proc_sym
; sym
= sym
->tlink
)
4611 bool alloc_comp_or_fini
= (sym
->ts
.type
== BT_DERIVED
)
4612 && (sym
->ts
.u
.derived
->attr
.alloc_comp
4613 || gfc_is_finalizable (sym
->ts
.u
.derived
,
4618 if (sym
->ts
.type
== BT_DERIVED
4619 && sym
->ts
.u
.derived
4620 && sym
->ts
.u
.derived
->attr
.pdt_type
)
4623 gfc_init_block (&tmpblock
);
4624 if (!(sym
->attr
.dummy
4625 || sym
->attr
.pointer
4626 || sym
->attr
.allocatable
))
4628 tmp
= gfc_allocate_pdt_comp (sym
->ts
.u
.derived
,
4630 sym
->as
? sym
->as
->rank
: 0,
4632 gfc_add_expr_to_block (&tmpblock
, tmp
);
4633 if (!sym
->attr
.result
)
4634 tmp
= gfc_deallocate_pdt_comp (sym
->ts
.u
.derived
,
4636 sym
->as
? sym
->as
->rank
: 0);
4639 gfc_add_init_cleanup (block
, gfc_finish_block (&tmpblock
), tmp
);
4641 else if (sym
->attr
.dummy
)
4643 tmp
= gfc_check_pdt_dummy (sym
->ts
.u
.derived
,
4645 sym
->as
? sym
->as
->rank
: 0,
4647 gfc_add_expr_to_block (&tmpblock
, tmp
);
4648 gfc_add_init_cleanup (block
, gfc_finish_block (&tmpblock
), NULL
);
4651 else if (sym
->ts
.type
== BT_CLASS
4652 && CLASS_DATA (sym
)->ts
.u
.derived
4653 && CLASS_DATA (sym
)->ts
.u
.derived
->attr
.pdt_type
)
4655 gfc_component
*data
= CLASS_DATA (sym
);
4657 gfc_init_block (&tmpblock
);
4658 if (!(sym
->attr
.dummy
4659 || CLASS_DATA (sym
)->attr
.pointer
4660 || CLASS_DATA (sym
)->attr
.allocatable
))
4662 tmp
= gfc_class_data_get (sym
->backend_decl
);
4663 tmp
= gfc_allocate_pdt_comp (data
->ts
.u
.derived
, tmp
,
4664 data
->as
? data
->as
->rank
: 0,
4666 gfc_add_expr_to_block (&tmpblock
, tmp
);
4667 tmp
= gfc_class_data_get (sym
->backend_decl
);
4668 if (!sym
->attr
.result
)
4669 tmp
= gfc_deallocate_pdt_comp (data
->ts
.u
.derived
, tmp
,
4670 data
->as
? data
->as
->rank
: 0);
4673 gfc_add_init_cleanup (block
, gfc_finish_block (&tmpblock
), tmp
);
4675 else if (sym
->attr
.dummy
)
4677 tmp
= gfc_class_data_get (sym
->backend_decl
);
4678 tmp
= gfc_check_pdt_dummy (data
->ts
.u
.derived
, tmp
,
4679 data
->as
? data
->as
->rank
: 0,
4681 gfc_add_expr_to_block (&tmpblock
, tmp
);
4682 gfc_add_init_cleanup (block
, gfc_finish_block (&tmpblock
), NULL
);
4686 if (sym
->attr
.pointer
&& sym
->attr
.dimension
4687 && sym
->attr
.save
== SAVE_NONE
4688 && !sym
->attr
.use_assoc
4689 && !sym
->attr
.host_assoc
4691 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym
->backend_decl
)))
4693 gfc_init_block (&tmpblock
);
4694 gfc_conv_descriptor_span_set (&tmpblock
, sym
->backend_decl
,
4695 build_int_cst (gfc_array_index_type
, 0));
4696 gfc_add_init_cleanup (block
, gfc_finish_block (&tmpblock
),
4700 if (sym
->ts
.type
== BT_CLASS
4701 && (sym
->attr
.save
|| flag_max_stack_var_size
== 0)
4702 && CLASS_DATA (sym
)->attr
.allocatable
)
4706 if (UNLIMITED_POLY (sym
))
4707 vptr
= null_pointer_node
;
4711 vsym
= gfc_find_derived_vtab (sym
->ts
.u
.derived
);
4712 vptr
= gfc_get_symbol_decl (vsym
);
4713 vptr
= gfc_build_addr_expr (NULL
, vptr
);
4716 if (CLASS_DATA (sym
)->attr
.dimension
4717 || (CLASS_DATA (sym
)->attr
.codimension
4718 && flag_coarray
!= GFC_FCOARRAY_LIB
))
4720 tmp
= gfc_class_data_get (sym
->backend_decl
);
4721 tmp
= gfc_build_null_descriptor (TREE_TYPE (tmp
));
4724 tmp
= null_pointer_node
;
4726 DECL_INITIAL (sym
->backend_decl
)
4727 = gfc_class_set_static_fields (sym
->backend_decl
, vptr
, tmp
);
4728 TREE_CONSTANT (DECL_INITIAL (sym
->backend_decl
)) = 1;
4730 else if ((sym
->attr
.dimension
|| sym
->attr
.codimension
4731 || (IS_CLASS_ARRAY (sym
) && !CLASS_DATA (sym
)->attr
.allocatable
)))
4733 bool is_classarray
= IS_CLASS_ARRAY (sym
);
4734 symbol_attribute
*array_attr
;
4736 array_type type_of_array
;
4738 array_attr
= is_classarray
? &CLASS_DATA (sym
)->attr
: &sym
->attr
;
4739 as
= is_classarray
? CLASS_DATA (sym
)->as
: sym
->as
;
4740 /* Assumed-size Cray pointees need to be treated as AS_EXPLICIT. */
4741 type_of_array
= as
->type
;
4742 if (type_of_array
== AS_ASSUMED_SIZE
&& as
->cp_was_assumed
)
4743 type_of_array
= AS_EXPLICIT
;
4744 switch (type_of_array
)
4747 if (sym
->attr
.dummy
|| sym
->attr
.result
)
4748 gfc_trans_dummy_array_bias (sym
, sym
->backend_decl
, block
);
4749 /* Allocatable and pointer arrays need to processed
4751 else if ((sym
->ts
.type
!= BT_CLASS
&& sym
->attr
.pointer
)
4752 || (sym
->ts
.type
== BT_CLASS
4753 && CLASS_DATA (sym
)->attr
.class_pointer
)
4754 || array_attr
->allocatable
)
4756 if (TREE_STATIC (sym
->backend_decl
))
4758 gfc_save_backend_locus (&loc
);
4759 gfc_set_backend_locus (&sym
->declared_at
);
4760 gfc_trans_static_array_pointer (sym
);
4761 gfc_restore_backend_locus (&loc
);
4765 seen_trans_deferred_array
= true;
4766 gfc_trans_deferred_array (sym
, block
);
4769 else if (sym
->attr
.codimension
4770 && TREE_STATIC (sym
->backend_decl
))
4772 gfc_init_block (&tmpblock
);
4773 gfc_trans_array_cobounds (TREE_TYPE (sym
->backend_decl
),
4775 gfc_add_init_cleanup (block
, gfc_finish_block (&tmpblock
),
4781 gfc_save_backend_locus (&loc
);
4782 gfc_set_backend_locus (&sym
->declared_at
);
4784 if (alloc_comp_or_fini
)
4786 seen_trans_deferred_array
= true;
4787 gfc_trans_deferred_array (sym
, block
);
4789 else if (sym
->ts
.type
== BT_DERIVED
4792 && sym
->attr
.save
== SAVE_NONE
)
4794 gfc_start_block (&tmpblock
);
4795 gfc_init_default_dt (sym
, &tmpblock
, false);
4796 gfc_add_init_cleanup (block
,
4797 gfc_finish_block (&tmpblock
),
4801 gfc_trans_auto_array_allocation (sym
->backend_decl
,
4803 gfc_restore_backend_locus (&loc
);
4807 case AS_ASSUMED_SIZE
:
4808 /* Must be a dummy parameter. */
4809 gcc_assert (sym
->attr
.dummy
|| as
->cp_was_assumed
);
4811 /* We should always pass assumed size arrays the g77 way. */
4812 if (sym
->attr
.dummy
)
4813 gfc_trans_g77_array (sym
, block
);
4816 case AS_ASSUMED_SHAPE
:
4817 /* Must be a dummy parameter. */
4818 gcc_assert (sym
->attr
.dummy
);
4820 gfc_trans_dummy_array_bias (sym
, sym
->backend_decl
, block
);
4823 case AS_ASSUMED_RANK
:
4825 seen_trans_deferred_array
= true;
4826 gfc_trans_deferred_array (sym
, block
);
4827 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.deferred
4828 && sym
->attr
.result
)
4830 gfc_start_block (&init
);
4831 gfc_save_backend_locus (&loc
);
4832 gfc_set_backend_locus (&sym
->declared_at
);
4833 tmp
= gfc_null_and_pass_deferred_len (sym
, &init
, &loc
);
4834 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), tmp
);
4841 if (alloc_comp_or_fini
&& !seen_trans_deferred_array
)
4842 gfc_trans_deferred_array (sym
, block
);
4844 else if ((!sym
->attr
.dummy
|| sym
->ts
.deferred
)
4845 && (sym
->ts
.type
== BT_CLASS
4846 && CLASS_DATA (sym
)->attr
.class_pointer
))
4848 else if ((!sym
->attr
.dummy
|| sym
->ts
.deferred
)
4849 && (sym
->attr
.allocatable
4850 || (sym
->attr
.pointer
&& sym
->attr
.result
)
4851 || (sym
->ts
.type
== BT_CLASS
4852 && CLASS_DATA (sym
)->attr
.allocatable
)))
4854 if (!sym
->attr
.save
&& flag_max_stack_var_size
!= 0)
4856 tree descriptor
= NULL_TREE
;
4858 gfc_save_backend_locus (&loc
);
4859 gfc_set_backend_locus (&sym
->declared_at
);
4860 gfc_start_block (&init
);
4862 if (sym
->ts
.type
== BT_CHARACTER
4863 && sym
->attr
.allocatable
4864 && !sym
->attr
.dimension
4865 && sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
4866 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_VARIABLE
)
4867 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
4869 if (!sym
->attr
.pointer
)
4871 /* Nullify and automatic deallocation of allocatable
4873 e
= gfc_lval_expr_from_sym (sym
);
4874 if (sym
->ts
.type
== BT_CLASS
)
4875 gfc_add_data_component (e
);
4877 gfc_init_se (&se
, NULL
);
4878 if (sym
->ts
.type
!= BT_CLASS
4879 || sym
->ts
.u
.derived
->attr
.dimension
4880 || sym
->ts
.u
.derived
->attr
.codimension
)
4882 se
.want_pointer
= 1;
4883 gfc_conv_expr (&se
, e
);
4885 else if (sym
->ts
.type
== BT_CLASS
4886 && !CLASS_DATA (sym
)->attr
.dimension
4887 && !CLASS_DATA (sym
)->attr
.codimension
)
4889 se
.want_pointer
= 1;
4890 gfc_conv_expr (&se
, e
);
4894 se
.descriptor_only
= 1;
4895 gfc_conv_expr (&se
, e
);
4896 descriptor
= se
.expr
;
4897 se
.expr
= gfc_conv_descriptor_data_addr (se
.expr
);
4898 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
4902 if (!sym
->attr
.dummy
|| sym
->attr
.intent
== INTENT_OUT
)
4904 /* Nullify when entering the scope. */
4905 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
4906 TREE_TYPE (se
.expr
), se
.expr
,
4907 fold_convert (TREE_TYPE (se
.expr
),
4908 null_pointer_node
));
4909 if (sym
->attr
.optional
)
4911 tree present
= gfc_conv_expr_present (sym
);
4912 tmp
= build3_loc (input_location
, COND_EXPR
,
4913 void_type_node
, present
, tmp
,
4914 build_empty_stmt (input_location
));
4916 gfc_add_expr_to_block (&init
, tmp
);
4920 if ((sym
->attr
.dummy
|| sym
->attr
.result
)
4921 && sym
->ts
.type
== BT_CHARACTER
4923 && sym
->ts
.u
.cl
->passed_length
)
4924 tmp
= gfc_null_and_pass_deferred_len (sym
, &init
, &loc
);
4927 gfc_restore_backend_locus (&loc
);
4931 /* Deallocate when leaving the scope. Nullifying is not
4933 if (!sym
->attr
.result
&& !sym
->attr
.dummy
&& !sym
->attr
.pointer
4934 && !sym
->ns
->proc_name
->attr
.is_main_program
)
4936 if (sym
->ts
.type
== BT_CLASS
4937 && CLASS_DATA (sym
)->attr
.codimension
)
4938 tmp
= gfc_deallocate_with_status (descriptor
, NULL_TREE
,
4939 NULL_TREE
, NULL_TREE
,
4940 NULL_TREE
, true, NULL
,
4941 GFC_CAF_COARRAY_ANALYZE
);
4944 gfc_expr
*expr
= gfc_lval_expr_from_sym (sym
);
4945 tmp
= gfc_deallocate_scalar_with_status (se
.expr
,
4950 gfc_free_expr (expr
);
4954 if (sym
->ts
.type
== BT_CLASS
)
4956 /* Initialize _vptr to declared type. */
4960 gfc_save_backend_locus (&loc
);
4961 gfc_set_backend_locus (&sym
->declared_at
);
4962 e
= gfc_lval_expr_from_sym (sym
);
4963 gfc_add_vptr_component (e
);
4964 gfc_init_se (&se
, NULL
);
4965 se
.want_pointer
= 1;
4966 gfc_conv_expr (&se
, e
);
4968 if (UNLIMITED_POLY (sym
))
4969 rhs
= build_int_cst (TREE_TYPE (se
.expr
), 0);
4972 vtab
= gfc_find_derived_vtab (sym
->ts
.u
.derived
);
4973 rhs
= gfc_build_addr_expr (TREE_TYPE (se
.expr
),
4974 gfc_get_symbol_decl (vtab
));
4976 gfc_add_modify (&init
, se
.expr
, rhs
);
4977 gfc_restore_backend_locus (&loc
);
4980 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), tmp
);
4983 else if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.deferred
)
4988 /* If we get to here, all that should be left are pointers. */
4989 gcc_assert (sym
->attr
.pointer
);
4991 if (sym
->attr
.dummy
)
4993 gfc_start_block (&init
);
4994 gfc_save_backend_locus (&loc
);
4995 gfc_set_backend_locus (&sym
->declared_at
);
4996 tmp
= gfc_null_and_pass_deferred_len (sym
, &init
, &loc
);
4997 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), tmp
);
5000 else if (sym
->ts
.deferred
)
5001 gfc_fatal_error ("Deferred type parameter not yet supported");
5002 else if (alloc_comp_or_fini
)
5003 gfc_trans_deferred_array (sym
, block
);
5004 else if (sym
->ts
.type
== BT_CHARACTER
)
5006 gfc_save_backend_locus (&loc
);
5007 gfc_set_backend_locus (&sym
->declared_at
);
5008 if (sym
->attr
.dummy
|| sym
->attr
.result
)
5009 gfc_trans_dummy_character (sym
, sym
->ts
.u
.cl
, block
);
5011 gfc_trans_auto_character_variable (sym
, block
);
5012 gfc_restore_backend_locus (&loc
);
5014 else if (sym
->attr
.assign
)
5016 gfc_save_backend_locus (&loc
);
5017 gfc_set_backend_locus (&sym
->declared_at
);
5018 gfc_trans_assign_aux_var (sym
, block
);
5019 gfc_restore_backend_locus (&loc
);
5021 else if (sym
->ts
.type
== BT_DERIVED
5024 && sym
->attr
.save
== SAVE_NONE
)
5026 gfc_start_block (&tmpblock
);
5027 gfc_init_default_dt (sym
, &tmpblock
, false);
5028 gfc_add_init_cleanup (block
, gfc_finish_block (&tmpblock
),
5031 else if (!(UNLIMITED_POLY(sym
)) && !is_pdt_type
)
5034 /* Assumed shape and assumed rank arrays are passed to BIND(C) procedures
5035 as ISO Fortran Interop descriptors. These have to be converted to
5036 gfortran descriptors and back again. This has to be done here so that
5037 the conversion occurs at the start of the init block. */
5038 if (is_CFI_desc (sym
, NULL
))
5039 convert_CFI_desc (block
, sym
);
5042 gfc_init_block (&tmpblock
);
5044 for (f
= gfc_sym_get_dummy_args (proc_sym
); f
; f
= f
->next
)
5046 if (f
->sym
&& f
->sym
->tlink
== NULL
&& f
->sym
->ts
.type
== BT_CHARACTER
5047 && f
->sym
->ts
.u
.cl
->backend_decl
)
5049 if (TREE_CODE (f
->sym
->ts
.u
.cl
->backend_decl
) == PARM_DECL
)
5050 gfc_trans_vla_type_sizes (f
->sym
, &tmpblock
);
5054 if (gfc_return_by_reference (proc_sym
) && proc_sym
->ts
.type
== BT_CHARACTER
5055 && current_fake_result_decl
!= NULL
)
5057 gcc_assert (proc_sym
->ts
.u
.cl
->backend_decl
!= NULL
);
5058 if (TREE_CODE (proc_sym
->ts
.u
.cl
->backend_decl
) == PARM_DECL
)
5059 gfc_trans_vla_type_sizes (proc_sym
, &tmpblock
);
5062 gfc_add_init_cleanup (block
, gfc_finish_block (&tmpblock
), NULL_TREE
);
5066 struct module_hasher
: ggc_ptr_hash
<module_htab_entry
>
5068 typedef const char *compare_type
;
5070 static hashval_t
hash (module_htab_entry
*s
)
5072 return htab_hash_string (s
->name
);
5076 equal (module_htab_entry
*a
, const char *b
)
5078 return !strcmp (a
->name
, b
);
5082 static GTY (()) hash_table
<module_hasher
> *module_htab
;
5084 /* Hash and equality functions for module_htab's decls. */
5087 module_decl_hasher::hash (tree t
)
5089 const_tree n
= DECL_NAME (t
);
5091 n
= TYPE_NAME (TREE_TYPE (t
));
5092 return htab_hash_string (IDENTIFIER_POINTER (n
));
5096 module_decl_hasher::equal (tree t1
, const char *x2
)
5098 const_tree n1
= DECL_NAME (t1
);
5099 if (n1
== NULL_TREE
)
5100 n1
= TYPE_NAME (TREE_TYPE (t1
));
5101 return strcmp (IDENTIFIER_POINTER (n1
), x2
) == 0;
5104 struct module_htab_entry
*
5105 gfc_find_module (const char *name
)
5108 module_htab
= hash_table
<module_hasher
>::create_ggc (10);
5110 module_htab_entry
**slot
5111 = module_htab
->find_slot_with_hash (name
, htab_hash_string (name
), INSERT
);
5114 module_htab_entry
*entry
= ggc_cleared_alloc
<module_htab_entry
> ();
5116 entry
->name
= gfc_get_string ("%s", name
);
5117 entry
->decls
= hash_table
<module_decl_hasher
>::create_ggc (10);
5124 gfc_module_add_decl (struct module_htab_entry
*entry
, tree decl
)
5128 if (DECL_NAME (decl
))
5129 name
= IDENTIFIER_POINTER (DECL_NAME (decl
));
5132 gcc_assert (TREE_CODE (decl
) == TYPE_DECL
);
5133 name
= IDENTIFIER_POINTER (TYPE_NAME (TREE_TYPE (decl
)));
5136 = entry
->decls
->find_slot_with_hash (name
, htab_hash_string (name
),
5143 /* Generate debugging symbols for namelists. This function must come after
5144 generate_local_decl to ensure that the variables in the namelist are
5145 already declared. */
5148 generate_namelist_decl (gfc_symbol
* sym
)
5152 vec
<constructor_elt
, va_gc
> *nml_decls
= NULL
;
5154 gcc_assert (sym
->attr
.flavor
== FL_NAMELIST
);
5155 for (nml
= sym
->namelist
; nml
; nml
= nml
->next
)
5157 if (nml
->sym
->backend_decl
== NULL_TREE
)
5159 nml
->sym
->attr
.referenced
= 1;
5160 nml
->sym
->backend_decl
= gfc_get_symbol_decl (nml
->sym
);
5162 DECL_IGNORED_P (nml
->sym
->backend_decl
) = 0;
5163 CONSTRUCTOR_APPEND_ELT (nml_decls
, NULL_TREE
, nml
->sym
->backend_decl
);
5166 decl
= make_node (NAMELIST_DECL
);
5167 TREE_TYPE (decl
) = void_type_node
;
5168 NAMELIST_DECL_ASSOCIATED_DECL (decl
) = build_constructor (NULL_TREE
, nml_decls
);
5169 DECL_NAME (decl
) = get_identifier (sym
->name
);
5174 /* Output an initialized decl for a module variable. */
5177 gfc_create_module_variable (gfc_symbol
* sym
)
5181 /* Module functions with alternate entries are dealt with later and
5182 would get caught by the next condition. */
5183 if (sym
->attr
.entry
)
5186 /* Make sure we convert the types of the derived types from iso_c_binding
5188 if (sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.is_iso_c
5189 && sym
->ts
.type
== BT_DERIVED
)
5190 sym
->backend_decl
= gfc_typenode_for_spec (&(sym
->ts
));
5192 if (gfc_fl_struct (sym
->attr
.flavor
)
5193 && sym
->backend_decl
5194 && TREE_CODE (sym
->backend_decl
) == RECORD_TYPE
)
5196 decl
= sym
->backend_decl
;
5197 gcc_assert (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
);
5199 if (!sym
->attr
.use_assoc
&& !sym
->attr
.used_in_submodule
)
5201 gcc_assert (TYPE_CONTEXT (decl
) == NULL_TREE
5202 || TYPE_CONTEXT (decl
) == sym
->ns
->proc_name
->backend_decl
);
5203 gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl
)) == NULL_TREE
5204 || DECL_CONTEXT (TYPE_STUB_DECL (decl
))
5205 == sym
->ns
->proc_name
->backend_decl
);
5207 TYPE_CONTEXT (decl
) = sym
->ns
->proc_name
->backend_decl
;
5208 DECL_CONTEXT (TYPE_STUB_DECL (decl
)) = sym
->ns
->proc_name
->backend_decl
;
5209 gfc_module_add_decl (cur_module
, TYPE_STUB_DECL (decl
));
5212 /* Only output variables, procedure pointers and array valued,
5213 or derived type, parameters. */
5214 if (sym
->attr
.flavor
!= FL_VARIABLE
5215 && !(sym
->attr
.flavor
== FL_PARAMETER
5216 && (sym
->attr
.dimension
|| sym
->ts
.type
== BT_DERIVED
))
5217 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc_pointer
))
5220 if ((sym
->attr
.in_common
|| sym
->attr
.in_equivalence
) && sym
->backend_decl
)
5222 decl
= sym
->backend_decl
;
5223 gcc_assert (DECL_FILE_SCOPE_P (decl
));
5224 gcc_assert (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
);
5225 DECL_CONTEXT (decl
) = sym
->ns
->proc_name
->backend_decl
;
5226 gfc_module_add_decl (cur_module
, decl
);
5229 /* Don't generate variables from other modules. Variables from
5230 COMMONs and Cray pointees will already have been generated. */
5231 if (sym
->attr
.use_assoc
|| sym
->attr
.used_in_submodule
5232 || sym
->attr
.in_common
|| sym
->attr
.cray_pointee
)
5235 /* Equivalenced variables arrive here after creation. */
5236 if (sym
->backend_decl
5237 && (sym
->equiv_built
|| sym
->attr
.in_equivalence
))
5240 if (sym
->backend_decl
&& !sym
->attr
.vtab
&& !sym
->attr
.target
)
5241 gfc_internal_error ("backend decl for module variable %qs already exists",
5244 if (sym
->module
&& !sym
->attr
.result
&& !sym
->attr
.dummy
5245 && (sym
->attr
.access
== ACCESS_UNKNOWN
5246 && (sym
->ns
->default_access
== ACCESS_PRIVATE
5247 || (sym
->ns
->default_access
== ACCESS_UNKNOWN
5248 && flag_module_private
))))
5249 sym
->attr
.access
= ACCESS_PRIVATE
;
5251 if (warn_unused_variable
&& !sym
->attr
.referenced
5252 && sym
->attr
.access
== ACCESS_PRIVATE
)
5253 gfc_warning (OPT_Wunused_value
,
5254 "Unused PRIVATE module variable %qs declared at %L",
5255 sym
->name
, &sym
->declared_at
);
5257 /* We always want module variables to be created. */
5258 sym
->attr
.referenced
= 1;
5259 /* Create the decl. */
5260 decl
= gfc_get_symbol_decl (sym
);
5262 /* Create the variable. */
5264 gcc_assert (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
5265 || (sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
5266 && sym
->fn_result_spec
));
5267 DECL_CONTEXT (decl
) = sym
->ns
->proc_name
->backend_decl
;
5268 rest_of_decl_compilation (decl
, 1, 0);
5269 gfc_module_add_decl (cur_module
, decl
);
5271 /* Also add length of strings. */
5272 if (sym
->ts
.type
== BT_CHARACTER
)
5276 length
= sym
->ts
.u
.cl
->backend_decl
;
5277 gcc_assert (length
|| sym
->attr
.proc_pointer
);
5278 if (length
&& !INTEGER_CST_P (length
))
5281 rest_of_decl_compilation (length
, 1, 0);
5285 if (sym
->attr
.codimension
&& !sym
->attr
.dummy
&& !sym
->attr
.allocatable
5286 && sym
->attr
.referenced
&& !sym
->attr
.use_assoc
)
5287 has_coarray_vars
= true;
5290 /* Emit debug information for USE statements. */
5293 gfc_trans_use_stmts (gfc_namespace
* ns
)
5295 gfc_use_list
*use_stmt
;
5296 for (use_stmt
= ns
->use_stmts
; use_stmt
; use_stmt
= use_stmt
->next
)
5298 struct module_htab_entry
*entry
5299 = gfc_find_module (use_stmt
->module_name
);
5300 gfc_use_rename
*rent
;
5302 if (entry
->namespace_decl
== NULL
)
5304 entry
->namespace_decl
5305 = build_decl (input_location
,
5307 get_identifier (use_stmt
->module_name
),
5309 DECL_EXTERNAL (entry
->namespace_decl
) = 1;
5311 gfc_set_backend_locus (&use_stmt
->where
);
5312 if (!use_stmt
->only_flag
)
5313 (*debug_hooks
->imported_module_or_decl
) (entry
->namespace_decl
,
5315 ns
->proc_name
->backend_decl
,
5317 for (rent
= use_stmt
->rename
; rent
; rent
= rent
->next
)
5319 tree decl
, local_name
;
5321 if (rent
->op
!= INTRINSIC_NONE
)
5324 hashval_t hash
= htab_hash_string (rent
->use_name
);
5325 tree
*slot
= entry
->decls
->find_slot_with_hash (rent
->use_name
, hash
,
5331 st
= gfc_find_symtree (ns
->sym_root
,
5333 ? rent
->local_name
: rent
->use_name
);
5335 /* The following can happen if a derived type is renamed. */
5339 name
= xstrdup (rent
->local_name
[0]
5340 ? rent
->local_name
: rent
->use_name
);
5341 name
[0] = (char) TOUPPER ((unsigned char) name
[0]);
5342 st
= gfc_find_symtree (ns
->sym_root
, name
);
5347 /* Sometimes, generic interfaces wind up being over-ruled by a
5348 local symbol (see PR41062). */
5349 if (!st
->n
.sym
->attr
.use_assoc
)
5352 if (st
->n
.sym
->backend_decl
5353 && DECL_P (st
->n
.sym
->backend_decl
)
5354 && st
->n
.sym
->module
5355 && strcmp (st
->n
.sym
->module
, use_stmt
->module_name
) == 0)
5357 gcc_assert (DECL_EXTERNAL (entry
->namespace_decl
)
5358 || !VAR_P (st
->n
.sym
->backend_decl
));
5359 decl
= copy_node (st
->n
.sym
->backend_decl
);
5360 DECL_CONTEXT (decl
) = entry
->namespace_decl
;
5361 DECL_EXTERNAL (decl
) = 1;
5362 DECL_IGNORED_P (decl
) = 0;
5363 DECL_INITIAL (decl
) = NULL_TREE
;
5365 else if (st
->n
.sym
->attr
.flavor
== FL_NAMELIST
5366 && st
->n
.sym
->attr
.use_only
5367 && st
->n
.sym
->module
5368 && strcmp (st
->n
.sym
->module
, use_stmt
->module_name
)
5371 decl
= generate_namelist_decl (st
->n
.sym
);
5372 DECL_CONTEXT (decl
) = entry
->namespace_decl
;
5373 DECL_EXTERNAL (decl
) = 1;
5374 DECL_IGNORED_P (decl
) = 0;
5375 DECL_INITIAL (decl
) = NULL_TREE
;
5379 *slot
= error_mark_node
;
5380 entry
->decls
->clear_slot (slot
);
5385 decl
= (tree
) *slot
;
5386 if (rent
->local_name
[0])
5387 local_name
= get_identifier (rent
->local_name
);
5389 local_name
= NULL_TREE
;
5390 gfc_set_backend_locus (&rent
->where
);
5391 (*debug_hooks
->imported_module_or_decl
) (decl
, local_name
,
5392 ns
->proc_name
->backend_decl
,
5393 !use_stmt
->only_flag
,
5400 /* Return true if expr is a constant initializer that gfc_conv_initializer
5404 check_constant_initializer (gfc_expr
*expr
, gfc_typespec
*ts
, bool array
,
5414 if (expr
->expr_type
== EXPR_CONSTANT
|| expr
->expr_type
== EXPR_NULL
)
5416 else if (expr
->expr_type
== EXPR_STRUCTURE
)
5417 return check_constant_initializer (expr
, ts
, false, false);
5418 else if (expr
->expr_type
!= EXPR_ARRAY
)
5420 for (c
= gfc_constructor_first (expr
->value
.constructor
);
5421 c
; c
= gfc_constructor_next (c
))
5425 if (c
->expr
->expr_type
== EXPR_STRUCTURE
)
5427 if (!check_constant_initializer (c
->expr
, ts
, false, false))
5430 else if (c
->expr
->expr_type
!= EXPR_CONSTANT
)
5435 else switch (ts
->type
)
5438 if (expr
->expr_type
!= EXPR_STRUCTURE
)
5440 cm
= expr
->ts
.u
.derived
->components
;
5441 for (c
= gfc_constructor_first (expr
->value
.constructor
);
5442 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
5444 if (!c
->expr
|| cm
->attr
.allocatable
)
5446 if (!check_constant_initializer (c
->expr
, &cm
->ts
,
5453 return expr
->expr_type
== EXPR_CONSTANT
;
5457 /* Emit debug info for parameters and unreferenced variables with
5461 gfc_emit_parameter_debug_info (gfc_symbol
*sym
)
5465 if (sym
->attr
.flavor
!= FL_PARAMETER
5466 && (sym
->attr
.flavor
!= FL_VARIABLE
|| sym
->attr
.referenced
))
5469 if (sym
->backend_decl
!= NULL
5470 || sym
->value
== NULL
5471 || sym
->attr
.use_assoc
5474 || sym
->attr
.function
5475 || sym
->attr
.intrinsic
5476 || sym
->attr
.pointer
5477 || sym
->attr
.allocatable
5478 || sym
->attr
.cray_pointee
5479 || sym
->attr
.threadprivate
5480 || sym
->attr
.is_bind_c
5481 || sym
->attr
.subref_array_pointer
5482 || sym
->attr
.assign
)
5485 if (sym
->ts
.type
== BT_CHARACTER
)
5487 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
5488 if (sym
->ts
.u
.cl
->backend_decl
== NULL
5489 || TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) != INTEGER_CST
)
5492 else if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.alloc_comp
)
5499 if (sym
->as
->type
!= AS_EXPLICIT
)
5501 for (n
= 0; n
< sym
->as
->rank
; n
++)
5502 if (sym
->as
->lower
[n
]->expr_type
!= EXPR_CONSTANT
5503 || sym
->as
->upper
[n
] == NULL
5504 || sym
->as
->upper
[n
]->expr_type
!= EXPR_CONSTANT
)
5508 if (!check_constant_initializer (sym
->value
, &sym
->ts
,
5509 sym
->attr
.dimension
, false))
5512 if (flag_coarray
== GFC_FCOARRAY_LIB
&& sym
->attr
.codimension
)
5515 /* Create the decl for the variable or constant. */
5516 decl
= build_decl (input_location
,
5517 sym
->attr
.flavor
== FL_PARAMETER
? CONST_DECL
: VAR_DECL
,
5518 gfc_sym_identifier (sym
), gfc_sym_type (sym
));
5519 if (sym
->attr
.flavor
== FL_PARAMETER
)
5520 TREE_READONLY (decl
) = 1;
5521 gfc_set_decl_location (decl
, &sym
->declared_at
);
5522 if (sym
->attr
.dimension
)
5523 GFC_DECL_PACKED_ARRAY (decl
) = 1;
5524 DECL_CONTEXT (decl
) = sym
->ns
->proc_name
->backend_decl
;
5525 TREE_STATIC (decl
) = 1;
5526 TREE_USED (decl
) = 1;
5527 if (DECL_CONTEXT (decl
) && TREE_CODE (DECL_CONTEXT (decl
)) == NAMESPACE_DECL
)
5528 TREE_PUBLIC (decl
) = 1;
5529 DECL_INITIAL (decl
) = gfc_conv_initializer (sym
->value
, &sym
->ts
,
5531 sym
->attr
.dimension
,
5533 debug_hooks
->early_global_decl (decl
);
5538 generate_coarray_sym_init (gfc_symbol
*sym
)
5540 tree tmp
, size
, decl
, token
, desc
;
5541 bool is_lock_type
, is_event_type
;
5544 symbol_attribute attr
;
5546 if (sym
->attr
.dummy
|| sym
->attr
.allocatable
|| !sym
->attr
.codimension
5547 || sym
->attr
.use_assoc
|| !sym
->attr
.referenced
5548 || sym
->attr
.select_type_temporary
)
5551 decl
= sym
->backend_decl
;
5552 TREE_USED(decl
) = 1;
5553 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
5555 is_lock_type
= sym
->ts
.type
== BT_DERIVED
5556 && sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
5557 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
;
5559 is_event_type
= sym
->ts
.type
== BT_DERIVED
5560 && sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
5561 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
;
5563 /* FIXME: Workaround for PR middle-end/49106, cf. also PR middle-end/49108
5564 to make sure the variable is not optimized away. */
5565 DECL_PRESERVE_P (DECL_CONTEXT (decl
)) = 1;
5567 /* For lock types, we pass the array size as only the library knows the
5568 size of the variable. */
5569 if (is_lock_type
|| is_event_type
)
5570 size
= gfc_index_one_node
;
5572 size
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (decl
)));
5574 /* Ensure that we do not have size=0 for zero-sized arrays. */
5575 size
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
5576 fold_convert (size_type_node
, size
),
5577 build_int_cst (size_type_node
, 1));
5579 if (GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl
)))
5581 tmp
= GFC_TYPE_ARRAY_SIZE (TREE_TYPE (decl
));
5582 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5583 fold_convert (size_type_node
, tmp
), size
);
5586 gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (decl
)) != NULL_TREE
);
5587 token
= gfc_build_addr_expr (ppvoid_type_node
,
5588 GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE(decl
)));
5590 reg_type
= sym
->attr
.artificial
? GFC_CAF_CRITICAL
: GFC_CAF_LOCK_STATIC
;
5591 else if (is_event_type
)
5592 reg_type
= GFC_CAF_EVENT_STATIC
;
5594 reg_type
= GFC_CAF_COARRAY_STATIC
;
5596 /* Compile the symbol attribute. */
5597 if (sym
->ts
.type
== BT_CLASS
)
5599 attr
= CLASS_DATA (sym
)->attr
;
5600 /* The pointer attribute is always set on classes, overwrite it with the
5601 class_pointer attribute, which denotes the pointer for classes. */
5602 attr
.pointer
= attr
.class_pointer
;
5606 gfc_init_se (&se
, NULL
);
5607 desc
= gfc_conv_scalar_to_descriptor (&se
, decl
, attr
);
5608 gfc_add_block_to_block (&caf_init_block
, &se
.pre
);
5610 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_register
, 7, size
,
5611 build_int_cst (integer_type_node
, reg_type
),
5612 token
, gfc_build_addr_expr (pvoid_type_node
, desc
),
5613 null_pointer_node
, /* stat. */
5614 null_pointer_node
, /* errgmsg. */
5615 build_zero_cst (size_type_node
)); /* errmsg_len. */
5616 gfc_add_expr_to_block (&caf_init_block
, tmp
);
5617 gfc_add_modify (&caf_init_block
, decl
, fold_convert (TREE_TYPE (decl
),
5618 gfc_conv_descriptor_data_get (desc
)));
5620 /* Handle "static" initializer. */
5623 if (sym
->value
->expr_type
== EXPR_ARRAY
)
5625 gfc_constructor
*c
, *cnext
;
5627 /* Test if the array has more than one element. */
5628 c
= gfc_constructor_first (sym
->value
->value
.constructor
);
5629 gcc_assert (c
); /* Empty constructor should not happen here. */
5630 cnext
= gfc_constructor_next (c
);
5634 /* An EXPR_ARRAY with a rank > 1 here has to come from a
5635 DATA statement. Set its rank here as not to confuse
5636 the following steps. */
5637 sym
->value
->rank
= 1;
5641 /* There is only a single value in the constructor, use
5642 it directly for the assignment. */
5644 new_expr
= gfc_copy_expr (c
->expr
);
5645 gfc_free_expr (sym
->value
);
5646 sym
->value
= new_expr
;
5650 sym
->attr
.pointer
= 1;
5651 tmp
= gfc_trans_assignment (gfc_lval_expr_from_sym (sym
), sym
->value
,
5653 sym
->attr
.pointer
= 0;
5654 gfc_add_expr_to_block (&caf_init_block
, tmp
);
5656 else if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.pointer_comp
)
5658 tmp
= gfc_nullify_alloc_comp (sym
->ts
.u
.derived
, decl
, sym
->as
5659 ? sym
->as
->rank
: 0,
5660 GFC_STRUCTURE_CAF_MODE_IN_COARRAY
);
5661 gfc_add_expr_to_block (&caf_init_block
, tmp
);
5666 /* Generate constructor function to initialize static, nonallocatable
5670 generate_coarray_init (gfc_namespace
* ns
__attribute((unused
)))
5672 tree fndecl
, tmp
, decl
, save_fn_decl
;
5674 save_fn_decl
= current_function_decl
;
5675 push_function_context ();
5677 tmp
= build_function_type_list (void_type_node
, NULL_TREE
);
5678 fndecl
= build_decl (input_location
, FUNCTION_DECL
,
5679 create_tmp_var_name ("_caf_init"), tmp
);
5681 DECL_STATIC_CONSTRUCTOR (fndecl
) = 1;
5682 SET_DECL_INIT_PRIORITY (fndecl
, DEFAULT_INIT_PRIORITY
);
5684 decl
= build_decl (input_location
, RESULT_DECL
, NULL_TREE
, void_type_node
);
5685 DECL_ARTIFICIAL (decl
) = 1;
5686 DECL_IGNORED_P (decl
) = 1;
5687 DECL_CONTEXT (decl
) = fndecl
;
5688 DECL_RESULT (fndecl
) = decl
;
5691 current_function_decl
= fndecl
;
5692 announce_function (fndecl
);
5694 rest_of_decl_compilation (fndecl
, 0, 0);
5695 make_decl_rtl (fndecl
);
5696 allocate_struct_function (fndecl
, false);
5699 gfc_init_block (&caf_init_block
);
5701 gfc_traverse_ns (ns
, generate_coarray_sym_init
);
5703 DECL_SAVED_TREE (fndecl
) = gfc_finish_block (&caf_init_block
);
5707 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl
)) = fndecl
;
5709 DECL_SAVED_TREE (fndecl
)
5710 = build3_v (BIND_EXPR
, decl
, DECL_SAVED_TREE (fndecl
),
5711 DECL_INITIAL (fndecl
));
5712 dump_function (TDI_original
, fndecl
);
5714 cfun
->function_end_locus
= input_location
;
5717 if (decl_function_context (fndecl
))
5718 (void) cgraph_node::create (fndecl
);
5720 cgraph_node::finalize_function (fndecl
, true);
5722 pop_function_context ();
5723 current_function_decl
= save_fn_decl
;
5728 create_module_nml_decl (gfc_symbol
*sym
)
5730 if (sym
->attr
.flavor
== FL_NAMELIST
)
5732 tree decl
= generate_namelist_decl (sym
);
5734 gcc_assert (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
);
5735 DECL_CONTEXT (decl
) = sym
->ns
->proc_name
->backend_decl
;
5736 rest_of_decl_compilation (decl
, 1, 0);
5737 gfc_module_add_decl (cur_module
, decl
);
5742 /* Generate all the required code for module variables. */
5745 gfc_generate_module_vars (gfc_namespace
* ns
)
5747 module_namespace
= ns
;
5748 cur_module
= gfc_find_module (ns
->proc_name
->name
);
5750 /* Check if the frontend left the namespace in a reasonable state. */
5751 gcc_assert (ns
->proc_name
&& !ns
->proc_name
->tlink
);
5753 /* Generate COMMON blocks. */
5754 gfc_trans_common (ns
);
5756 has_coarray_vars
= false;
5758 /* Create decls for all the module variables. */
5759 gfc_traverse_ns (ns
, gfc_create_module_variable
);
5760 gfc_traverse_ns (ns
, create_module_nml_decl
);
5762 if (flag_coarray
== GFC_FCOARRAY_LIB
&& has_coarray_vars
)
5763 generate_coarray_init (ns
);
5767 gfc_trans_use_stmts (ns
);
5768 gfc_traverse_ns (ns
, gfc_emit_parameter_debug_info
);
5773 gfc_generate_contained_functions (gfc_namespace
* parent
)
5777 /* We create all the prototypes before generating any code. */
5778 for (ns
= parent
->contained
; ns
; ns
= ns
->sibling
)
5780 /* Skip namespaces from used modules. */
5781 if (ns
->parent
!= parent
)
5784 gfc_create_function_decl (ns
, false);
5787 for (ns
= parent
->contained
; ns
; ns
= ns
->sibling
)
5789 /* Skip namespaces from used modules. */
5790 if (ns
->parent
!= parent
)
5793 gfc_generate_function_code (ns
);
5798 /* Drill down through expressions for the array specification bounds and
5799 character length calling generate_local_decl for all those variables
5800 that have not already been declared. */
5803 generate_local_decl (gfc_symbol
*);
5805 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
5808 expr_decls (gfc_expr
*e
, gfc_symbol
*sym
,
5809 int *f ATTRIBUTE_UNUSED
)
5811 if (e
->expr_type
!= EXPR_VARIABLE
5812 || sym
== e
->symtree
->n
.sym
5813 || e
->symtree
->n
.sym
->mark
5814 || e
->symtree
->n
.sym
->ns
!= sym
->ns
)
5817 generate_local_decl (e
->symtree
->n
.sym
);
5822 generate_expr_decls (gfc_symbol
*sym
, gfc_expr
*e
)
5824 gfc_traverse_expr (e
, sym
, expr_decls
, 0);
5828 /* Check for dependencies in the character length and array spec. */
5831 generate_dependency_declarations (gfc_symbol
*sym
)
5835 if (sym
->ts
.type
== BT_CHARACTER
5837 && sym
->ts
.u
.cl
->length
5838 && sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
5839 generate_expr_decls (sym
, sym
->ts
.u
.cl
->length
);
5841 if (sym
->as
&& sym
->as
->rank
)
5843 for (i
= 0; i
< sym
->as
->rank
; i
++)
5845 generate_expr_decls (sym
, sym
->as
->lower
[i
]);
5846 generate_expr_decls (sym
, sym
->as
->upper
[i
]);
5852 /* Generate decls for all local variables. We do this to ensure correct
5853 handling of expressions which only appear in the specification of
5857 generate_local_decl (gfc_symbol
* sym
)
5859 if (sym
->attr
.flavor
== FL_VARIABLE
)
5861 if (sym
->attr
.codimension
&& !sym
->attr
.dummy
&& !sym
->attr
.allocatable
5862 && sym
->attr
.referenced
&& !sym
->attr
.use_assoc
)
5863 has_coarray_vars
= true;
5865 if (!sym
->attr
.dummy
&& !sym
->ns
->proc_name
->attr
.entry_master
)
5866 generate_dependency_declarations (sym
);
5868 if (sym
->attr
.referenced
)
5869 gfc_get_symbol_decl (sym
);
5871 /* Warnings for unused dummy arguments. */
5872 else if (sym
->attr
.dummy
&& !sym
->attr
.in_namelist
)
5874 /* INTENT(out) dummy arguments are likely meant to be set. */
5875 if (warn_unused_dummy_argument
&& sym
->attr
.intent
== INTENT_OUT
)
5877 if (sym
->ts
.type
!= BT_DERIVED
)
5878 gfc_warning (OPT_Wunused_dummy_argument
,
5879 "Dummy argument %qs at %L was declared "
5880 "INTENT(OUT) but was not set", sym
->name
,
5882 else if (!gfc_has_default_initializer (sym
->ts
.u
.derived
)
5883 && !sym
->ts
.u
.derived
->attr
.zero_comp
)
5884 gfc_warning (OPT_Wunused_dummy_argument
,
5885 "Derived-type dummy argument %qs at %L was "
5886 "declared INTENT(OUT) but was not set and "
5887 "does not have a default initializer",
5888 sym
->name
, &sym
->declared_at
);
5889 if (sym
->backend_decl
!= NULL_TREE
)
5890 TREE_NO_WARNING(sym
->backend_decl
) = 1;
5892 else if (warn_unused_dummy_argument
)
5894 if (!sym
->attr
.artificial
)
5895 gfc_warning (OPT_Wunused_dummy_argument
,
5896 "Unused dummy argument %qs at %L", sym
->name
,
5899 if (sym
->backend_decl
!= NULL_TREE
)
5900 TREE_NO_WARNING(sym
->backend_decl
) = 1;
5904 /* Warn for unused variables, but not if they're inside a common
5905 block or a namelist. */
5906 else if (warn_unused_variable
5907 && !(sym
->attr
.in_common
|| sym
->mark
|| sym
->attr
.in_namelist
))
5909 if (sym
->attr
.use_only
)
5911 gfc_warning (OPT_Wunused_variable
,
5912 "Unused module variable %qs which has been "
5913 "explicitly imported at %L", sym
->name
,
5915 if (sym
->backend_decl
!= NULL_TREE
)
5916 TREE_NO_WARNING(sym
->backend_decl
) = 1;
5918 else if (!sym
->attr
.use_assoc
)
5920 /* Corner case: the symbol may be an entry point. At this point,
5921 it may appear to be an unused variable. Suppress warning. */
5925 for (el
= sym
->ns
->entries
; el
; el
=el
->next
)
5926 if (strcmp(sym
->name
, el
->sym
->name
) == 0)
5930 gfc_warning (OPT_Wunused_variable
,
5931 "Unused variable %qs declared at %L",
5932 sym
->name
, &sym
->declared_at
);
5933 if (sym
->backend_decl
!= NULL_TREE
)
5934 TREE_NO_WARNING(sym
->backend_decl
) = 1;
5938 /* For variable length CHARACTER parameters, the PARM_DECL already
5939 references the length variable, so force gfc_get_symbol_decl
5940 even when not referenced. If optimize > 0, it will be optimized
5941 away anyway. But do this only after emitting -Wunused-parameter
5942 warning if requested. */
5943 if (sym
->attr
.dummy
&& !sym
->attr
.referenced
5944 && sym
->ts
.type
== BT_CHARACTER
5945 && sym
->ts
.u
.cl
->backend_decl
!= NULL
5946 && VAR_P (sym
->ts
.u
.cl
->backend_decl
))
5948 sym
->attr
.referenced
= 1;
5949 gfc_get_symbol_decl (sym
);
5952 /* INTENT(out) dummy arguments and result variables with allocatable
5953 components are reset by default and need to be set referenced to
5954 generate the code for nullification and automatic lengths. */
5955 if (!sym
->attr
.referenced
5956 && sym
->ts
.type
== BT_DERIVED
5957 && sym
->ts
.u
.derived
->attr
.alloc_comp
5958 && !sym
->attr
.pointer
5959 && ((sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
)
5961 (sym
->attr
.result
&& sym
!= sym
->result
)))
5963 sym
->attr
.referenced
= 1;
5964 gfc_get_symbol_decl (sym
);
5967 /* Check for dependencies in the array specification and string
5968 length, adding the necessary declarations to the function. We
5969 mark the symbol now, as well as in traverse_ns, to prevent
5970 getting stuck in a circular dependency. */
5973 else if (sym
->attr
.flavor
== FL_PARAMETER
)
5975 if (warn_unused_parameter
5976 && !sym
->attr
.referenced
)
5978 if (!sym
->attr
.use_assoc
)
5979 gfc_warning (OPT_Wunused_parameter
,
5980 "Unused parameter %qs declared at %L", sym
->name
,
5982 else if (sym
->attr
.use_only
)
5983 gfc_warning (OPT_Wunused_parameter
,
5984 "Unused parameter %qs which has been explicitly "
5985 "imported at %L", sym
->name
, &sym
->declared_at
);
5988 if (sym
->ns
&& sym
->ns
->construct_entities
)
5990 if (sym
->attr
.referenced
)
5991 gfc_get_symbol_decl (sym
);
5995 else if (sym
->attr
.flavor
== FL_PROCEDURE
)
5997 /* TODO: move to the appropriate place in resolve.c. */
5998 if (warn_return_type
> 0
5999 && sym
->attr
.function
6001 && sym
!= sym
->result
6002 && !sym
->result
->attr
.referenced
6003 && !sym
->attr
.use_assoc
6004 && sym
->attr
.if_source
!= IFSRC_IFBODY
)
6006 gfc_warning (OPT_Wreturn_type
,
6007 "Return value %qs of function %qs declared at "
6008 "%L not set", sym
->result
->name
, sym
->name
,
6009 &sym
->result
->declared_at
);
6011 /* Prevents "Unused variable" warning for RESULT variables. */
6012 sym
->result
->mark
= 1;
6016 if (sym
->attr
.dummy
== 1)
6018 /* Modify the tree type for scalar character dummy arguments of bind(c)
6019 procedures if they are passed by value. The tree type for them will
6020 be promoted to INTEGER_TYPE for the middle end, which appears to be
6021 what C would do with characters passed by-value. The value attribute
6022 implies the dummy is a scalar. */
6023 if (sym
->attr
.value
== 1 && sym
->backend_decl
!= NULL
6024 && sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.is_c_interop
6025 && sym
->ns
->proc_name
!= NULL
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
6026 gfc_conv_scalar_char_value (sym
, NULL
, NULL
);
6028 /* Unused procedure passed as dummy argument. */
6029 if (sym
->attr
.flavor
== FL_PROCEDURE
)
6031 if (!sym
->attr
.referenced
)
6033 if (warn_unused_dummy_argument
)
6034 gfc_warning (OPT_Wunused_dummy_argument
,
6035 "Unused dummy argument %qs at %L", sym
->name
,
6039 /* Silence bogus "unused parameter" warnings from the
6041 if (sym
->backend_decl
!= NULL_TREE
)
6042 TREE_NO_WARNING (sym
->backend_decl
) = 1;
6046 /* Make sure we convert the types of the derived types from iso_c_binding
6048 if (sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.is_iso_c
6049 && sym
->ts
.type
== BT_DERIVED
)
6050 sym
->backend_decl
= gfc_typenode_for_spec (&(sym
->ts
));
6055 generate_local_nml_decl (gfc_symbol
* sym
)
6057 if (sym
->attr
.flavor
== FL_NAMELIST
&& !sym
->attr
.use_assoc
)
6059 tree decl
= generate_namelist_decl (sym
);
6066 generate_local_vars (gfc_namespace
* ns
)
6068 gfc_traverse_ns (ns
, generate_local_decl
);
6069 gfc_traverse_ns (ns
, generate_local_nml_decl
);
6073 /* Generate a switch statement to jump to the correct entry point. Also
6074 creates the label decls for the entry points. */
6077 gfc_trans_entry_master_switch (gfc_entry_list
* el
)
6084 gfc_init_block (&block
);
6085 for (; el
; el
= el
->next
)
6087 /* Add the case label. */
6088 label
= gfc_build_label_decl (NULL_TREE
);
6089 val
= build_int_cst (gfc_array_index_type
, el
->id
);
6090 tmp
= build_case_label (val
, NULL_TREE
, label
);
6091 gfc_add_expr_to_block (&block
, tmp
);
6093 /* And jump to the actual entry point. */
6094 label
= gfc_build_label_decl (NULL_TREE
);
6095 tmp
= build1_v (GOTO_EXPR
, label
);
6096 gfc_add_expr_to_block (&block
, tmp
);
6098 /* Save the label decl. */
6101 tmp
= gfc_finish_block (&block
);
6102 /* The first argument selects the entry point. */
6103 val
= DECL_ARGUMENTS (current_function_decl
);
6104 tmp
= fold_build2_loc (input_location
, SWITCH_EXPR
, NULL_TREE
, val
, tmp
);
6109 /* Add code to string lengths of actual arguments passed to a function against
6110 the expected lengths of the dummy arguments. */
6113 add_argument_checking (stmtblock_t
*block
, gfc_symbol
*sym
)
6115 gfc_formal_arglist
*formal
;
6117 for (formal
= gfc_sym_get_dummy_args (sym
); formal
; formal
= formal
->next
)
6118 if (formal
->sym
&& formal
->sym
->ts
.type
== BT_CHARACTER
6119 && !formal
->sym
->ts
.deferred
)
6121 enum tree_code comparison
;
6126 const char *message
;
6132 gcc_assert (cl
->passed_length
!= NULL_TREE
);
6133 gcc_assert (cl
->backend_decl
!= NULL_TREE
);
6135 /* For POINTER, ALLOCATABLE and assumed-shape dummy arguments, the
6136 string lengths must match exactly. Otherwise, it is only required
6137 that the actual string length is *at least* the expected one.
6138 Sequence association allows for a mismatch of the string length
6139 if the actual argument is (part of) an array, but only if the
6140 dummy argument is an array. (See "Sequence association" in
6141 Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.) */
6142 if (fsym
->attr
.pointer
|| fsym
->attr
.allocatable
6143 || (fsym
->as
&& (fsym
->as
->type
== AS_ASSUMED_SHAPE
6144 || fsym
->as
->type
== AS_ASSUMED_RANK
)))
6146 comparison
= NE_EXPR
;
6147 message
= _("Actual string length does not match the declared one"
6148 " for dummy argument '%s' (%ld/%ld)");
6150 else if (fsym
->as
&& fsym
->as
->rank
!= 0)
6154 comparison
= LT_EXPR
;
6155 message
= _("Actual string length is shorter than the declared one"
6156 " for dummy argument '%s' (%ld/%ld)");
6159 /* Build the condition. For optional arguments, an actual length
6160 of 0 is also acceptable if the associated string is NULL, which
6161 means the argument was not passed. */
6162 cond
= fold_build2_loc (input_location
, comparison
, logical_type_node
,
6163 cl
->passed_length
, cl
->backend_decl
);
6164 if (fsym
->attr
.optional
)
6170 not_0length
= fold_build2_loc (input_location
, NE_EXPR
,
6174 (TREE_TYPE (cl
->passed_length
)));
6175 /* The symbol needs to be referenced for gfc_get_symbol_decl. */
6176 fsym
->attr
.referenced
= 1;
6177 not_absent
= gfc_conv_expr_present (fsym
);
6179 absent_failed
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
6180 logical_type_node
, not_0length
,
6183 cond
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
6184 logical_type_node
, cond
, absent_failed
);
6187 /* Build the runtime check. */
6188 argname
= gfc_build_cstring_const (fsym
->name
);
6189 argname
= gfc_build_addr_expr (pchar_type_node
, argname
);
6190 gfc_trans_runtime_check (true, false, cond
, block
, &fsym
->declared_at
,
6192 fold_convert (long_integer_type_node
,
6194 fold_convert (long_integer_type_node
,
6201 create_main_function (tree fndecl
)
6205 tree tmp
, decl
, result_decl
, argc
, argv
, typelist
, arglist
;
6208 old_context
= current_function_decl
;
6212 push_function_context ();
6213 saved_parent_function_decls
= saved_function_decls
;
6214 saved_function_decls
= NULL_TREE
;
6217 /* main() function must be declared with global scope. */
6218 gcc_assert (current_function_decl
== NULL_TREE
);
6220 /* Declare the function. */
6221 tmp
= build_function_type_list (integer_type_node
, integer_type_node
,
6222 build_pointer_type (pchar_type_node
),
6224 main_identifier_node
= get_identifier ("main");
6225 ftn_main
= build_decl (input_location
, FUNCTION_DECL
,
6226 main_identifier_node
, tmp
);
6227 DECL_EXTERNAL (ftn_main
) = 0;
6228 TREE_PUBLIC (ftn_main
) = 1;
6229 TREE_STATIC (ftn_main
) = 1;
6230 DECL_ATTRIBUTES (ftn_main
)
6231 = tree_cons (get_identifier("externally_visible"), NULL_TREE
, NULL_TREE
);
6233 /* Setup the result declaration (for "return 0"). */
6234 result_decl
= build_decl (input_location
,
6235 RESULT_DECL
, NULL_TREE
, integer_type_node
);
6236 DECL_ARTIFICIAL (result_decl
) = 1;
6237 DECL_IGNORED_P (result_decl
) = 1;
6238 DECL_CONTEXT (result_decl
) = ftn_main
;
6239 DECL_RESULT (ftn_main
) = result_decl
;
6241 pushdecl (ftn_main
);
6243 /* Get the arguments. */
6245 arglist
= NULL_TREE
;
6246 typelist
= TYPE_ARG_TYPES (TREE_TYPE (ftn_main
));
6248 tmp
= TREE_VALUE (typelist
);
6249 argc
= build_decl (input_location
, PARM_DECL
, get_identifier ("argc"), tmp
);
6250 DECL_CONTEXT (argc
) = ftn_main
;
6251 DECL_ARG_TYPE (argc
) = TREE_VALUE (typelist
);
6252 TREE_READONLY (argc
) = 1;
6253 gfc_finish_decl (argc
);
6254 arglist
= chainon (arglist
, argc
);
6256 typelist
= TREE_CHAIN (typelist
);
6257 tmp
= TREE_VALUE (typelist
);
6258 argv
= build_decl (input_location
, PARM_DECL
, get_identifier ("argv"), tmp
);
6259 DECL_CONTEXT (argv
) = ftn_main
;
6260 DECL_ARG_TYPE (argv
) = TREE_VALUE (typelist
);
6261 TREE_READONLY (argv
) = 1;
6262 DECL_BY_REFERENCE (argv
) = 1;
6263 gfc_finish_decl (argv
);
6264 arglist
= chainon (arglist
, argv
);
6266 DECL_ARGUMENTS (ftn_main
) = arglist
;
6267 current_function_decl
= ftn_main
;
6268 announce_function (ftn_main
);
6270 rest_of_decl_compilation (ftn_main
, 1, 0);
6271 make_decl_rtl (ftn_main
);
6272 allocate_struct_function (ftn_main
, false);
6275 gfc_init_block (&body
);
6277 /* Call some libgfortran initialization routines, call then MAIN__(). */
6279 /* Call _gfortran_caf_init (*argc, ***argv). */
6280 if (flag_coarray
== GFC_FCOARRAY_LIB
)
6282 tree pint_type
, pppchar_type
;
6283 pint_type
= build_pointer_type (integer_type_node
);
6285 = build_pointer_type (build_pointer_type (pchar_type_node
));
6287 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_init
, 2,
6288 gfc_build_addr_expr (pint_type
, argc
),
6289 gfc_build_addr_expr (pppchar_type
, argv
));
6290 gfc_add_expr_to_block (&body
, tmp
);
6293 /* Call _gfortran_set_args (argc, argv). */
6294 TREE_USED (argc
) = 1;
6295 TREE_USED (argv
) = 1;
6296 tmp
= build_call_expr_loc (input_location
,
6297 gfor_fndecl_set_args
, 2, argc
, argv
);
6298 gfc_add_expr_to_block (&body
, tmp
);
6300 /* Add a call to set_options to set up the runtime library Fortran
6301 language standard parameters. */
6303 tree array_type
, array
, var
;
6304 vec
<constructor_elt
, va_gc
> *v
= NULL
;
6305 static const int noptions
= 7;
6307 /* Passing a new option to the library requires three modifications:
6308 + add it to the tree_cons list below
6309 + change the noptions variable above
6310 + modify the library (runtime/compile_options.c)! */
6312 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
6313 build_int_cst (integer_type_node
,
6314 gfc_option
.warn_std
));
6315 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
6316 build_int_cst (integer_type_node
,
6317 gfc_option
.allow_std
));
6318 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
6319 build_int_cst (integer_type_node
, pedantic
));
6320 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
6321 build_int_cst (integer_type_node
, flag_backtrace
));
6322 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
6323 build_int_cst (integer_type_node
, flag_sign_zero
));
6324 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
6325 build_int_cst (integer_type_node
,
6327 & GFC_RTCHECK_BOUNDS
)));
6328 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
6329 build_int_cst (integer_type_node
,
6330 gfc_option
.fpe_summary
));
6332 array_type
= build_array_type_nelts (integer_type_node
, noptions
);
6333 array
= build_constructor (array_type
, v
);
6334 TREE_CONSTANT (array
) = 1;
6335 TREE_STATIC (array
) = 1;
6337 /* Create a static variable to hold the jump table. */
6338 var
= build_decl (input_location
, VAR_DECL
,
6339 create_tmp_var_name ("options"), array_type
);
6340 DECL_ARTIFICIAL (var
) = 1;
6341 DECL_IGNORED_P (var
) = 1;
6342 TREE_CONSTANT (var
) = 1;
6343 TREE_STATIC (var
) = 1;
6344 TREE_READONLY (var
) = 1;
6345 DECL_INITIAL (var
) = array
;
6347 var
= gfc_build_addr_expr (build_pointer_type (integer_type_node
), var
);
6349 tmp
= build_call_expr_loc (input_location
,
6350 gfor_fndecl_set_options
, 2,
6351 build_int_cst (integer_type_node
, noptions
), var
);
6352 gfc_add_expr_to_block (&body
, tmp
);
6355 /* If -ffpe-trap option was provided, add a call to set_fpe so that
6356 the library will raise a FPE when needed. */
6357 if (gfc_option
.fpe
!= 0)
6359 tmp
= build_call_expr_loc (input_location
,
6360 gfor_fndecl_set_fpe
, 1,
6361 build_int_cst (integer_type_node
,
6363 gfc_add_expr_to_block (&body
, tmp
);
6366 /* If this is the main program and an -fconvert option was provided,
6367 add a call to set_convert. */
6369 if (flag_convert
!= GFC_FLAG_CONVERT_NATIVE
)
6371 tmp
= build_call_expr_loc (input_location
,
6372 gfor_fndecl_set_convert
, 1,
6373 build_int_cst (integer_type_node
, flag_convert
));
6374 gfc_add_expr_to_block (&body
, tmp
);
6377 /* If this is the main program and an -frecord-marker option was provided,
6378 add a call to set_record_marker. */
6380 if (flag_record_marker
!= 0)
6382 tmp
= build_call_expr_loc (input_location
,
6383 gfor_fndecl_set_record_marker
, 1,
6384 build_int_cst (integer_type_node
,
6385 flag_record_marker
));
6386 gfc_add_expr_to_block (&body
, tmp
);
6389 if (flag_max_subrecord_length
!= 0)
6391 tmp
= build_call_expr_loc (input_location
,
6392 gfor_fndecl_set_max_subrecord_length
, 1,
6393 build_int_cst (integer_type_node
,
6394 flag_max_subrecord_length
));
6395 gfc_add_expr_to_block (&body
, tmp
);
6398 /* Call MAIN__(). */
6399 tmp
= build_call_expr_loc (input_location
,
6401 gfc_add_expr_to_block (&body
, tmp
);
6403 /* Mark MAIN__ as used. */
6404 TREE_USED (fndecl
) = 1;
6406 /* Coarray: Call _gfortran_caf_finalize(void). */
6407 if (flag_coarray
== GFC_FCOARRAY_LIB
)
6409 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_finalize
, 0);
6410 gfc_add_expr_to_block (&body
, tmp
);
6414 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, integer_type_node
,
6415 DECL_RESULT (ftn_main
),
6416 build_int_cst (integer_type_node
, 0));
6417 tmp
= build1_v (RETURN_EXPR
, tmp
);
6418 gfc_add_expr_to_block (&body
, tmp
);
6421 DECL_SAVED_TREE (ftn_main
) = gfc_finish_block (&body
);
6424 /* Finish off this function and send it for code generation. */
6426 BLOCK_SUPERCONTEXT (DECL_INITIAL (ftn_main
)) = ftn_main
;
6428 DECL_SAVED_TREE (ftn_main
)
6429 = build3_v (BIND_EXPR
, decl
, DECL_SAVED_TREE (ftn_main
),
6430 DECL_INITIAL (ftn_main
));
6432 /* Output the GENERIC tree. */
6433 dump_function (TDI_original
, ftn_main
);
6435 cgraph_node::finalize_function (ftn_main
, true);
6439 pop_function_context ();
6440 saved_function_decls
= saved_parent_function_decls
;
6442 current_function_decl
= old_context
;
6446 /* Generate an appropriate return-statement for a procedure. */
6449 gfc_generate_return (void)
6455 sym
= current_procedure_symbol
;
6456 fndecl
= sym
->backend_decl
;
6458 if (TREE_TYPE (DECL_RESULT (fndecl
)) == void_type_node
)
6462 result
= get_proc_result (sym
);
6464 /* Set the return value to the dummy result variable. The
6465 types may be different for scalar default REAL functions
6466 with -ff2c, therefore we have to convert. */
6467 if (result
!= NULL_TREE
)
6469 result
= convert (TREE_TYPE (DECL_RESULT (fndecl
)), result
);
6470 result
= fold_build2_loc (input_location
, MODIFY_EXPR
,
6471 TREE_TYPE (result
), DECL_RESULT (fndecl
),
6476 /* If the function does not have a result variable, result is
6477 NULL_TREE, and a 'return' is generated without a variable.
6478 The following generates a 'return __result_XXX' where XXX is
6479 the function name. */
6480 if (sym
== sym
->result
&& sym
->attr
.function
)
6482 result
= gfc_get_fake_result_decl (sym
, 0);
6483 result
= fold_build2_loc (input_location
, MODIFY_EXPR
,
6485 DECL_RESULT (fndecl
), result
);
6490 return build1_v (RETURN_EXPR
, result
);
6495 is_from_ieee_module (gfc_symbol
*sym
)
6497 if (sym
->from_intmod
== INTMOD_IEEE_FEATURES
6498 || sym
->from_intmod
== INTMOD_IEEE_EXCEPTIONS
6499 || sym
->from_intmod
== INTMOD_IEEE_ARITHMETIC
)
6500 seen_ieee_symbol
= 1;
6505 is_ieee_module_used (gfc_namespace
*ns
)
6507 seen_ieee_symbol
= 0;
6508 gfc_traverse_ns (ns
, is_from_ieee_module
);
6509 return seen_ieee_symbol
;
6513 static gfc_omp_clauses
*module_oacc_clauses
;
6517 add_clause (gfc_symbol
*sym
, gfc_omp_map_op map_op
)
6519 gfc_omp_namelist
*n
;
6521 n
= gfc_get_omp_namelist ();
6523 n
->u
.map_op
= map_op
;
6525 if (!module_oacc_clauses
)
6526 module_oacc_clauses
= gfc_get_omp_clauses ();
6528 if (module_oacc_clauses
->lists
[OMP_LIST_MAP
])
6529 n
->next
= module_oacc_clauses
->lists
[OMP_LIST_MAP
];
6531 module_oacc_clauses
->lists
[OMP_LIST_MAP
] = n
;
6536 find_module_oacc_declare_clauses (gfc_symbol
*sym
)
6538 if (sym
->attr
.use_assoc
)
6540 gfc_omp_map_op map_op
;
6542 if (sym
->attr
.oacc_declare_create
)
6543 map_op
= OMP_MAP_FORCE_ALLOC
;
6545 if (sym
->attr
.oacc_declare_copyin
)
6546 map_op
= OMP_MAP_FORCE_TO
;
6548 if (sym
->attr
.oacc_declare_deviceptr
)
6549 map_op
= OMP_MAP_FORCE_DEVICEPTR
;
6551 if (sym
->attr
.oacc_declare_device_resident
)
6552 map_op
= OMP_MAP_DEVICE_RESIDENT
;
6554 if (sym
->attr
.oacc_declare_create
6555 || sym
->attr
.oacc_declare_copyin
6556 || sym
->attr
.oacc_declare_deviceptr
6557 || sym
->attr
.oacc_declare_device_resident
)
6559 sym
->attr
.referenced
= 1;
6560 add_clause (sym
, map_op
);
6567 finish_oacc_declare (gfc_namespace
*ns
, gfc_symbol
*sym
, bool block
)
6570 gfc_oacc_declare
*oc
;
6571 locus where
= gfc_current_locus
;
6572 gfc_omp_clauses
*omp_clauses
= NULL
;
6573 gfc_omp_namelist
*n
, *p
;
6575 module_oacc_clauses
= NULL
;
6576 gfc_traverse_ns (ns
, find_module_oacc_declare_clauses
);
6578 if (module_oacc_clauses
&& sym
->attr
.flavor
== FL_PROGRAM
)
6580 gfc_oacc_declare
*new_oc
;
6582 new_oc
= gfc_get_oacc_declare ();
6583 new_oc
->next
= ns
->oacc_declare
;
6584 new_oc
->clauses
= module_oacc_clauses
;
6586 ns
->oacc_declare
= new_oc
;
6589 if (!ns
->oacc_declare
)
6592 for (oc
= ns
->oacc_declare
; oc
; oc
= oc
->next
)
6598 gfc_error ("Sorry, !$ACC DECLARE at %L is not allowed "
6599 "in BLOCK construct", &oc
->loc
);
6602 if (oc
->clauses
&& oc
->clauses
->lists
[OMP_LIST_MAP
])
6604 if (omp_clauses
== NULL
)
6606 omp_clauses
= oc
->clauses
;
6610 for (n
= oc
->clauses
->lists
[OMP_LIST_MAP
]; n
; p
= n
, n
= n
->next
)
6613 gcc_assert (p
->next
== NULL
);
6615 p
->next
= omp_clauses
->lists
[OMP_LIST_MAP
];
6616 omp_clauses
= oc
->clauses
;
6623 for (n
= omp_clauses
->lists
[OMP_LIST_MAP
]; n
; n
= n
->next
)
6625 switch (n
->u
.map_op
)
6627 case OMP_MAP_DEVICE_RESIDENT
:
6628 n
->u
.map_op
= OMP_MAP_FORCE_ALLOC
;
6636 code
= XCNEW (gfc_code
);
6637 code
->op
= EXEC_OACC_DECLARE
;
6640 code
->ext
.oacc_declare
= gfc_get_oacc_declare ();
6641 code
->ext
.oacc_declare
->clauses
= omp_clauses
;
6643 code
->block
= XCNEW (gfc_code
);
6644 code
->block
->op
= EXEC_OACC_DECLARE
;
6645 code
->block
->loc
= where
;
6648 code
->block
->next
= ns
->code
;
6656 /* Generate code for a function. */
6659 gfc_generate_function_code (gfc_namespace
* ns
)
6665 tree fpstate
= NULL_TREE
;
6666 stmtblock_t init
, cleanup
;
6668 gfc_wrapped_block try_block
;
6669 tree recurcheckvar
= NULL_TREE
;
6671 gfc_symbol
*previous_procedure_symbol
;
6675 sym
= ns
->proc_name
;
6676 previous_procedure_symbol
= current_procedure_symbol
;
6677 current_procedure_symbol
= sym
;
6679 /* Initialize sym->tlink so that gfc_trans_deferred_vars does not get
6683 /* Create the declaration for functions with global scope. */
6684 if (!sym
->backend_decl
)
6685 gfc_create_function_decl (ns
, false);
6687 fndecl
= sym
->backend_decl
;
6688 old_context
= current_function_decl
;
6692 push_function_context ();
6693 saved_parent_function_decls
= saved_function_decls
;
6694 saved_function_decls
= NULL_TREE
;
6697 trans_function_start (sym
);
6699 gfc_init_block (&init
);
6701 if (ns
->entries
&& ns
->proc_name
->ts
.type
== BT_CHARACTER
)
6703 /* Copy length backend_decls to all entry point result
6708 gfc_conv_const_charlen (ns
->proc_name
->ts
.u
.cl
);
6709 backend_decl
= ns
->proc_name
->result
->ts
.u
.cl
->backend_decl
;
6710 for (el
= ns
->entries
; el
; el
= el
->next
)
6711 el
->sym
->result
->ts
.u
.cl
->backend_decl
= backend_decl
;
6714 /* Translate COMMON blocks. */
6715 gfc_trans_common (ns
);
6717 /* Null the parent fake result declaration if this namespace is
6718 a module function or an external procedures. */
6719 if ((ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
6720 || ns
->parent
== NULL
)
6721 parent_fake_result_decl
= NULL_TREE
;
6723 gfc_generate_contained_functions (ns
);
6725 has_coarray_vars
= false;
6726 generate_local_vars (ns
);
6728 if (flag_coarray
== GFC_FCOARRAY_LIB
&& has_coarray_vars
)
6729 generate_coarray_init (ns
);
6731 /* Keep the parent fake result declaration in module functions
6732 or external procedures. */
6733 if ((ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
6734 || ns
->parent
== NULL
)
6735 current_fake_result_decl
= parent_fake_result_decl
;
6737 current_fake_result_decl
= NULL_TREE
;
6739 is_recursive
= sym
->attr
.recursive
6740 || (sym
->attr
.entry_master
6741 && sym
->ns
->entries
->sym
->attr
.recursive
);
6742 if ((gfc_option
.rtcheck
& GFC_RTCHECK_RECURSION
)
6743 && !is_recursive
&& !flag_recursive
)
6747 msg
= xasprintf ("Recursive call to nonrecursive procedure '%s'",
6749 recurcheckvar
= gfc_create_var (logical_type_node
, "is_recursive");
6750 TREE_STATIC (recurcheckvar
) = 1;
6751 DECL_INITIAL (recurcheckvar
) = logical_false_node
;
6752 gfc_add_expr_to_block (&init
, recurcheckvar
);
6753 gfc_trans_runtime_check (true, false, recurcheckvar
, &init
,
6754 &sym
->declared_at
, msg
);
6755 gfc_add_modify (&init
, recurcheckvar
, logical_true_node
);
6759 /* Check if an IEEE module is used in the procedure. If so, save
6760 the floating point state. */
6761 ieee
= is_ieee_module_used (ns
);
6763 fpstate
= gfc_save_fp_state (&init
);
6765 /* Now generate the code for the body of this function. */
6766 gfc_init_block (&body
);
6768 if (TREE_TYPE (DECL_RESULT (fndecl
)) != void_type_node
6769 && sym
->attr
.subroutine
)
6771 tree alternate_return
;
6772 alternate_return
= gfc_get_fake_result_decl (sym
, 0);
6773 gfc_add_modify (&body
, alternate_return
, integer_zero_node
);
6778 /* Jump to the correct entry point. */
6779 tmp
= gfc_trans_entry_master_switch (ns
->entries
);
6780 gfc_add_expr_to_block (&body
, tmp
);
6783 /* If bounds-checking is enabled, generate code to check passed in actual
6784 arguments against the expected dummy argument attributes (e.g. string
6786 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) && !sym
->attr
.is_bind_c
)
6787 add_argument_checking (&body
, sym
);
6789 finish_oacc_declare (ns
, sym
, false);
6791 tmp
= gfc_trans_code (ns
->code
);
6792 gfc_add_expr_to_block (&body
, tmp
);
6794 if (TREE_TYPE (DECL_RESULT (fndecl
)) != void_type_node
6795 || (sym
->result
&& sym
->result
!= sym
6796 && sym
->result
->ts
.type
== BT_DERIVED
6797 && sym
->result
->ts
.u
.derived
->attr
.alloc_comp
))
6799 bool artificial_result_decl
= false;
6800 tree result
= get_proc_result (sym
);
6801 gfc_symbol
*rsym
= sym
== sym
->result
? sym
: sym
->result
;
6803 /* Make sure that a function returning an object with
6804 alloc/pointer_components always has a result, where at least
6805 the allocatable/pointer components are set to zero. */
6806 if (result
== NULL_TREE
&& sym
->attr
.function
6807 && ((sym
->result
->ts
.type
== BT_DERIVED
6808 && (sym
->attr
.allocatable
6809 || sym
->attr
.pointer
6810 || sym
->result
->ts
.u
.derived
->attr
.alloc_comp
6811 || sym
->result
->ts
.u
.derived
->attr
.pointer_comp
))
6812 || (sym
->result
->ts
.type
== BT_CLASS
6813 && (CLASS_DATA (sym
)->attr
.allocatable
6814 || CLASS_DATA (sym
)->attr
.class_pointer
6815 || CLASS_DATA (sym
->result
)->attr
.alloc_comp
6816 || CLASS_DATA (sym
->result
)->attr
.pointer_comp
))))
6818 artificial_result_decl
= true;
6819 result
= gfc_get_fake_result_decl (sym
, 0);
6822 if (result
!= NULL_TREE
&& sym
->attr
.function
&& !sym
->attr
.pointer
)
6824 if (sym
->attr
.allocatable
&& sym
->attr
.dimension
== 0
6825 && sym
->result
== sym
)
6826 gfc_add_modify (&init
, result
, fold_convert (TREE_TYPE (result
),
6827 null_pointer_node
));
6828 else if (sym
->ts
.type
== BT_CLASS
6829 && CLASS_DATA (sym
)->attr
.allocatable
6830 && CLASS_DATA (sym
)->attr
.dimension
== 0
6831 && sym
->result
== sym
)
6833 tmp
= CLASS_DATA (sym
)->backend_decl
;
6834 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
6835 TREE_TYPE (tmp
), result
, tmp
, NULL_TREE
);
6836 gfc_add_modify (&init
, tmp
, fold_convert (TREE_TYPE (tmp
),
6837 null_pointer_node
));
6839 else if (sym
->ts
.type
== BT_DERIVED
6840 && !sym
->attr
.allocatable
)
6843 /* Arrays are not initialized using the default initializer of
6844 their elements. Therefore only check if a default
6845 initializer is available when the result is scalar. */
6846 init_exp
= rsym
->as
? NULL
6847 : gfc_generate_initializer (&rsym
->ts
, true);
6850 tmp
= gfc_trans_structure_assign (result
, init_exp
, 0);
6851 gfc_free_expr (init_exp
);
6852 gfc_add_expr_to_block (&init
, tmp
);
6854 else if (rsym
->ts
.u
.derived
->attr
.alloc_comp
)
6856 rank
= rsym
->as
? rsym
->as
->rank
: 0;
6857 tmp
= gfc_nullify_alloc_comp (rsym
->ts
.u
.derived
, result
,
6859 gfc_prepend_expr_to_block (&body
, tmp
);
6864 if (result
== NULL_TREE
|| artificial_result_decl
)
6866 /* TODO: move to the appropriate place in resolve.c. */
6867 if (warn_return_type
> 0 && sym
== sym
->result
)
6868 gfc_warning (OPT_Wreturn_type
,
6869 "Return value of function %qs at %L not set",
6870 sym
->name
, &sym
->declared_at
);
6871 if (warn_return_type
> 0)
6872 TREE_NO_WARNING(sym
->backend_decl
) = 1;
6874 if (result
!= NULL_TREE
)
6875 gfc_add_expr_to_block (&body
, gfc_generate_return ());
6878 gfc_init_block (&cleanup
);
6880 /* Reset recursion-check variable. */
6881 if ((gfc_option
.rtcheck
& GFC_RTCHECK_RECURSION
)
6882 && !is_recursive
&& !flag_openmp
&& recurcheckvar
!= NULL_TREE
)
6884 gfc_add_modify (&cleanup
, recurcheckvar
, logical_false_node
);
6885 recurcheckvar
= NULL
;
6888 /* If IEEE modules are loaded, restore the floating-point state. */
6890 gfc_restore_fp_state (&cleanup
, fpstate
);
6892 /* Finish the function body and add init and cleanup code. */
6893 tmp
= gfc_finish_block (&body
);
6894 gfc_start_wrapped_block (&try_block
, tmp
);
6895 /* Add code to create and cleanup arrays. */
6896 gfc_trans_deferred_vars (sym
, &try_block
);
6897 gfc_add_init_cleanup (&try_block
, gfc_finish_block (&init
),
6898 gfc_finish_block (&cleanup
));
6900 /* Add all the decls we created during processing. */
6901 decl
= nreverse (saved_function_decls
);
6906 next
= DECL_CHAIN (decl
);
6907 DECL_CHAIN (decl
) = NULL_TREE
;
6911 saved_function_decls
= NULL_TREE
;
6913 DECL_SAVED_TREE (fndecl
) = gfc_finish_wrapped_block (&try_block
);
6916 /* Finish off this function and send it for code generation. */
6918 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl
)) = fndecl
;
6920 DECL_SAVED_TREE (fndecl
)
6921 = build3_v (BIND_EXPR
, decl
, DECL_SAVED_TREE (fndecl
),
6922 DECL_INITIAL (fndecl
));
6924 /* Output the GENERIC tree. */
6925 dump_function (TDI_original
, fndecl
);
6927 /* Store the end of the function, so that we get good line number
6928 info for the epilogue. */
6929 cfun
->function_end_locus
= input_location
;
6931 /* We're leaving the context of this function, so zap cfun.
6932 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
6933 tree_rest_of_compilation. */
6938 pop_function_context ();
6939 saved_function_decls
= saved_parent_function_decls
;
6941 current_function_decl
= old_context
;
6943 if (decl_function_context (fndecl
))
6945 /* Register this function with cgraph just far enough to get it
6946 added to our parent's nested function list.
6947 If there are static coarrays in this function, the nested _caf_init
6948 function has already called cgraph_create_node, which also created
6949 the cgraph node for this function. */
6950 if (!has_coarray_vars
|| flag_coarray
!= GFC_FCOARRAY_LIB
)
6951 (void) cgraph_node::get_create (fndecl
);
6954 cgraph_node::finalize_function (fndecl
, true);
6956 gfc_trans_use_stmts (ns
);
6957 gfc_traverse_ns (ns
, gfc_emit_parameter_debug_info
);
6959 if (sym
->attr
.is_main_program
)
6960 create_main_function (fndecl
);
6962 current_procedure_symbol
= previous_procedure_symbol
;
6967 gfc_generate_constructors (void)
6969 gcc_assert (gfc_static_ctors
== NULL_TREE
);
6977 if (gfc_static_ctors
== NULL_TREE
)
6980 fnname
= get_file_function_name ("I");
6981 type
= build_function_type_list (void_type_node
, NULL_TREE
);
6983 fndecl
= build_decl (input_location
,
6984 FUNCTION_DECL
, fnname
, type
);
6985 TREE_PUBLIC (fndecl
) = 1;
6987 decl
= build_decl (input_location
,
6988 RESULT_DECL
, NULL_TREE
, void_type_node
);
6989 DECL_ARTIFICIAL (decl
) = 1;
6990 DECL_IGNORED_P (decl
) = 1;
6991 DECL_CONTEXT (decl
) = fndecl
;
6992 DECL_RESULT (fndecl
) = decl
;
6996 current_function_decl
= fndecl
;
6998 rest_of_decl_compilation (fndecl
, 1, 0);
7000 make_decl_rtl (fndecl
);
7002 allocate_struct_function (fndecl
, false);
7006 for (; gfc_static_ctors
; gfc_static_ctors
= TREE_CHAIN (gfc_static_ctors
))
7008 tmp
= build_call_expr_loc (input_location
,
7009 TREE_VALUE (gfc_static_ctors
), 0);
7010 DECL_SAVED_TREE (fndecl
) = build_stmt (input_location
, EXPR_STMT
, tmp
);
7016 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl
)) = fndecl
;
7017 DECL_SAVED_TREE (fndecl
)
7018 = build3_v (BIND_EXPR
, decl
, DECL_SAVED_TREE (fndecl
),
7019 DECL_INITIAL (fndecl
));
7021 free_after_parsing (cfun
);
7022 free_after_compilation (cfun
);
7024 tree_rest_of_compilation (fndecl
);
7026 current_function_decl
= NULL_TREE
;
7030 /* Translates a BLOCK DATA program unit. This means emitting the
7031 commons contained therein plus their initializations. We also emit
7032 a globally visible symbol to make sure that each BLOCK DATA program
7033 unit remains unique. */
7036 gfc_generate_block_data (gfc_namespace
* ns
)
7041 /* Tell the backend the source location of the block data. */
7043 gfc_set_backend_locus (&ns
->proc_name
->declared_at
);
7045 gfc_set_backend_locus (&gfc_current_locus
);
7047 /* Process the DATA statements. */
7048 gfc_trans_common (ns
);
7050 /* Create a global symbol with the mane of the block data. This is to
7051 generate linker errors if the same name is used twice. It is never
7054 id
= gfc_sym_mangled_function_id (ns
->proc_name
);
7056 id
= get_identifier ("__BLOCK_DATA__");
7058 decl
= build_decl (input_location
,
7059 VAR_DECL
, id
, gfc_array_index_type
);
7060 TREE_PUBLIC (decl
) = 1;
7061 TREE_STATIC (decl
) = 1;
7062 DECL_IGNORED_P (decl
) = 1;
7065 rest_of_decl_compilation (decl
, 1, 0);
7069 /* Process the local variables of a BLOCK construct. */
7072 gfc_process_block_locals (gfc_namespace
* ns
)
7076 saved_local_decls
= NULL_TREE
;
7077 has_coarray_vars
= false;
7079 generate_local_vars (ns
);
7081 if (flag_coarray
== GFC_FCOARRAY_LIB
&& has_coarray_vars
)
7082 generate_coarray_init (ns
);
7084 decl
= nreverse (saved_local_decls
);
7089 next
= DECL_CHAIN (decl
);
7090 DECL_CHAIN (decl
) = NULL_TREE
;
7094 saved_local_decls
= NULL_TREE
;
7098 #include "gt-fortran-trans-decl.h"