1 /* Backend function setup
2 Copyright (C) 2002-2023 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.cc -- 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"
50 #include "attr-fnspec.h"
52 #define MAX_LABEL_VALUE 99999
55 /* Holds the result of the function if no result variable specified. */
57 static GTY(()) tree current_fake_result_decl
;
58 static GTY(()) tree parent_fake_result_decl
;
61 /* Holds the variable DECLs for the current function. */
63 static GTY(()) tree saved_function_decls
;
64 static GTY(()) tree saved_parent_function_decls
;
66 /* Holds the variable DECLs that are locals. */
68 static GTY(()) tree saved_local_decls
;
70 /* The namespace of the module we're currently generating. Only used while
71 outputting decls for module variables. Do not rely on this being set. */
73 static gfc_namespace
*module_namespace
;
75 /* The currently processed procedure symbol. */
76 static gfc_symbol
* current_procedure_symbol
= NULL
;
78 /* The currently processed module. */
79 static struct module_htab_entry
*cur_module
;
81 /* With -fcoarray=lib: For generating the registering call
82 of static coarrays. */
83 static bool has_coarray_vars
;
84 static stmtblock_t caf_init_block
;
87 /* List of static constructor functions. */
89 tree gfc_static_ctors
;
92 /* Whether we've seen a symbol from an IEEE module in the namespace. */
93 static int seen_ieee_symbol
;
95 /* Function declarations for builtin library functions. */
97 tree gfor_fndecl_pause_numeric
;
98 tree gfor_fndecl_pause_string
;
99 tree gfor_fndecl_stop_numeric
;
100 tree gfor_fndecl_stop_string
;
101 tree gfor_fndecl_error_stop_numeric
;
102 tree gfor_fndecl_error_stop_string
;
103 tree gfor_fndecl_runtime_error
;
104 tree gfor_fndecl_runtime_error_at
;
105 tree gfor_fndecl_runtime_warning_at
;
106 tree gfor_fndecl_os_error_at
;
107 tree gfor_fndecl_generate_error
;
108 tree gfor_fndecl_set_args
;
109 tree gfor_fndecl_set_fpe
;
110 tree gfor_fndecl_set_options
;
111 tree gfor_fndecl_set_convert
;
112 tree gfor_fndecl_set_record_marker
;
113 tree gfor_fndecl_set_max_subrecord_length
;
114 tree gfor_fndecl_ctime
;
115 tree gfor_fndecl_fdate
;
116 tree gfor_fndecl_ttynam
;
117 tree gfor_fndecl_in_pack
;
118 tree gfor_fndecl_in_unpack
;
119 tree gfor_fndecl_associated
;
120 tree gfor_fndecl_system_clock4
;
121 tree gfor_fndecl_system_clock8
;
122 tree gfor_fndecl_ieee_procedure_entry
;
123 tree gfor_fndecl_ieee_procedure_exit
;
125 /* Coarray run-time library function decls. */
126 tree gfor_fndecl_caf_init
;
127 tree gfor_fndecl_caf_finalize
;
128 tree gfor_fndecl_caf_this_image
;
129 tree gfor_fndecl_caf_num_images
;
130 tree gfor_fndecl_caf_register
;
131 tree gfor_fndecl_caf_deregister
;
132 tree gfor_fndecl_caf_get
;
133 tree gfor_fndecl_caf_send
;
134 tree gfor_fndecl_caf_sendget
;
135 tree gfor_fndecl_caf_get_by_ref
;
136 tree gfor_fndecl_caf_send_by_ref
;
137 tree gfor_fndecl_caf_sendget_by_ref
;
138 tree gfor_fndecl_caf_sync_all
;
139 tree gfor_fndecl_caf_sync_memory
;
140 tree gfor_fndecl_caf_sync_images
;
141 tree gfor_fndecl_caf_stop_str
;
142 tree gfor_fndecl_caf_stop_numeric
;
143 tree gfor_fndecl_caf_error_stop
;
144 tree gfor_fndecl_caf_error_stop_str
;
145 tree gfor_fndecl_caf_atomic_def
;
146 tree gfor_fndecl_caf_atomic_ref
;
147 tree gfor_fndecl_caf_atomic_cas
;
148 tree gfor_fndecl_caf_atomic_op
;
149 tree gfor_fndecl_caf_lock
;
150 tree gfor_fndecl_caf_unlock
;
151 tree gfor_fndecl_caf_event_post
;
152 tree gfor_fndecl_caf_event_wait
;
153 tree gfor_fndecl_caf_event_query
;
154 tree gfor_fndecl_caf_fail_image
;
155 tree gfor_fndecl_caf_failed_images
;
156 tree gfor_fndecl_caf_image_status
;
157 tree gfor_fndecl_caf_stopped_images
;
158 tree gfor_fndecl_caf_form_team
;
159 tree gfor_fndecl_caf_change_team
;
160 tree gfor_fndecl_caf_end_team
;
161 tree gfor_fndecl_caf_sync_team
;
162 tree gfor_fndecl_caf_get_team
;
163 tree gfor_fndecl_caf_team_number
;
164 tree gfor_fndecl_co_broadcast
;
165 tree gfor_fndecl_co_max
;
166 tree gfor_fndecl_co_min
;
167 tree gfor_fndecl_co_reduce
;
168 tree gfor_fndecl_co_sum
;
169 tree gfor_fndecl_caf_is_present
;
170 tree gfor_fndecl_caf_random_init
;
173 /* Math functions. Many other math functions are handled in
174 trans-intrinsic.cc. */
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_iargc
;
215 tree gfor_fndecl_kill
;
216 tree gfor_fndecl_kill_sub
;
217 tree gfor_fndecl_is_contiguous0
;
220 /* Intrinsic functions implemented in Fortran. */
221 tree gfor_fndecl_sc_kind
;
222 tree gfor_fndecl_si_kind
;
223 tree gfor_fndecl_sr_kind
;
225 /* BLAS gemm functions. */
226 tree gfor_fndecl_sgemm
;
227 tree gfor_fndecl_dgemm
;
228 tree gfor_fndecl_cgemm
;
229 tree gfor_fndecl_zgemm
;
231 /* RANDOM_INIT function. */
232 tree gfor_fndecl_random_init
; /* libgfortran, 1 image only. */
235 gfc_add_decl_to_parent_function (tree decl
)
238 DECL_CONTEXT (decl
) = DECL_CONTEXT (current_function_decl
);
239 DECL_NONLOCAL (decl
) = 1;
240 DECL_CHAIN (decl
) = saved_parent_function_decls
;
241 saved_parent_function_decls
= decl
;
245 gfc_add_decl_to_function (tree decl
)
248 TREE_USED (decl
) = 1;
249 DECL_CONTEXT (decl
) = current_function_decl
;
250 DECL_CHAIN (decl
) = saved_function_decls
;
251 saved_function_decls
= decl
;
255 add_decl_as_local (tree decl
)
258 TREE_USED (decl
) = 1;
259 DECL_CONTEXT (decl
) = current_function_decl
;
260 DECL_CHAIN (decl
) = saved_local_decls
;
261 saved_local_decls
= decl
;
265 /* Build a backend label declaration. Set TREE_USED for named labels.
266 The context of the label is always the current_function_decl. All
267 labels are marked artificial. */
270 gfc_build_label_decl (tree label_id
)
272 /* 2^32 temporaries should be enough. */
273 static unsigned int tmp_num
= 1;
277 if (label_id
== NULL_TREE
)
279 /* Build an internal label name. */
280 ASM_FORMAT_PRIVATE_NAME (label_name
, "L", tmp_num
++);
281 label_id
= get_identifier (label_name
);
286 /* Build the LABEL_DECL node. Labels have no type. */
287 label_decl
= build_decl (input_location
,
288 LABEL_DECL
, label_id
, void_type_node
);
289 DECL_CONTEXT (label_decl
) = current_function_decl
;
290 SET_DECL_MODE (label_decl
, VOIDmode
);
292 /* We always define the label as used, even if the original source
293 file never references the label. We don't want all kinds of
294 spurious warnings for old-style Fortran code with too many
296 TREE_USED (label_decl
) = 1;
298 DECL_ARTIFICIAL (label_decl
) = 1;
303 /* Set the backend source location of a decl. */
306 gfc_set_decl_location (tree decl
, locus
* loc
)
308 DECL_SOURCE_LOCATION (decl
) = gfc_get_location (loc
);
312 /* Return the backend label declaration for a given label structure,
313 or create it if it doesn't exist yet. */
316 gfc_get_label_decl (gfc_st_label
* lp
)
318 if (lp
->backend_decl
)
319 return lp
->backend_decl
;
322 char label_name
[GFC_MAX_SYMBOL_LEN
+ 1];
325 /* Validate the label declaration from the front end. */
326 gcc_assert (lp
!= NULL
&& lp
->value
<= MAX_LABEL_VALUE
);
328 /* Build a mangled name for the label. */
329 sprintf (label_name
, "__label_%.6d", lp
->value
);
331 /* Build the LABEL_DECL node. */
332 label_decl
= gfc_build_label_decl (get_identifier (label_name
));
334 /* Tell the debugger where the label came from. */
335 if (lp
->value
<= MAX_LABEL_VALUE
) /* An internal label. */
336 gfc_set_decl_location (label_decl
, &lp
->where
);
338 DECL_ARTIFICIAL (label_decl
) = 1;
340 /* Store the label in the label list and return the LABEL_DECL. */
341 lp
->backend_decl
= label_decl
;
346 /* Return the name of an identifier. */
349 sym_identifier (gfc_symbol
*sym
)
351 if (sym
->attr
.is_main_program
&& strcmp (sym
->name
, "main") == 0)
357 /* Convert a gfc_symbol to an identifier of the same name. */
360 gfc_sym_identifier (gfc_symbol
* sym
)
362 return get_identifier (sym_identifier (sym
));
365 /* Construct mangled name from symbol name. */
368 mangled_identifier (gfc_symbol
*sym
)
370 gfc_symbol
*proc
= sym
->ns
->proc_name
;
371 static char name
[3*GFC_MAX_MANGLED_SYMBOL_LEN
+ 14];
372 /* Prevent the mangling of identifiers that have an assigned
373 binding label (mainly those that are bind(c)). */
375 if (sym
->attr
.is_bind_c
== 1 && sym
->binding_label
)
376 return sym
->binding_label
;
378 if (!sym
->fn_result_spec
379 || (sym
->module
&& !(proc
&& proc
->attr
.flavor
== FL_PROCEDURE
)))
381 if (sym
->module
== NULL
)
382 return sym_identifier (sym
);
384 snprintf (name
, sizeof name
, "__%s_MOD_%s", sym
->module
, sym
->name
);
388 /* This is an entity that is actually local to a module procedure
389 that appears in the result specification expression. Since
390 sym->module will be a zero length string, we use ns->proc_name
391 to provide the module name instead. */
392 if (proc
&& proc
->module
)
393 snprintf (name
, sizeof name
, "__%s_MOD__%s_PROC_%s",
394 proc
->module
, proc
->name
, sym
->name
);
396 snprintf (name
, sizeof name
, "__%s_PROC_%s",
397 proc
->name
, sym
->name
);
403 /* Get mangled identifier, adding the symbol to the global table if
404 it is not yet already there. */
407 gfc_sym_mangled_identifier (gfc_symbol
* sym
)
413 name
= mangled_identifier (sym
);
414 result
= get_identifier (name
);
416 gsym
= gfc_find_gsymbol (gfc_gsym_root
, name
);
419 gsym
= gfc_get_gsymbol (name
, false);
421 gsym
->sym_name
= sym
->name
;
427 /* Construct mangled function name from symbol name. */
430 gfc_sym_mangled_function_id (gfc_symbol
* sym
)
433 char name
[GFC_MAX_MANGLED_SYMBOL_LEN
+ 1];
435 /* It may be possible to simply use the binding label if it's
436 provided, and remove the other checks. Then we could use it
437 for other things if we wished. */
438 if ((sym
->attr
.is_bind_c
== 1 || sym
->attr
.is_iso_c
== 1) &&
440 /* use the binding label rather than the mangled name */
441 return get_identifier (sym
->binding_label
);
443 if ((sym
->module
== NULL
|| sym
->attr
.proc
== PROC_EXTERNAL
444 || (sym
->module
!= NULL
&& (sym
->attr
.external
445 || sym
->attr
.if_source
== IFSRC_IFBODY
)))
446 && !sym
->attr
.module_procedure
)
448 /* Main program is mangled into MAIN__. */
449 if (sym
->attr
.is_main_program
)
450 return get_identifier ("MAIN__");
452 /* Intrinsic procedures are never mangled. */
453 if (sym
->attr
.proc
== PROC_INTRINSIC
)
454 return get_identifier (sym
->name
);
456 if (flag_underscoring
)
458 has_underscore
= strchr (sym
->name
, '_') != 0;
459 if (flag_second_underscore
&& has_underscore
)
460 snprintf (name
, sizeof name
, "%s__", sym
->name
);
462 snprintf (name
, sizeof name
, "%s_", sym
->name
);
463 return get_identifier (name
);
466 return get_identifier (sym
->name
);
470 snprintf (name
, sizeof name
, "__%s_MOD_%s", sym
->module
, sym
->name
);
471 return get_identifier (name
);
477 gfc_set_decl_assembler_name (tree decl
, tree name
)
479 tree target_mangled
= targetm
.mangle_decl_assembler_name (decl
, name
);
480 SET_DECL_ASSEMBLER_NAME (decl
, target_mangled
);
484 /* Returns true if a variable of specified size should go on the stack. */
487 gfc_can_put_var_on_stack (tree size
)
489 unsigned HOST_WIDE_INT low
;
491 if (!INTEGER_CST_P (size
))
494 if (flag_max_stack_var_size
< 0)
497 if (!tree_fits_uhwi_p (size
))
500 low
= TREE_INT_CST_LOW (size
);
501 if (low
> (unsigned HOST_WIDE_INT
) flag_max_stack_var_size
)
504 /* TODO: Set a per-function stack size limit. */
510 /* gfc_finish_cray_pointee sets DECL_VALUE_EXPR for a Cray pointee to
511 an expression involving its corresponding pointer. There are
512 2 cases; one for variable size arrays, and one for everything else,
513 because variable-sized arrays require one fewer level of
517 gfc_finish_cray_pointee (tree decl
, gfc_symbol
*sym
)
519 tree ptr_decl
= gfc_get_symbol_decl (sym
->cp_pointer
);
522 /* Parameters need to be dereferenced. */
523 if (sym
->cp_pointer
->attr
.dummy
)
524 ptr_decl
= build_fold_indirect_ref_loc (input_location
,
527 /* Check to see if we're dealing with a variable-sized array. */
528 if (sym
->attr
.dimension
529 && TREE_CODE (TREE_TYPE (decl
)) == POINTER_TYPE
)
531 /* These decls will be dereferenced later, so we don't dereference
533 value
= convert (TREE_TYPE (decl
), ptr_decl
);
537 ptr_decl
= convert (build_pointer_type (TREE_TYPE (decl
)),
539 value
= build_fold_indirect_ref_loc (input_location
,
543 SET_DECL_VALUE_EXPR (decl
, value
);
544 DECL_HAS_VALUE_EXPR_P (decl
) = 1;
545 GFC_DECL_CRAY_POINTEE (decl
) = 1;
549 /* Finish processing of a declaration without an initial value. */
552 gfc_finish_decl (tree decl
)
554 gcc_assert (TREE_CODE (decl
) == PARM_DECL
555 || DECL_INITIAL (decl
) == NULL_TREE
);
560 if (DECL_SIZE (decl
) == NULL_TREE
561 && TYPE_SIZE (TREE_TYPE (decl
)) != NULL_TREE
)
562 layout_decl (decl
, 0);
564 /* A few consistency checks. */
565 /* A static variable with an incomplete type is an error if it is
566 initialized. Also if it is not file scope. Otherwise, let it
567 through, but if it is not `extern' then it may cause an error
569 /* An automatic variable with an incomplete type is an error. */
571 /* We should know the storage size. */
572 gcc_assert (DECL_SIZE (decl
) != NULL_TREE
573 || (TREE_STATIC (decl
)
574 ? (!DECL_INITIAL (decl
) || !DECL_CONTEXT (decl
))
575 : DECL_EXTERNAL (decl
)));
577 /* The storage size should be constant. */
578 gcc_assert ((!DECL_EXTERNAL (decl
) && !TREE_STATIC (decl
))
580 || TREE_CODE (DECL_SIZE (decl
)) == INTEGER_CST
);
584 /* Handle setting of GFC_DECL_SCALAR* on DECL. */
587 gfc_finish_decl_attrs (tree decl
, symbol_attribute
*attr
)
589 if (!attr
->dimension
&& !attr
->codimension
)
591 /* Handle scalar allocatable variables. */
592 if (attr
->allocatable
)
594 gfc_allocate_lang_decl (decl
);
595 GFC_DECL_SCALAR_ALLOCATABLE (decl
) = 1;
597 /* Handle scalar pointer variables. */
600 gfc_allocate_lang_decl (decl
);
601 GFC_DECL_SCALAR_POINTER (decl
) = 1;
605 gfc_allocate_lang_decl (decl
);
606 GFC_DECL_SCALAR_TARGET (decl
) = 1;
612 /* Apply symbol attributes to a variable, and add it to the function scope. */
615 gfc_finish_var_decl (tree decl
, gfc_symbol
* sym
)
619 /* Set DECL_VALUE_EXPR for Cray Pointees. */
620 if (sym
->attr
.cray_pointee
)
621 gfc_finish_cray_pointee (decl
, sym
);
623 /* TREE_ADDRESSABLE means the address of this variable is actually needed.
624 This is the equivalent of the TARGET variables.
625 We also need to set this if the variable is passed by reference in a
627 if (sym
->attr
.target
)
628 TREE_ADDRESSABLE (decl
) = 1;
630 /* If it wasn't used we wouldn't be getting it. */
631 TREE_USED (decl
) = 1;
633 if (sym
->attr
.flavor
== FL_PARAMETER
634 && (sym
->attr
.dimension
|| sym
->ts
.type
== BT_DERIVED
))
635 TREE_READONLY (decl
) = 1;
637 /* Chain this decl to the pending declarations. Don't do pushdecl()
638 because this would add them to the current scope rather than the
640 if (current_function_decl
!= NULL_TREE
)
642 if (sym
->ns
->proc_name
643 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
644 || sym
->result
== sym
))
645 gfc_add_decl_to_function (decl
);
646 else if (sym
->ns
->proc_name
647 && sym
->ns
->proc_name
->attr
.flavor
== FL_LABEL
)
648 /* This is a BLOCK construct. */
649 add_decl_as_local (decl
);
650 else if (sym
->ns
->omp_affinity_iterators
)
651 /* This is a block-local iterator. */
652 add_decl_as_local (decl
);
654 gfc_add_decl_to_parent_function (decl
);
657 if (sym
->attr
.cray_pointee
)
660 if(sym
->attr
.is_bind_c
== 1 && sym
->binding_label
)
662 /* We need to put variables that are bind(c) into the common
663 segment of the object file, because this is what C would do.
664 gfortran would typically put them in either the BSS or
665 initialized data segments, and only mark them as common if
666 they were part of common blocks. However, if they are not put
667 into common space, then C cannot initialize global Fortran
668 variables that it interoperates with and the draft says that
669 either Fortran or C should be able to initialize it (but not
670 both, of course.) (J3/04-007, section 15.3). */
671 TREE_PUBLIC(decl
) = 1;
672 DECL_COMMON(decl
) = 1;
673 if (sym
->attr
.access
== ACCESS_PRIVATE
&& !sym
->attr
.public_used
)
675 DECL_VISIBILITY (decl
) = VISIBILITY_HIDDEN
;
676 DECL_VISIBILITY_SPECIFIED (decl
) = true;
680 /* If a variable is USE associated, it's always external. */
681 if (sym
->attr
.use_assoc
|| sym
->attr
.used_in_submodule
)
683 DECL_EXTERNAL (decl
) = 1;
684 TREE_PUBLIC (decl
) = 1;
686 else if (sym
->fn_result_spec
&& !sym
->ns
->proc_name
->module
)
689 if (sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_DECL
)
690 DECL_EXTERNAL (decl
) = 1;
692 TREE_STATIC (decl
) = 1;
694 TREE_PUBLIC (decl
) = 1;
696 else if (sym
->module
&& !sym
->attr
.result
&& !sym
->attr
.dummy
)
698 /* TODO: Don't set sym->module for result or dummy variables. */
699 gcc_assert (current_function_decl
== NULL_TREE
|| sym
->result
== sym
);
701 TREE_PUBLIC (decl
) = 1;
702 TREE_STATIC (decl
) = 1;
703 if (sym
->attr
.access
== ACCESS_PRIVATE
&& !sym
->attr
.public_used
)
705 DECL_VISIBILITY (decl
) = VISIBILITY_HIDDEN
;
706 DECL_VISIBILITY_SPECIFIED (decl
) = true;
710 /* Derived types are a bit peculiar because of the possibility of
711 a default initializer; this must be applied each time the variable
712 comes into scope it therefore need not be static. These variables
713 are SAVE_NONE but have an initializer. Otherwise explicitly
714 initialized variables are SAVE_IMPLICIT and explicitly saved are
716 if (!sym
->attr
.use_assoc
717 && (sym
->attr
.save
!= SAVE_NONE
|| sym
->attr
.data
718 || (sym
->value
&& sym
->ns
->proc_name
->attr
.is_main_program
)
719 || (flag_coarray
== GFC_FCOARRAY_LIB
720 && sym
->attr
.codimension
&& !sym
->attr
.allocatable
)))
721 TREE_STATIC (decl
) = 1;
723 /* If derived-type variables with DTIO procedures are not made static
724 some bits of code referencing them get optimized away.
725 TODO Understand why this is so and fix it. */
726 if (!sym
->attr
.use_assoc
727 && ((sym
->ts
.type
== BT_DERIVED
728 && sym
->ts
.u
.derived
->attr
.has_dtio_procs
)
729 || (sym
->ts
.type
== BT_CLASS
730 && CLASS_DATA (sym
)->ts
.u
.derived
->attr
.has_dtio_procs
)))
731 TREE_STATIC (decl
) = 1;
733 /* Treat asynchronous variables the same as volatile, for now. */
734 if (sym
->attr
.volatile_
|| sym
->attr
.asynchronous
)
736 TREE_THIS_VOLATILE (decl
) = 1;
737 TREE_SIDE_EFFECTS (decl
) = 1;
738 new_type
= build_qualified_type (TREE_TYPE (decl
), TYPE_QUAL_VOLATILE
);
739 TREE_TYPE (decl
) = new_type
;
742 /* Keep variables larger than max-stack-var-size off stack. */
743 if (!(sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.recursive
)
744 && !sym
->attr
.automatic
745 && !sym
->attr
.associate_var
746 && sym
->attr
.save
!= SAVE_EXPLICIT
747 && sym
->attr
.save
!= SAVE_IMPLICIT
748 && INTEGER_CST_P (DECL_SIZE_UNIT (decl
))
749 && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl
))
750 /* Put variable length auto array pointers always into stack. */
751 && (TREE_CODE (TREE_TYPE (decl
)) != POINTER_TYPE
752 || sym
->attr
.dimension
== 0
753 || sym
->as
->type
!= AS_EXPLICIT
755 || sym
->attr
.allocatable
)
756 && !DECL_ARTIFICIAL (decl
))
758 if (flag_max_stack_var_size
> 0
759 && !(sym
->ns
->proc_name
760 && sym
->ns
->proc_name
->attr
.is_main_program
))
761 gfc_warning (OPT_Wsurprising
,
762 "Array %qs at %L is larger than limit set by "
763 "%<-fmax-stack-var-size=%>, moved from stack to static "
764 "storage. This makes the procedure unsafe when called "
765 "recursively, or concurrently from multiple threads. "
766 "Consider increasing the %<-fmax-stack-var-size=%> "
767 "limit (or use %<-frecursive%>, which implies "
768 "unlimited %<-fmax-stack-var-size%>) - or change the "
769 "code to use an ALLOCATABLE array. If the variable is "
770 "never accessed concurrently, this warning can be "
771 "ignored, and the variable could also be declared with "
772 "the SAVE attribute.",
773 sym
->name
, &sym
->declared_at
);
775 TREE_STATIC (decl
) = 1;
777 /* Because the size of this variable isn't known until now, we may have
778 greedily added an initializer to this variable (in build_init_assign)
779 even though the max-stack-var-size indicates the variable should be
780 static. Therefore we rip out the automatic initializer here and
781 replace it with a static one. */
782 gfc_symtree
*st
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
783 gfc_code
*prev
= NULL
;
784 gfc_code
*code
= sym
->ns
->code
;
785 while (code
&& code
->op
== EXEC_INIT_ASSIGN
)
787 /* Look for an initializer meant for this symbol. */
788 if (code
->expr1
->symtree
== st
)
791 prev
->next
= code
->next
;
793 sym
->ns
->code
= code
->next
;
801 if (code
&& code
->op
== EXEC_INIT_ASSIGN
)
803 /* Keep the init expression for a static initializer. */
804 sym
->value
= code
->expr2
;
805 /* Cleanup the defunct code object, without freeing the init expr. */
807 gfc_free_statement (code
);
812 /* Handle threadprivate variables. */
813 if (sym
->attr
.threadprivate
814 && (TREE_STATIC (decl
) || DECL_EXTERNAL (decl
)))
815 set_decl_tls_model (decl
, decl_default_tls_model (decl
));
817 /* Mark weak variables. */
818 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_WEAK
))
821 gfc_finish_decl_attrs (decl
, &sym
->attr
);
825 /* Allocate the lang-specific part of a decl. */
828 gfc_allocate_lang_decl (tree decl
)
830 if (DECL_LANG_SPECIFIC (decl
) == NULL
)
831 DECL_LANG_SPECIFIC (decl
) = ggc_cleared_alloc
<struct lang_decl
> ();
834 /* Remember a symbol to generate initialization/cleanup code at function
838 gfc_defer_symbol_init (gfc_symbol
* sym
)
844 /* Don't add a symbol twice. */
848 last
= head
= sym
->ns
->proc_name
;
851 /* Make sure that setup code for dummy variables which are used in the
852 setup of other variables is generated first. */
855 /* Find the first dummy arg seen after us, or the first non-dummy arg.
856 This is a circular list, so don't go past the head. */
858 && (!p
->attr
.dummy
|| p
->dummy_order
> sym
->dummy_order
))
864 /* Insert in between last and p. */
870 /* Used in gfc_get_symbol_decl and gfc_get_derived_type to obtain the
871 backend_decl for a module symbol, if it all ready exists. If the
872 module gsymbol does not exist, it is created. If the symbol does
873 not exist, it is added to the gsymbol namespace. Returns true if
874 an existing backend_decl is found. */
877 gfc_get_module_backend_decl (gfc_symbol
*sym
)
883 gsym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->module
);
885 if (!gsym
|| (gsym
->ns
&& gsym
->type
== GSYM_MODULE
))
890 /* Check for a symbol with the same name. */
892 gfc_find_symbol (sym
->name
, gsym
->ns
, 0, &s
);
898 gsym
= gfc_get_gsymbol (sym
->module
, false);
899 gsym
->type
= GSYM_MODULE
;
900 gsym
->ns
= gfc_get_namespace (NULL
, 0);
903 st
= gfc_new_symtree (&gsym
->ns
->sym_root
, sym
->name
);
907 else if (gfc_fl_struct (sym
->attr
.flavor
))
909 if (s
&& s
->attr
.flavor
== FL_PROCEDURE
)
912 gcc_assert (s
->attr
.generic
);
913 for (intr
= s
->generic
; intr
; intr
= intr
->next
)
914 if (gfc_fl_struct (intr
->sym
->attr
.flavor
))
921 /* Normally we can assume that s is a derived-type symbol since it
922 shares a name with the derived-type sym. However if sym is a
923 STRUCTURE, it may in fact share a name with any other basic type
924 variable. If s is in fact of derived type then we can continue
925 looking for a duplicate type declaration. */
926 if (sym
->attr
.flavor
== FL_STRUCT
&& s
->ts
.type
== BT_DERIVED
)
931 if (gfc_fl_struct (s
->attr
.flavor
) && !s
->backend_decl
)
933 if (s
->attr
.flavor
== FL_UNION
)
934 s
->backend_decl
= gfc_get_union_type (s
);
936 s
->backend_decl
= gfc_get_derived_type (s
);
938 gfc_copy_dt_decls_ifequal (s
, sym
, true);
941 else if (s
->backend_decl
)
943 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
944 gfc_copy_dt_decls_ifequal (s
->ts
.u
.derived
, sym
->ts
.u
.derived
,
946 else if (sym
->ts
.type
== BT_CHARACTER
)
947 sym
->ts
.u
.cl
->backend_decl
= s
->ts
.u
.cl
->backend_decl
;
948 sym
->backend_decl
= s
->backend_decl
;
956 /* Create an array index type variable with function scope. */
959 create_index_var (const char * pfx
, int nest
)
963 decl
= gfc_create_var_np (gfc_array_index_type
, pfx
);
965 gfc_add_decl_to_parent_function (decl
);
967 gfc_add_decl_to_function (decl
);
972 /* Create variables to hold all the non-constant bits of info for a
973 descriptorless array. Remember these in the lang-specific part of the
977 gfc_build_qualified_array (tree decl
, gfc_symbol
* sym
)
982 gfc_namespace
* procns
;
983 symbol_attribute
*array_attr
;
985 bool is_classarray
= IS_CLASS_ARRAY (sym
);
987 type
= TREE_TYPE (decl
);
988 array_attr
= is_classarray
? &CLASS_DATA (sym
)->attr
: &sym
->attr
;
989 as
= is_classarray
? CLASS_DATA (sym
)->as
: sym
->as
;
991 /* We just use the descriptor, if there is one. */
992 if (GFC_DESCRIPTOR_TYPE_P (type
))
995 gcc_assert (GFC_ARRAY_TYPE_P (type
));
996 procns
= gfc_find_proc_namespace (sym
->ns
);
997 nest
= (procns
->proc_name
->backend_decl
!= current_function_decl
)
998 && !sym
->attr
.contained
;
1000 if (array_attr
->codimension
&& flag_coarray
== GFC_FCOARRAY_LIB
1001 && as
->type
!= AS_ASSUMED_SHAPE
1002 && GFC_TYPE_ARRAY_CAF_TOKEN (type
) == NULL_TREE
)
1005 tree token_type
= build_qualified_type (pvoid_type_node
,
1006 TYPE_QUAL_RESTRICT
);
1008 if (sym
->module
&& (sym
->attr
.use_assoc
1009 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
))
1012 = get_identifier (gfc_get_string (GFC_PREFIX ("caf_token%s"),
1013 IDENTIFIER_POINTER (gfc_sym_mangled_identifier (sym
))));
1014 token
= build_decl (DECL_SOURCE_LOCATION (decl
), VAR_DECL
, token_name
,
1016 if (sym
->attr
.use_assoc
)
1017 DECL_EXTERNAL (token
) = 1;
1019 TREE_STATIC (token
) = 1;
1021 TREE_PUBLIC (token
) = 1;
1023 if (sym
->attr
.access
== ACCESS_PRIVATE
&& !sym
->attr
.public_used
)
1025 DECL_VISIBILITY (token
) = VISIBILITY_HIDDEN
;
1026 DECL_VISIBILITY_SPECIFIED (token
) = true;
1031 token
= gfc_create_var_np (token_type
, "caf_token");
1032 TREE_STATIC (token
) = 1;
1035 GFC_TYPE_ARRAY_CAF_TOKEN (type
) = token
;
1036 DECL_ARTIFICIAL (token
) = 1;
1037 DECL_NONALIASED (token
) = 1;
1039 if (sym
->module
&& !sym
->attr
.use_assoc
)
1042 DECL_CONTEXT (token
) = sym
->ns
->proc_name
->backend_decl
;
1043 gfc_module_add_decl (cur_module
, token
);
1045 else if (sym
->attr
.host_assoc
1046 && TREE_CODE (DECL_CONTEXT (current_function_decl
))
1047 != TRANSLATION_UNIT_DECL
)
1048 gfc_add_decl_to_parent_function (token
);
1050 gfc_add_decl_to_function (token
);
1053 for (dim
= 0; dim
< GFC_TYPE_ARRAY_RANK (type
); dim
++)
1055 if (GFC_TYPE_ARRAY_LBOUND (type
, dim
) == NULL_TREE
)
1057 GFC_TYPE_ARRAY_LBOUND (type
, dim
) = create_index_var ("lbound", nest
);
1058 suppress_warning (GFC_TYPE_ARRAY_LBOUND (type
, dim
));
1060 /* Don't try to use the unknown bound for assumed shape arrays. */
1061 if (GFC_TYPE_ARRAY_UBOUND (type
, dim
) == NULL_TREE
1062 && (as
->type
!= AS_ASSUMED_SIZE
1063 || dim
< GFC_TYPE_ARRAY_RANK (type
) - 1))
1065 GFC_TYPE_ARRAY_UBOUND (type
, dim
) = create_index_var ("ubound", nest
);
1066 suppress_warning (GFC_TYPE_ARRAY_UBOUND (type
, dim
));
1069 if (GFC_TYPE_ARRAY_STRIDE (type
, dim
) == NULL_TREE
)
1071 GFC_TYPE_ARRAY_STRIDE (type
, dim
) = create_index_var ("stride", nest
);
1072 suppress_warning (GFC_TYPE_ARRAY_STRIDE (type
, dim
));
1075 for (dim
= GFC_TYPE_ARRAY_RANK (type
);
1076 dim
< GFC_TYPE_ARRAY_RANK (type
) + GFC_TYPE_ARRAY_CORANK (type
); dim
++)
1078 if (GFC_TYPE_ARRAY_LBOUND (type
, dim
) == NULL_TREE
)
1080 GFC_TYPE_ARRAY_LBOUND (type
, dim
) = create_index_var ("lbound", nest
);
1081 suppress_warning (GFC_TYPE_ARRAY_LBOUND (type
, dim
));
1083 /* Don't try to use the unknown ubound for the last coarray dimension. */
1084 if (GFC_TYPE_ARRAY_UBOUND (type
, dim
) == NULL_TREE
1085 && dim
< GFC_TYPE_ARRAY_RANK (type
) + GFC_TYPE_ARRAY_CORANK (type
) - 1)
1087 GFC_TYPE_ARRAY_UBOUND (type
, dim
) = create_index_var ("ubound", nest
);
1088 suppress_warning (GFC_TYPE_ARRAY_UBOUND (type
, dim
));
1091 if (GFC_TYPE_ARRAY_OFFSET (type
) == NULL_TREE
)
1093 GFC_TYPE_ARRAY_OFFSET (type
) = gfc_create_var_np (gfc_array_index_type
,
1095 suppress_warning (GFC_TYPE_ARRAY_OFFSET (type
));
1098 gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type
));
1100 gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type
));
1103 if (GFC_TYPE_ARRAY_SIZE (type
) == NULL_TREE
1104 && as
->type
!= AS_ASSUMED_SIZE
)
1106 GFC_TYPE_ARRAY_SIZE (type
) = create_index_var ("size", nest
);
1107 suppress_warning (GFC_TYPE_ARRAY_SIZE (type
));
1110 if (POINTER_TYPE_P (type
))
1112 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (type
)));
1113 gcc_assert (TYPE_LANG_SPECIFIC (type
)
1114 == TYPE_LANG_SPECIFIC (TREE_TYPE (type
)));
1115 type
= TREE_TYPE (type
);
1118 if (! COMPLETE_TYPE_P (type
) && GFC_TYPE_ARRAY_SIZE (type
))
1122 size
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
1123 GFC_TYPE_ARRAY_SIZE (type
), gfc_index_one_node
);
1124 range
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
1126 TYPE_DOMAIN (type
) = range
;
1130 if (TYPE_NAME (type
) != NULL_TREE
&& as
->rank
> 0
1131 && GFC_TYPE_ARRAY_UBOUND (type
, as
->rank
- 1) != NULL_TREE
1132 && VAR_P (GFC_TYPE_ARRAY_UBOUND (type
, as
->rank
- 1)))
1134 tree gtype
= DECL_ORIGINAL_TYPE (TYPE_NAME (type
));
1136 for (dim
= 0; dim
< as
->rank
- 1; dim
++)
1138 gcc_assert (TREE_CODE (gtype
) == ARRAY_TYPE
);
1139 gtype
= TREE_TYPE (gtype
);
1141 gcc_assert (TREE_CODE (gtype
) == ARRAY_TYPE
);
1142 if (TYPE_MAX_VALUE (TYPE_DOMAIN (gtype
)) == NULL
)
1143 TYPE_NAME (type
) = NULL_TREE
;
1146 if (TYPE_NAME (type
) == NULL_TREE
)
1148 tree gtype
= TREE_TYPE (type
), rtype
, type_decl
;
1150 for (dim
= as
->rank
- 1; dim
>= 0; dim
--)
1152 tree lbound
, ubound
;
1153 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
1154 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
1155 rtype
= build_range_type (gfc_array_index_type
, lbound
, ubound
);
1156 gtype
= build_array_type (gtype
, rtype
);
1157 /* Ensure the bound variables aren't optimized out at -O0.
1158 For -O1 and above they often will be optimized out, but
1159 can be tracked by VTA. Also set DECL_NAMELESS, so that
1160 the artificial lbound.N or ubound.N DECL_NAME doesn't
1161 end up in debug info. */
1164 && DECL_ARTIFICIAL (lbound
)
1165 && DECL_IGNORED_P (lbound
))
1167 if (DECL_NAME (lbound
)
1168 && strstr (IDENTIFIER_POINTER (DECL_NAME (lbound
)),
1170 DECL_NAMELESS (lbound
) = 1;
1171 DECL_IGNORED_P (lbound
) = 0;
1175 && DECL_ARTIFICIAL (ubound
)
1176 && DECL_IGNORED_P (ubound
))
1178 if (DECL_NAME (ubound
)
1179 && strstr (IDENTIFIER_POINTER (DECL_NAME (ubound
)),
1181 DECL_NAMELESS (ubound
) = 1;
1182 DECL_IGNORED_P (ubound
) = 0;
1185 TYPE_NAME (type
) = type_decl
= build_decl (input_location
,
1186 TYPE_DECL
, NULL
, gtype
);
1187 DECL_ORIGINAL_TYPE (type_decl
) = gtype
;
1192 /* For some dummy arguments we don't use the actual argument directly.
1193 Instead we create a local decl and use that. This allows us to perform
1194 initialization, and construct full type information. */
1197 gfc_build_dummy_array_decl (gfc_symbol
* sym
, tree dummy
)
1202 symbol_attribute
*array_attr
;
1207 bool is_classarray
= IS_CLASS_ARRAY (sym
);
1209 /* Use the array as and attr. */
1210 as
= is_classarray
? CLASS_DATA (sym
)->as
: sym
->as
;
1211 array_attr
= is_classarray
? &CLASS_DATA (sym
)->attr
: &sym
->attr
;
1213 /* The dummy is returned for pointer, allocatable or assumed rank arrays.
1214 For class arrays the information if sym is an allocatable or pointer
1215 object needs to be checked explicitly (IS_CLASS_ARRAY can be false for
1216 too many reasons to be of use here). */
1217 if ((sym
->ts
.type
!= BT_CLASS
&& sym
->attr
.pointer
)
1218 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->attr
.class_pointer
)
1219 || array_attr
->allocatable
1220 || (as
&& as
->type
== AS_ASSUMED_RANK
))
1223 /* Add to list of variables if not a fake result variable.
1224 These symbols are set on the symbol only, not on the class component. */
1225 if (sym
->attr
.result
|| sym
->attr
.dummy
)
1226 gfc_defer_symbol_init (sym
);
1228 /* For a class array the array descriptor is in the _data component, while
1229 for a regular array the TREE_TYPE of the dummy is a pointer to the
1231 type
= TREE_TYPE (is_classarray
? gfc_class_data_get (dummy
)
1232 : TREE_TYPE (dummy
));
1233 /* type now is the array descriptor w/o any indirection. */
1234 gcc_assert (TREE_CODE (dummy
) == PARM_DECL
1235 && POINTER_TYPE_P (TREE_TYPE (dummy
)));
1237 /* Do we know the element size? */
1238 known_size
= sym
->ts
.type
!= BT_CHARACTER
1239 || INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
);
1241 if (known_size
&& !GFC_DESCRIPTOR_TYPE_P (type
))
1243 /* For descriptorless arrays with known element size the actual
1244 argument is sufficient. */
1245 gfc_build_qualified_array (dummy
, sym
);
1249 if (GFC_DESCRIPTOR_TYPE_P (type
))
1251 /* Create a descriptorless array pointer. */
1254 /* Even when -frepack-arrays is used, symbols with TARGET attribute
1255 are not repacked. */
1256 if (!flag_repack_arrays
|| sym
->attr
.target
)
1258 if (as
->type
== AS_ASSUMED_SIZE
)
1259 packed
= PACKED_FULL
;
1263 if (as
->type
== AS_EXPLICIT
)
1265 packed
= PACKED_FULL
;
1266 for (n
= 0; n
< as
->rank
; n
++)
1270 && as
->upper
[n
]->expr_type
== EXPR_CONSTANT
1271 && as
->lower
[n
]->expr_type
== EXPR_CONSTANT
))
1273 packed
= PACKED_PARTIAL
;
1279 packed
= PACKED_PARTIAL
;
1282 /* For classarrays the element type is required, but
1283 gfc_typenode_for_spec () returns the array descriptor. */
1284 type
= is_classarray
? gfc_get_element_type (type
)
1285 : gfc_typenode_for_spec (&sym
->ts
);
1286 type
= gfc_get_nodesc_array_type (type
, as
, packed
,
1291 /* We now have an expression for the element size, so create a fully
1292 qualified type. Reset sym->backend decl or this will just return the
1294 DECL_ARTIFICIAL (sym
->backend_decl
) = 1;
1295 sym
->backend_decl
= NULL_TREE
;
1296 type
= gfc_sym_type (sym
);
1297 packed
= PACKED_FULL
;
1300 ASM_FORMAT_PRIVATE_NAME (name
, IDENTIFIER_POINTER (DECL_NAME (dummy
)), 0);
1301 decl
= build_decl (input_location
,
1302 VAR_DECL
, get_identifier (name
), type
);
1304 DECL_ARTIFICIAL (decl
) = 1;
1305 DECL_NAMELESS (decl
) = 1;
1306 TREE_PUBLIC (decl
) = 0;
1307 TREE_STATIC (decl
) = 0;
1308 DECL_EXTERNAL (decl
) = 0;
1310 /* Avoid uninitialized warnings for optional dummy arguments. */
1311 if ((sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->attr
.optional
)
1312 || sym
->attr
.optional
)
1313 suppress_warning (decl
);
1315 /* We should never get deferred shape arrays here. We used to because of
1317 gcc_assert (as
->type
!= AS_DEFERRED
);
1319 if (packed
== PACKED_PARTIAL
)
1320 GFC_DECL_PARTIAL_PACKED_ARRAY (decl
) = 1;
1321 else if (packed
== PACKED_FULL
)
1322 GFC_DECL_PACKED_ARRAY (decl
) = 1;
1324 gfc_build_qualified_array (decl
, sym
);
1326 if (DECL_LANG_SPECIFIC (dummy
))
1327 DECL_LANG_SPECIFIC (decl
) = DECL_LANG_SPECIFIC (dummy
);
1329 gfc_allocate_lang_decl (decl
);
1331 GFC_DECL_SAVED_DESCRIPTOR (decl
) = dummy
;
1333 if (sym
->ns
->proc_name
->backend_decl
== current_function_decl
1334 || sym
->attr
.contained
)
1335 gfc_add_decl_to_function (decl
);
1337 gfc_add_decl_to_parent_function (decl
);
1342 /* Return a constant or a variable to use as a string length. Does not
1343 add the decl to the current scope. */
1346 gfc_create_string_length (gfc_symbol
* sym
)
1348 gcc_assert (sym
->ts
.u
.cl
);
1349 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
1351 if (sym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
1356 /* The string length variable shall be in static memory if it is either
1357 explicitly SAVED, a module variable or with -fno-automatic. Only
1358 relevant is "len=:" - otherwise, it is either a constant length or
1359 it is an automatic variable. */
1360 bool static_length
= sym
->attr
.save
1361 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
1362 || (flag_max_stack_var_size
== 0
1363 && sym
->ts
.deferred
&& !sym
->attr
.dummy
1364 && !sym
->attr
.result
&& !sym
->attr
.function
);
1366 /* Also prefix the mangled name. We need to call GFC_PREFIX for static
1367 variables as some systems do not support the "." in the assembler name.
1368 For nonstatic variables, the "." does not appear in assembler. */
1372 name
= gfc_get_string (GFC_PREFIX ("%s_MOD_%s"), sym
->module
,
1375 name
= gfc_get_string (GFC_PREFIX ("%s"), sym
->name
);
1377 else if (sym
->module
)
1378 name
= gfc_get_string (".__%s_MOD_%s", sym
->module
, sym
->name
);
1380 name
= gfc_get_string (".%s", sym
->name
);
1382 length
= build_decl (input_location
,
1383 VAR_DECL
, get_identifier (name
),
1384 gfc_charlen_type_node
);
1385 DECL_ARTIFICIAL (length
) = 1;
1386 TREE_USED (length
) = 1;
1387 if (sym
->ns
->proc_name
->tlink
!= NULL
)
1388 gfc_defer_symbol_init (sym
);
1390 sym
->ts
.u
.cl
->backend_decl
= length
;
1393 TREE_STATIC (length
) = 1;
1395 if (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
1396 && (sym
->attr
.access
!= ACCESS_PRIVATE
|| sym
->attr
.public_used
))
1397 TREE_PUBLIC (length
) = 1;
1400 gcc_assert (sym
->ts
.u
.cl
->backend_decl
!= NULL_TREE
);
1401 return sym
->ts
.u
.cl
->backend_decl
;
1404 /* If a variable is assigned a label, we add another two auxiliary
1408 gfc_add_assign_aux_vars (gfc_symbol
* sym
)
1414 gcc_assert (sym
->backend_decl
);
1416 decl
= sym
->backend_decl
;
1417 gfc_allocate_lang_decl (decl
);
1418 GFC_DECL_ASSIGN (decl
) = 1;
1419 length
= build_decl (input_location
,
1420 VAR_DECL
, create_tmp_var_name (sym
->name
),
1421 gfc_charlen_type_node
);
1422 addr
= build_decl (input_location
,
1423 VAR_DECL
, create_tmp_var_name (sym
->name
),
1425 gfc_finish_var_decl (length
, sym
);
1426 gfc_finish_var_decl (addr
, sym
);
1427 /* STRING_LENGTH is also used as flag. Less than -1 means that
1428 ASSIGN_ADDR cannot be used. Equal -1 means that ASSIGN_ADDR is the
1429 target label's address. Otherwise, value is the length of a format string
1430 and ASSIGN_ADDR is its address. */
1431 if (TREE_STATIC (length
))
1432 DECL_INITIAL (length
) = build_int_cst (gfc_charlen_type_node
, -2);
1434 gfc_defer_symbol_init (sym
);
1436 GFC_DECL_STRING_LEN (decl
) = length
;
1437 GFC_DECL_ASSIGN_ADDR (decl
) = addr
;
1442 add_attributes_to_decl (symbol_attribute sym_attr
, tree list
)
1447 for (id
= 0; id
< EXT_ATTR_NUM
; id
++)
1448 if (sym_attr
.ext_attr
& (1 << id
) && ext_attr_list
[id
].middle_end_name
)
1450 attr
= build_tree_list (
1451 get_identifier (ext_attr_list
[id
].middle_end_name
),
1453 list
= chainon (list
, attr
);
1456 tree clauses
= NULL_TREE
;
1458 if (sym_attr
.oacc_routine_lop
!= OACC_ROUTINE_LOP_NONE
)
1460 omp_clause_code code
;
1461 switch (sym_attr
.oacc_routine_lop
)
1463 case OACC_ROUTINE_LOP_GANG
:
1464 code
= OMP_CLAUSE_GANG
;
1466 case OACC_ROUTINE_LOP_WORKER
:
1467 code
= OMP_CLAUSE_WORKER
;
1469 case OACC_ROUTINE_LOP_VECTOR
:
1470 code
= OMP_CLAUSE_VECTOR
;
1472 case OACC_ROUTINE_LOP_SEQ
:
1473 code
= OMP_CLAUSE_SEQ
;
1475 case OACC_ROUTINE_LOP_NONE
:
1476 case OACC_ROUTINE_LOP_ERROR
:
1480 tree c
= build_omp_clause (UNKNOWN_LOCATION
, code
);
1481 OMP_CLAUSE_CHAIN (c
) = clauses
;
1484 tree dims
= oacc_build_routine_dims (clauses
);
1485 list
= oacc_replace_fn_attrib_attr (list
, dims
);
1488 if (sym_attr
.oacc_routine_nohost
)
1490 tree c
= build_omp_clause (UNKNOWN_LOCATION
, OMP_CLAUSE_NOHOST
);
1491 OMP_CLAUSE_CHAIN (c
) = clauses
;
1495 if (sym_attr
.omp_device_type
!= OMP_DEVICE_TYPE_UNSET
)
1497 tree c
= build_omp_clause (UNKNOWN_LOCATION
, OMP_CLAUSE_DEVICE_TYPE
);
1498 switch (sym_attr
.omp_device_type
)
1500 case OMP_DEVICE_TYPE_HOST
:
1501 OMP_CLAUSE_DEVICE_TYPE_KIND (c
) = OMP_CLAUSE_DEVICE_TYPE_HOST
;
1503 case OMP_DEVICE_TYPE_NOHOST
:
1504 OMP_CLAUSE_DEVICE_TYPE_KIND (c
) = OMP_CLAUSE_DEVICE_TYPE_NOHOST
;
1506 case OMP_DEVICE_TYPE_ANY
:
1507 OMP_CLAUSE_DEVICE_TYPE_KIND (c
) = OMP_CLAUSE_DEVICE_TYPE_ANY
;
1512 OMP_CLAUSE_CHAIN (c
) = clauses
;
1516 if (sym_attr
.omp_declare_target_link
1517 || sym_attr
.oacc_declare_link
)
1518 list
= tree_cons (get_identifier ("omp declare target link"),
1520 else if (sym_attr
.omp_declare_target
1521 || sym_attr
.oacc_declare_create
1522 || sym_attr
.oacc_declare_copyin
1523 || sym_attr
.oacc_declare_deviceptr
1524 || sym_attr
.oacc_declare_device_resident
)
1525 list
= tree_cons (get_identifier ("omp declare target"),
1532 static void build_function_decl (gfc_symbol
* sym
, bool global
);
1535 /* Return the decl for a gfc_symbol, create it if it doesn't already
1539 gfc_get_symbol_decl (gfc_symbol
* sym
)
1542 tree length
= NULL_TREE
;
1545 bool intrinsic_array_parameter
= false;
1548 gcc_assert (sym
->attr
.referenced
1549 || sym
->attr
.flavor
== FL_PROCEDURE
1550 || sym
->attr
.use_assoc
1551 || sym
->attr
.used_in_submodule
1552 || sym
->ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
1553 || (sym
->module
&& sym
->attr
.if_source
!= IFSRC_DECL
1554 && sym
->backend_decl
));
1556 if (sym
->attr
.dummy
&& sym
->ns
->proc_name
->attr
.is_bind_c
1557 && is_CFI_desc (sym
, NULL
))
1559 gcc_assert (sym
->backend_decl
&& (sym
->ts
.type
!= BT_CHARACTER
1560 || sym
->ts
.u
.cl
->backend_decl
));
1561 return sym
->backend_decl
;
1564 if (sym
->ns
&& sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.function
)
1565 byref
= gfc_return_by_reference (sym
->ns
->proc_name
);
1569 /* Make sure that the vtab for the declared type is completed. */
1570 if (sym
->ts
.type
== BT_CLASS
)
1572 gfc_component
*c
= CLASS_DATA (sym
);
1573 if (!c
->ts
.u
.derived
->backend_decl
)
1575 gfc_find_derived_vtab (c
->ts
.u
.derived
);
1576 gfc_get_derived_type (sym
->ts
.u
.derived
);
1580 /* PDT parameterized array components and string_lengths must have the
1581 'len' parameters substituted for the expressions appearing in the
1582 declaration of the entity and memory allocated/deallocated. */
1583 if ((sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
1584 && sym
->param_list
!= NULL
1585 && gfc_current_ns
== sym
->ns
1586 && !(sym
->attr
.use_assoc
|| sym
->attr
.dummy
))
1587 gfc_defer_symbol_init (sym
);
1589 /* Dummy PDT 'len' parameters should be checked when they are explicit. */
1590 if ((sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
1591 && (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1592 && sym
->param_list
!= NULL
1594 gfc_defer_symbol_init (sym
);
1596 /* All deferred character length procedures need to retain the backend
1597 decl, which is a pointer to the character length in the caller's
1598 namespace and to declare a local character length. */
1599 if (!byref
&& sym
->attr
.function
1600 && sym
->ts
.type
== BT_CHARACTER
1602 && sym
->ts
.u
.cl
->passed_length
== NULL
1603 && sym
->ts
.u
.cl
->backend_decl
1604 && TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) == PARM_DECL
)
1606 sym
->ts
.u
.cl
->passed_length
= sym
->ts
.u
.cl
->backend_decl
;
1607 gcc_assert (POINTER_TYPE_P (TREE_TYPE (sym
->ts
.u
.cl
->passed_length
)));
1608 sym
->ts
.u
.cl
->backend_decl
= build_fold_indirect_ref (sym
->ts
.u
.cl
->backend_decl
);
1611 fun_or_res
= byref
&& (sym
->attr
.result
1612 || (sym
->attr
.function
&& sym
->ts
.deferred
));
1613 if ((sym
->attr
.dummy
&& ! sym
->attr
.function
) || fun_or_res
)
1615 /* Return via extra parameter. */
1616 if (sym
->attr
.result
&& byref
1617 && !sym
->backend_decl
)
1620 DECL_ARGUMENTS (sym
->ns
->proc_name
->backend_decl
);
1621 /* For entry master function skip over the __entry
1623 if (sym
->ns
->proc_name
->attr
.entry_master
)
1624 sym
->backend_decl
= DECL_CHAIN (sym
->backend_decl
);
1627 /* Dummy variables should already have been created. */
1628 gcc_assert (sym
->backend_decl
);
1630 /* However, the string length of deferred arrays must be set. */
1631 if (sym
->ts
.type
== BT_CHARACTER
1633 && sym
->attr
.dimension
1634 && sym
->attr
.allocatable
)
1635 gfc_defer_symbol_init (sym
);
1637 if (sym
->attr
.pointer
&& sym
->attr
.dimension
&& sym
->ts
.type
!= BT_CLASS
)
1638 GFC_DECL_PTR_ARRAY_P (sym
->backend_decl
) = 1;
1640 /* Create a character length variable. */
1641 if (sym
->ts
.type
== BT_CHARACTER
)
1643 /* For a deferred dummy, make a new string length variable. */
1644 if (sym
->ts
.deferred
1646 (sym
->ts
.u
.cl
->passed_length
== sym
->ts
.u
.cl
->backend_decl
))
1647 sym
->ts
.u
.cl
->backend_decl
= NULL_TREE
;
1649 if (sym
->ts
.deferred
&& byref
)
1651 /* The string length of a deferred char array is stored in the
1652 parameter at sym->ts.u.cl->backend_decl as a reference and
1653 marked as a result. Exempt this variable from generating a
1654 temporary for it. */
1655 if (sym
->attr
.result
)
1657 /* We need to insert a indirect ref for param decls. */
1658 if (sym
->ts
.u
.cl
->backend_decl
1659 && TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) == PARM_DECL
)
1661 sym
->ts
.u
.cl
->passed_length
= sym
->ts
.u
.cl
->backend_decl
;
1662 sym
->ts
.u
.cl
->backend_decl
=
1663 build_fold_indirect_ref (sym
->ts
.u
.cl
->backend_decl
);
1666 /* For all other parameters make sure, that they are copied so
1667 that the value and any modifications are local to the routine
1668 by generating a temporary variable. */
1669 else if (sym
->attr
.function
1670 && sym
->ts
.u
.cl
->passed_length
== NULL
1671 && sym
->ts
.u
.cl
->backend_decl
)
1673 sym
->ts
.u
.cl
->passed_length
= sym
->ts
.u
.cl
->backend_decl
;
1674 if (POINTER_TYPE_P (TREE_TYPE (sym
->ts
.u
.cl
->passed_length
)))
1675 sym
->ts
.u
.cl
->backend_decl
1676 = build_fold_indirect_ref (sym
->ts
.u
.cl
->backend_decl
);
1678 sym
->ts
.u
.cl
->backend_decl
= NULL_TREE
;
1682 if (sym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
1683 length
= gfc_create_string_length (sym
);
1685 length
= sym
->ts
.u
.cl
->backend_decl
;
1686 if (VAR_P (length
) && DECL_FILE_SCOPE_P (length
))
1688 /* Add the string length to the same context as the symbol. */
1689 if (DECL_CONTEXT (length
) == NULL_TREE
)
1691 if (sym
->backend_decl
== current_function_decl
1692 || (DECL_CONTEXT (sym
->backend_decl
)
1693 == current_function_decl
))
1694 gfc_add_decl_to_function (length
);
1696 gfc_add_decl_to_parent_function (length
);
1699 gcc_assert (sym
->backend_decl
== current_function_decl
1700 ? DECL_CONTEXT (length
) == current_function_decl
1701 : (DECL_CONTEXT (sym
->backend_decl
)
1702 == DECL_CONTEXT (length
)));
1704 gfc_defer_symbol_init (sym
);
1708 /* Use a copy of the descriptor for dummy arrays. */
1709 if ((sym
->attr
.dimension
|| sym
->attr
.codimension
)
1710 && !TREE_USED (sym
->backend_decl
))
1712 decl
= gfc_build_dummy_array_decl (sym
, sym
->backend_decl
);
1713 /* Prevent the dummy from being detected as unused if it is copied. */
1714 if (sym
->backend_decl
!= NULL
&& decl
!= sym
->backend_decl
)
1715 DECL_ARTIFICIAL (sym
->backend_decl
) = 1;
1716 sym
->backend_decl
= decl
;
1719 /* Returning the descriptor for dummy class arrays is hazardous, because
1720 some caller is expecting an expression to apply the component refs to.
1721 Therefore the descriptor is only created and stored in
1722 sym->backend_decl's GFC_DECL_SAVED_DESCRIPTOR. The caller is then
1723 responsible to extract it from there, when the descriptor is
1725 if (IS_CLASS_ARRAY (sym
)
1726 && (!DECL_LANG_SPECIFIC (sym
->backend_decl
)
1727 || !GFC_DECL_SAVED_DESCRIPTOR (sym
->backend_decl
)))
1729 decl
= gfc_build_dummy_array_decl (sym
, sym
->backend_decl
);
1730 /* Prevent the dummy from being detected as unused if it is copied. */
1731 if (sym
->backend_decl
!= NULL
&& decl
!= sym
->backend_decl
)
1732 DECL_ARTIFICIAL (sym
->backend_decl
) = 1;
1733 sym
->backend_decl
= decl
;
1736 TREE_USED (sym
->backend_decl
) = 1;
1737 if (sym
->attr
.assign
&& GFC_DECL_ASSIGN (sym
->backend_decl
) == 0)
1738 gfc_add_assign_aux_vars (sym
);
1740 if (sym
->ts
.type
== BT_CLASS
&& sym
->backend_decl
)
1741 GFC_DECL_CLASS(sym
->backend_decl
) = 1;
1743 return sym
->backend_decl
;
1746 if (sym
->result
== sym
&& sym
->attr
.assign
1747 && GFC_DECL_ASSIGN (sym
->backend_decl
) == 0)
1748 gfc_add_assign_aux_vars (sym
);
1750 if (sym
->backend_decl
)
1751 return sym
->backend_decl
;
1753 /* Special case for array-valued named constants from intrinsic
1754 procedures; those are inlined. */
1755 if (sym
->attr
.use_assoc
&& sym
->attr
.flavor
== FL_PARAMETER
1756 && (sym
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
1757 || sym
->from_intmod
== INTMOD_ISO_C_BINDING
))
1758 intrinsic_array_parameter
= true;
1760 /* If use associated compilation, use the module
1762 if ((sym
->attr
.flavor
== FL_VARIABLE
1763 || sym
->attr
.flavor
== FL_PARAMETER
)
1764 && (sym
->attr
.use_assoc
|| sym
->attr
.used_in_submodule
)
1765 && !intrinsic_array_parameter
1767 && gfc_get_module_backend_decl (sym
))
1769 if (sym
->ts
.type
== BT_CLASS
&& sym
->backend_decl
)
1770 GFC_DECL_CLASS(sym
->backend_decl
) = 1;
1771 return sym
->backend_decl
;
1774 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1776 /* Catch functions. Only used for actual parameters,
1777 procedure pointers and procptr initialization targets. */
1778 if (sym
->attr
.use_assoc
1779 || sym
->attr
.used_in_submodule
1780 || sym
->attr
.intrinsic
1781 || sym
->attr
.if_source
!= IFSRC_DECL
)
1783 decl
= gfc_get_extern_function_decl (sym
);
1787 if (!sym
->backend_decl
)
1788 build_function_decl (sym
, false);
1789 decl
= sym
->backend_decl
;
1794 if (sym
->attr
.intrinsic
)
1795 gfc_internal_error ("intrinsic variable which isn't a procedure");
1797 /* Create string length decl first so that they can be used in the
1798 type declaration. For associate names, the target character
1799 length is used. Set 'length' to a constant so that if the
1800 string length is a variable, it is not finished a second time. */
1801 if (sym
->ts
.type
== BT_CHARACTER
)
1803 if (sym
->attr
.associate_var
1805 && sym
->assoc
&& sym
->assoc
->target
1806 && ((sym
->assoc
->target
->expr_type
== EXPR_VARIABLE
1807 && sym
->assoc
->target
->symtree
->n
.sym
->ts
.type
!= BT_CHARACTER
)
1808 || sym
->assoc
->target
->expr_type
!= EXPR_VARIABLE
))
1809 sym
->ts
.u
.cl
->backend_decl
= NULL_TREE
;
1811 if (sym
->attr
.associate_var
1812 && sym
->ts
.u
.cl
->backend_decl
1813 && (VAR_P (sym
->ts
.u
.cl
->backend_decl
)
1814 || TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) == PARM_DECL
))
1815 length
= gfc_index_zero_node
;
1817 length
= gfc_create_string_length (sym
);
1820 /* Create the decl for the variable. */
1821 decl
= build_decl (gfc_get_location (&sym
->declared_at
),
1822 VAR_DECL
, gfc_sym_identifier (sym
), gfc_sym_type (sym
));
1824 /* Add attributes to variables. Functions are handled elsewhere. */
1825 attributes
= add_attributes_to_decl (sym
->attr
, NULL_TREE
);
1826 decl_attributes (&decl
, attributes
, 0);
1828 /* Symbols from modules should have their assembler names mangled.
1829 This is done here rather than in gfc_finish_var_decl because it
1830 is different for string length variables. */
1831 if (sym
->module
|| sym
->fn_result_spec
)
1833 gfc_set_decl_assembler_name (decl
, gfc_sym_mangled_identifier (sym
));
1834 if (sym
->attr
.use_assoc
&& !intrinsic_array_parameter
)
1835 DECL_IGNORED_P (decl
) = 1;
1838 if (sym
->attr
.select_type_temporary
)
1840 DECL_ARTIFICIAL (decl
) = 1;
1841 DECL_IGNORED_P (decl
) = 1;
1844 if (sym
->attr
.dimension
|| sym
->attr
.codimension
)
1846 /* Create variables to hold the non-constant bits of array info. */
1847 gfc_build_qualified_array (decl
, sym
);
1849 if (sym
->attr
.contiguous
1850 || ((sym
->attr
.allocatable
|| !sym
->attr
.dummy
) && !sym
->attr
.pointer
))
1851 GFC_DECL_PACKED_ARRAY (decl
) = 1;
1854 /* Remember this variable for allocation/cleanup. */
1855 if (sym
->attr
.dimension
|| sym
->attr
.allocatable
|| sym
->attr
.codimension
1856 || (sym
->ts
.type
== BT_CLASS
&&
1857 (CLASS_DATA (sym
)->attr
.dimension
1858 || CLASS_DATA (sym
)->attr
.allocatable
))
1859 || (sym
->ts
.type
== BT_DERIVED
1860 && (sym
->ts
.u
.derived
->attr
.alloc_comp
1861 || (!sym
->attr
.pointer
&& !sym
->attr
.artificial
&& !sym
->attr
.save
1862 && !sym
->ns
->proc_name
->attr
.is_main_program
1863 && gfc_is_finalizable (sym
->ts
.u
.derived
, NULL
))))
1864 /* This applies a derived type default initializer. */
1865 || (sym
->ts
.type
== BT_DERIVED
1866 && sym
->attr
.save
== SAVE_NONE
1868 && !sym
->attr
.allocatable
1869 && (sym
->value
&& !sym
->ns
->proc_name
->attr
.is_main_program
)
1870 && !(sym
->attr
.use_assoc
&& !intrinsic_array_parameter
)))
1871 gfc_defer_symbol_init (sym
);
1873 if (sym
->ts
.type
== BT_CHARACTER
1874 && sym
->attr
.allocatable
1875 && !sym
->attr
.dimension
1876 && sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
1877 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_VARIABLE
)
1878 gfc_defer_symbol_init (sym
);
1880 /* Associate names can use the hidden string length variable
1881 of their associated target. */
1882 if (sym
->ts
.type
== BT_CHARACTER
1883 && TREE_CODE (length
) != INTEGER_CST
1884 && TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) != INDIRECT_REF
)
1886 length
= fold_convert (gfc_charlen_type_node
, length
);
1887 gfc_finish_var_decl (length
, sym
);
1888 if (!sym
->attr
.associate_var
1889 && TREE_CODE (length
) == VAR_DECL
1890 && sym
->value
&& sym
->value
->expr_type
!= EXPR_NULL
1891 && sym
->value
->ts
.u
.cl
->length
)
1893 gfc_expr
*len
= sym
->value
->ts
.u
.cl
->length
;
1894 DECL_INITIAL (length
) = gfc_conv_initializer (len
, &len
->ts
,
1896 false, false, false);
1897 DECL_INITIAL (length
) = fold_convert (gfc_charlen_type_node
,
1898 DECL_INITIAL (length
));
1901 gcc_assert (!sym
->value
|| sym
->value
->expr_type
== EXPR_NULL
);
1904 gfc_finish_var_decl (decl
, sym
);
1906 if (sym
->ts
.type
== BT_CHARACTER
)
1907 /* Character variables need special handling. */
1908 gfc_allocate_lang_decl (decl
);
1910 if (sym
->assoc
&& sym
->attr
.subref_array_pointer
)
1911 sym
->attr
.pointer
= 1;
1913 if (sym
->attr
.pointer
&& sym
->attr
.dimension
1914 && !sym
->ts
.deferred
1915 && !(sym
->attr
.select_type_temporary
1916 && !sym
->attr
.subref_array_pointer
))
1917 GFC_DECL_PTR_ARRAY_P (decl
) = 1;
1919 if (sym
->ts
.type
== BT_CLASS
)
1920 GFC_DECL_CLASS(decl
) = 1;
1922 sym
->backend_decl
= decl
;
1924 if (sym
->attr
.assign
)
1925 gfc_add_assign_aux_vars (sym
);
1927 if (intrinsic_array_parameter
)
1929 TREE_STATIC (decl
) = 1;
1930 DECL_EXTERNAL (decl
) = 0;
1933 if (TREE_STATIC (decl
)
1934 && !(sym
->attr
.use_assoc
&& !intrinsic_array_parameter
)
1935 && (sym
->attr
.save
|| sym
->ns
->proc_name
->attr
.is_main_program
1936 || !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl
))
1937 || sym
->attr
.data
|| sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
1938 && (flag_coarray
!= GFC_FCOARRAY_LIB
1939 || !sym
->attr
.codimension
|| sym
->attr
.allocatable
)
1940 && !(sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.pdt_type
)
1941 && !(sym
->ts
.type
== BT_CLASS
1942 && CLASS_DATA (sym
)->ts
.u
.derived
->attr
.pdt_type
))
1944 /* Add static initializer. For procedures, it is only needed if
1945 SAVE is specified otherwise they need to be reinitialized
1946 every time the procedure is entered. The TREE_STATIC is
1947 in this case due to -fmax-stack-var-size=. */
1949 DECL_INITIAL (decl
) = gfc_conv_initializer (sym
->value
, &sym
->ts
,
1950 TREE_TYPE (decl
), sym
->attr
.dimension
1951 || (sym
->attr
.codimension
1952 && sym
->attr
.allocatable
),
1953 sym
->attr
.pointer
|| sym
->attr
.allocatable
1954 || sym
->ts
.type
== BT_CLASS
,
1955 sym
->attr
.proc_pointer
);
1958 if (!TREE_STATIC (decl
)
1959 && POINTER_TYPE_P (TREE_TYPE (decl
))
1960 && !sym
->attr
.pointer
1961 && !sym
->attr
.allocatable
1962 && !sym
->attr
.proc_pointer
1963 && !sym
->attr
.select_type_temporary
)
1964 DECL_BY_REFERENCE (decl
) = 1;
1966 if (sym
->attr
.associate_var
)
1967 GFC_DECL_ASSOCIATE_VAR_P (decl
) = 1;
1969 /* We only longer mark __def_init as read-only if it actually has an
1970 initializer, it does not needlessly take up space in the
1971 read-only section and can go into the BSS instead, see PR 84487.
1972 Marking this as artificial means that OpenMP will treat this as
1973 predetermined shared. */
1975 bool def_init
= startswith (sym
->name
, "__def_init");
1977 if (sym
->attr
.vtab
|| def_init
)
1979 DECL_ARTIFICIAL (decl
) = 1;
1980 if (def_init
&& sym
->value
)
1981 TREE_READONLY (decl
) = 1;
1988 /* Substitute a temporary variable in place of the real one. */
1991 gfc_shadow_sym (gfc_symbol
* sym
, tree decl
, gfc_saved_var
* save
)
1993 save
->attr
= sym
->attr
;
1994 save
->decl
= sym
->backend_decl
;
1996 gfc_clear_attr (&sym
->attr
);
1997 sym
->attr
.referenced
= 1;
1998 sym
->attr
.flavor
= FL_VARIABLE
;
2000 sym
->backend_decl
= decl
;
2004 /* Restore the original variable. */
2007 gfc_restore_sym (gfc_symbol
* sym
, gfc_saved_var
* save
)
2009 sym
->attr
= save
->attr
;
2010 sym
->backend_decl
= save
->decl
;
2014 /* Declare a procedure pointer. */
2017 get_proc_pointer_decl (gfc_symbol
*sym
)
2022 if (sym
->module
|| sym
->fn_result_spec
)
2027 name
= mangled_identifier (sym
);
2028 gsym
= gfc_find_gsymbol (gfc_gsym_root
, name
);
2032 gfc_find_symbol (sym
->name
, gsym
->ns
, 0, &s
);
2033 if (s
&& s
->backend_decl
)
2034 return s
->backend_decl
;
2038 decl
= sym
->backend_decl
;
2042 decl
= build_decl (input_location
,
2043 VAR_DECL
, get_identifier (sym
->name
),
2044 build_pointer_type (gfc_get_function_type (sym
)));
2048 /* Apply name mangling. */
2049 gfc_set_decl_assembler_name (decl
, gfc_sym_mangled_identifier (sym
));
2050 if (sym
->attr
.use_assoc
)
2051 DECL_IGNORED_P (decl
) = 1;
2054 if ((sym
->ns
->proc_name
2055 && sym
->ns
->proc_name
->backend_decl
== current_function_decl
)
2056 || sym
->attr
.contained
)
2057 gfc_add_decl_to_function (decl
);
2058 else if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
2059 gfc_add_decl_to_parent_function (decl
);
2061 sym
->backend_decl
= decl
;
2063 /* If a variable is USE associated, it's always external. */
2064 if (sym
->attr
.use_assoc
)
2066 DECL_EXTERNAL (decl
) = 1;
2067 TREE_PUBLIC (decl
) = 1;
2069 else if (sym
->module
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2071 /* This is the declaration of a module variable. */
2072 TREE_PUBLIC (decl
) = 1;
2073 if (sym
->attr
.access
== ACCESS_PRIVATE
&& !sym
->attr
.public_used
)
2075 DECL_VISIBILITY (decl
) = VISIBILITY_HIDDEN
;
2076 DECL_VISIBILITY_SPECIFIED (decl
) = true;
2078 TREE_STATIC (decl
) = 1;
2081 if (!sym
->attr
.use_assoc
2082 && (sym
->attr
.save
!= SAVE_NONE
|| sym
->attr
.data
2083 || (sym
->value
&& sym
->ns
->proc_name
->attr
.is_main_program
)))
2084 TREE_STATIC (decl
) = 1;
2086 if (TREE_STATIC (decl
) && sym
->value
)
2088 /* Add static initializer. */
2089 DECL_INITIAL (decl
) = gfc_conv_initializer (sym
->value
, &sym
->ts
,
2091 sym
->attr
.dimension
,
2095 /* Handle threadprivate procedure pointers. */
2096 if (sym
->attr
.threadprivate
2097 && (TREE_STATIC (decl
) || DECL_EXTERNAL (decl
)))
2098 set_decl_tls_model (decl
, decl_default_tls_model (decl
));
2100 attributes
= add_attributes_to_decl (sym
->attr
, NULL_TREE
);
2101 decl_attributes (&decl
, attributes
, 0);
2107 /* Get a basic decl for an external function. */
2110 gfc_get_extern_function_decl (gfc_symbol
* sym
, gfc_actual_arglist
*actual_args
,
2117 gfc_intrinsic_sym
*isym
;
2119 char s
[GFC_MAX_SYMBOL_LEN
+ 23]; /* "_gfortran_f2c_specific" and '\0'. */
2124 if (sym
->backend_decl
)
2125 return sym
->backend_decl
;
2127 /* We should never be creating external decls for alternate entry points.
2128 The procedure may be an alternate entry point, but we don't want/need
2130 gcc_assert (!(sym
->attr
.entry
|| sym
->attr
.entry_master
));
2132 if (sym
->attr
.proc_pointer
)
2133 return get_proc_pointer_decl (sym
);
2135 /* See if this is an external procedure from the same file. If so,
2136 return the backend_decl. If we are looking at a BIND(C)
2137 procedure and the symbol is not BIND(C), or vice versa, we
2138 haven't found the right procedure. */
2140 if (sym
->binding_label
)
2142 gsym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->binding_label
);
2143 if (gsym
&& !gsym
->bind_c
)
2146 else if (sym
->module
== NULL
)
2148 gsym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->name
);
2149 if (gsym
&& gsym
->bind_c
)
2154 /* Procedure from a different module. */
2158 if (gsym
&& !gsym
->defined
)
2161 /* This can happen because of C binding. */
2162 if (gsym
&& gsym
->ns
&& gsym
->ns
->proc_name
2163 && gsym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2166 if ((!sym
->attr
.use_assoc
|| sym
->attr
.if_source
!= IFSRC_DECL
)
2167 && !sym
->backend_decl
2169 && ((gsym
->type
== GSYM_SUBROUTINE
) || (gsym
->type
== GSYM_FUNCTION
))
2170 && (gsym
->ns
->proc_name
->backend_decl
|| !sym
->attr
.intrinsic
))
2172 if (!gsym
->ns
->proc_name
->backend_decl
)
2174 /* By construction, the external function cannot be
2175 a contained procedure. */
2178 gfc_save_backend_locus (&old_loc
);
2181 gfc_create_function_decl (gsym
->ns
, true);
2184 gfc_restore_backend_locus (&old_loc
);
2187 /* If the namespace has entries, the proc_name is the
2188 entry master. Find the entry and use its backend_decl.
2189 otherwise, use the proc_name backend_decl. */
2190 if (gsym
->ns
->entries
)
2192 gfc_entry_list
*entry
= gsym
->ns
->entries
;
2194 for (; entry
; entry
= entry
->next
)
2196 if (strcmp (gsym
->name
, entry
->sym
->name
) == 0)
2198 sym
->backend_decl
= entry
->sym
->backend_decl
;
2204 sym
->backend_decl
= gsym
->ns
->proc_name
->backend_decl
;
2206 if (sym
->backend_decl
)
2208 /* Avoid problems of double deallocation of the backend declaration
2209 later in gfc_trans_use_stmts; cf. PR 45087. */
2210 if (sym
->attr
.if_source
!= IFSRC_DECL
&& sym
->attr
.use_assoc
)
2211 sym
->attr
.use_assoc
= 0;
2213 return sym
->backend_decl
;
2217 /* See if this is a module procedure from the same file. If so,
2218 return the backend_decl. */
2220 gsym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->module
);
2223 if (gsym
&& gsym
->ns
2224 && (gsym
->type
== GSYM_MODULE
2225 || (gsym
->ns
->proc_name
&& gsym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)))
2230 if (gsym
->type
== GSYM_MODULE
)
2231 gfc_find_symbol (sym
->name
, gsym
->ns
, 0, &s
);
2233 gfc_find_symbol (gsym
->sym_name
, gsym
->ns
, 0, &s
);
2235 if (s
&& s
->backend_decl
)
2237 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
2238 gfc_copy_dt_decls_ifequal (s
->ts
.u
.derived
, sym
->ts
.u
.derived
,
2240 else if (sym
->ts
.type
== BT_CHARACTER
)
2241 sym
->ts
.u
.cl
->backend_decl
= s
->ts
.u
.cl
->backend_decl
;
2242 sym
->backend_decl
= s
->backend_decl
;
2243 return sym
->backend_decl
;
2247 if (sym
->attr
.intrinsic
)
2249 /* Call the resolution function to get the actual name. This is
2250 a nasty hack which relies on the resolution functions only looking
2251 at the first argument. We pass NULL for the second argument
2252 otherwise things like AINT get confused. */
2253 isym
= gfc_find_function (sym
->name
);
2254 gcc_assert (isym
->resolve
.f0
!= NULL
);
2256 memset (&e
, 0, sizeof (e
));
2257 e
.expr_type
= EXPR_FUNCTION
;
2259 memset (&argexpr
, 0, sizeof (argexpr
));
2260 gcc_assert (isym
->formal
);
2261 argexpr
.ts
= isym
->formal
->ts
;
2263 if (isym
->formal
->next
== NULL
)
2264 isym
->resolve
.f1 (&e
, &argexpr
);
2267 if (isym
->formal
->next
->next
== NULL
)
2268 isym
->resolve
.f2 (&e
, &argexpr
, NULL
);
2271 if (isym
->formal
->next
->next
->next
== NULL
)
2272 isym
->resolve
.f3 (&e
, &argexpr
, NULL
, NULL
);
2275 /* All specific intrinsics take less than 5 arguments. */
2276 gcc_assert (isym
->formal
->next
->next
->next
->next
== NULL
);
2277 isym
->resolve
.f4 (&e
, &argexpr
, NULL
, NULL
, NULL
);
2283 && ((e
.ts
.type
== BT_REAL
&& e
.ts
.kind
== gfc_default_real_kind
)
2284 || e
.ts
.type
== BT_COMPLEX
))
2286 /* Specific which needs a different implementation if f2c
2287 calling conventions are used. */
2288 sprintf (s
, "_gfortran_f2c_specific%s", e
.value
.function
.name
);
2291 sprintf (s
, "_gfortran_specific%s", e
.value
.function
.name
);
2293 name
= get_identifier (s
);
2294 mangled_name
= name
;
2298 name
= gfc_sym_identifier (sym
);
2299 mangled_name
= gfc_sym_mangled_function_id (sym
);
2302 type
= gfc_get_function_type (sym
, actual_args
, fnspec
);
2304 fndecl
= build_decl (input_location
,
2305 FUNCTION_DECL
, name
, type
);
2307 /* Initialize DECL_EXTERNAL and TREE_PUBLIC before calling decl_attributes;
2308 TREE_PUBLIC specifies whether a function is globally addressable (i.e.
2309 the opposite of declaring a function as static in C). */
2310 DECL_EXTERNAL (fndecl
) = 1;
2311 TREE_PUBLIC (fndecl
) = 1;
2313 attributes
= add_attributes_to_decl (sym
->attr
, NULL_TREE
);
2314 decl_attributes (&fndecl
, attributes
, 0);
2316 gfc_set_decl_assembler_name (fndecl
, mangled_name
);
2318 /* Set the context of this decl. */
2319 if (0 && sym
->ns
&& sym
->ns
->proc_name
)
2321 /* TODO: Add external decls to the appropriate scope. */
2322 DECL_CONTEXT (fndecl
) = sym
->ns
->proc_name
->backend_decl
;
2326 /* Global declaration, e.g. intrinsic subroutine. */
2327 DECL_CONTEXT (fndecl
) = NULL_TREE
;
2330 /* Set attributes for PURE functions. A call to PURE function in the
2331 Fortran 95 sense is both pure and without side effects in the C
2333 if (sym
->attr
.pure
|| sym
->attr
.implicit_pure
)
2335 if (sym
->attr
.function
&& !gfc_return_by_reference (sym
))
2336 DECL_PURE_P (fndecl
) = 1;
2337 /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
2338 parameters and don't use alternate returns (is this
2339 allowed?). In that case, calls to them are meaningless, and
2340 can be optimized away. See also in build_function_decl(). */
2341 TREE_SIDE_EFFECTS (fndecl
) = 0;
2344 /* Mark non-returning functions. */
2345 if (sym
->attr
.noreturn
|| sym
->attr
.ext_attr
& (1 << EXT_ATTR_NORETURN
))
2346 TREE_THIS_VOLATILE(fndecl
) = 1;
2348 sym
->backend_decl
= fndecl
;
2350 if (DECL_CONTEXT (fndecl
) == NULL_TREE
)
2351 pushdecl_top_level (fndecl
);
2354 && sym
->formal_ns
->proc_name
== sym
)
2356 if (sym
->formal_ns
->omp_declare_simd
)
2357 gfc_trans_omp_declare_simd (sym
->formal_ns
);
2359 gfc_trans_omp_declare_variant (sym
->formal_ns
);
2366 /* Create a declaration for a procedure. For external functions (in the C
2367 sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is
2368 a master function with alternate entry points. */
2371 build_function_decl (gfc_symbol
* sym
, bool global
)
2373 tree fndecl
, type
, attributes
;
2374 symbol_attribute attr
;
2376 gfc_formal_arglist
*f
;
2378 bool module_procedure
= sym
->attr
.module_procedure
2380 && sym
->ns
->proc_name
2381 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
;
2383 gcc_assert (!sym
->attr
.external
|| module_procedure
);
2385 if (sym
->backend_decl
)
2388 /* Set the line and filename. sym->declared_at seems to point to the
2389 last statement for subroutines, but it'll do for now. */
2390 gfc_set_backend_locus (&sym
->declared_at
);
2392 /* Allow only one nesting level. Allow public declarations. */
2393 gcc_assert (current_function_decl
== NULL_TREE
2394 || DECL_FILE_SCOPE_P (current_function_decl
)
2395 || (TREE_CODE (DECL_CONTEXT (current_function_decl
))
2396 == NAMESPACE_DECL
));
2398 type
= gfc_get_function_type (sym
);
2399 fndecl
= build_decl (input_location
,
2400 FUNCTION_DECL
, gfc_sym_identifier (sym
), type
);
2404 /* Initialize DECL_EXTERNAL and TREE_PUBLIC before calling decl_attributes;
2405 TREE_PUBLIC specifies whether a function is globally addressable (i.e.
2406 the opposite of declaring a function as static in C). */
2407 DECL_EXTERNAL (fndecl
) = 0;
2409 if (sym
->attr
.access
== ACCESS_UNKNOWN
&& sym
->module
2410 && (sym
->ns
->default_access
== ACCESS_PRIVATE
2411 || (sym
->ns
->default_access
== ACCESS_UNKNOWN
2412 && flag_module_private
)))
2413 sym
->attr
.access
= ACCESS_PRIVATE
;
2415 if (!current_function_decl
2416 && !sym
->attr
.entry_master
&& !sym
->attr
.is_main_program
2417 && (sym
->attr
.access
!= ACCESS_PRIVATE
|| sym
->binding_label
2418 || sym
->attr
.public_used
))
2419 TREE_PUBLIC (fndecl
) = 1;
2421 if (sym
->attr
.referenced
|| sym
->attr
.entry_master
)
2422 TREE_USED (fndecl
) = 1;
2424 attributes
= add_attributes_to_decl (attr
, NULL_TREE
);
2425 decl_attributes (&fndecl
, attributes
, 0);
2427 /* Figure out the return type of the declared function, and build a
2428 RESULT_DECL for it. If this is a subroutine with alternate
2429 returns, build a RESULT_DECL for it. */
2430 result_decl
= NULL_TREE
;
2431 /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
2434 if (gfc_return_by_reference (sym
))
2435 type
= void_type_node
;
2438 if (sym
->result
!= sym
)
2439 result_decl
= gfc_sym_identifier (sym
->result
);
2441 type
= TREE_TYPE (TREE_TYPE (fndecl
));
2446 /* Look for alternate return placeholders. */
2447 int has_alternate_returns
= 0;
2448 for (f
= gfc_sym_get_dummy_args (sym
); f
; f
= f
->next
)
2452 has_alternate_returns
= 1;
2457 if (has_alternate_returns
)
2458 type
= integer_type_node
;
2460 type
= void_type_node
;
2463 result_decl
= build_decl (input_location
,
2464 RESULT_DECL
, result_decl
, type
);
2465 DECL_ARTIFICIAL (result_decl
) = 1;
2466 DECL_IGNORED_P (result_decl
) = 1;
2467 DECL_CONTEXT (result_decl
) = fndecl
;
2468 DECL_RESULT (fndecl
) = result_decl
;
2470 /* Don't call layout_decl for a RESULT_DECL.
2471 layout_decl (result_decl, 0); */
2473 /* TREE_STATIC means the function body is defined here. */
2474 TREE_STATIC (fndecl
) = 1;
2476 /* Set attributes for PURE functions. A call to a PURE function in the
2477 Fortran 95 sense is both pure and without side effects in the C
2479 if (attr
.pure
|| attr
.implicit_pure
)
2481 /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
2482 including an alternate return. In that case it can also be
2483 marked as PURE. See also in gfc_get_extern_function_decl(). */
2484 if (attr
.function
&& !gfc_return_by_reference (sym
))
2485 DECL_PURE_P (fndecl
) = 1;
2486 TREE_SIDE_EFFECTS (fndecl
) = 0;
2489 /* Mark noinline functions. */
2490 if (attr
.ext_attr
& (1 << EXT_ATTR_NOINLINE
))
2491 DECL_UNINLINABLE (fndecl
) = 1;
2493 /* Mark noreturn functions. */
2494 if (attr
.ext_attr
& (1 << EXT_ATTR_NORETURN
))
2495 TREE_THIS_VOLATILE (fndecl
) = 1;
2497 /* Mark weak functions. */
2498 if (attr
.ext_attr
& (1 << EXT_ATTR_WEAK
))
2499 declare_weak (fndecl
);
2501 /* Layout the function declaration and put it in the binding level
2502 of the current function. */
2505 pushdecl_top_level (fndecl
);
2509 /* Perform name mangling if this is a top level or module procedure. */
2510 if (current_function_decl
== NULL_TREE
)
2511 gfc_set_decl_assembler_name (fndecl
, gfc_sym_mangled_function_id (sym
));
2513 sym
->backend_decl
= fndecl
;
2517 /* Create the DECL_ARGUMENTS for a procedure.
2518 NOTE: The arguments added here must match the argument type created by
2519 gfc_get_function_type (). */
2522 create_function_arglist (gfc_symbol
* sym
)
2525 gfc_formal_arglist
*f
;
2526 tree typelist
, hidden_typelist
, optval_typelist
;
2527 tree arglist
, hidden_arglist
, optval_arglist
;
2531 fndecl
= sym
->backend_decl
;
2533 /* Build formal argument list. Make sure that their TREE_CONTEXT is
2534 the new FUNCTION_DECL node. */
2535 arglist
= NULL_TREE
;
2536 hidden_arglist
= NULL_TREE
;
2537 optval_arglist
= NULL_TREE
;
2538 typelist
= TYPE_ARG_TYPES (TREE_TYPE (fndecl
));
2540 if (sym
->attr
.entry_master
)
2542 type
= TREE_VALUE (typelist
);
2543 parm
= build_decl (input_location
,
2544 PARM_DECL
, get_identifier ("__entry"), type
);
2546 DECL_CONTEXT (parm
) = fndecl
;
2547 DECL_ARG_TYPE (parm
) = type
;
2548 TREE_READONLY (parm
) = 1;
2549 gfc_finish_decl (parm
);
2550 DECL_ARTIFICIAL (parm
) = 1;
2552 arglist
= chainon (arglist
, parm
);
2553 typelist
= TREE_CHAIN (typelist
);
2556 if (gfc_return_by_reference (sym
))
2558 tree type
= TREE_VALUE (typelist
), length
= NULL
;
2560 if (sym
->ts
.type
== BT_CHARACTER
)
2562 /* Length of character result. */
2563 tree len_type
= TREE_VALUE (TREE_CHAIN (typelist
));
2565 length
= build_decl (input_location
,
2567 get_identifier (".__result"),
2569 if (POINTER_TYPE_P (len_type
))
2571 sym
->ts
.u
.cl
->passed_length
= length
;
2572 TREE_USED (length
) = 1;
2574 else if (!sym
->ts
.u
.cl
->length
)
2576 sym
->ts
.u
.cl
->backend_decl
= length
;
2577 TREE_USED (length
) = 1;
2579 gcc_assert (TREE_CODE (length
) == PARM_DECL
);
2580 DECL_CONTEXT (length
) = fndecl
;
2581 DECL_ARG_TYPE (length
) = len_type
;
2582 TREE_READONLY (length
) = 1;
2583 DECL_ARTIFICIAL (length
) = 1;
2584 gfc_finish_decl (length
);
2585 if (sym
->ts
.u
.cl
->backend_decl
== NULL
2586 || sym
->ts
.u
.cl
->backend_decl
== length
)
2591 if (sym
->ts
.u
.cl
->backend_decl
== NULL
)
2593 tree len
= build_decl (input_location
,
2595 get_identifier ("..__result"),
2596 gfc_charlen_type_node
);
2597 DECL_ARTIFICIAL (len
) = 1;
2598 TREE_USED (len
) = 1;
2599 sym
->ts
.u
.cl
->backend_decl
= len
;
2602 /* Make sure PARM_DECL type doesn't point to incomplete type. */
2603 arg
= sym
->result
? sym
->result
: sym
;
2604 backend_decl
= arg
->backend_decl
;
2605 /* Temporary clear it, so that gfc_sym_type creates complete
2607 arg
->backend_decl
= NULL
;
2608 type
= gfc_sym_type (arg
);
2609 arg
->backend_decl
= backend_decl
;
2610 type
= build_reference_type (type
);
2614 parm
= build_decl (input_location
,
2615 PARM_DECL
, get_identifier ("__result"), type
);
2617 DECL_CONTEXT (parm
) = fndecl
;
2618 DECL_ARG_TYPE (parm
) = TREE_VALUE (typelist
);
2619 TREE_READONLY (parm
) = 1;
2620 DECL_ARTIFICIAL (parm
) = 1;
2621 gfc_finish_decl (parm
);
2623 arglist
= chainon (arglist
, parm
);
2624 typelist
= TREE_CHAIN (typelist
);
2626 if (sym
->ts
.type
== BT_CHARACTER
)
2628 gfc_allocate_lang_decl (parm
);
2629 arglist
= chainon (arglist
, length
);
2630 typelist
= TREE_CHAIN (typelist
);
2634 hidden_typelist
= typelist
;
2635 for (f
= gfc_sym_get_dummy_args (sym
); f
; f
= f
->next
)
2636 if (f
->sym
!= NULL
) /* Ignore alternate returns. */
2637 hidden_typelist
= TREE_CHAIN (hidden_typelist
);
2639 /* Advance hidden_typelist over optional+value argument presence flags. */
2640 optval_typelist
= hidden_typelist
;
2641 for (f
= gfc_sym_get_dummy_args (sym
); f
; f
= f
->next
)
2643 && f
->sym
->attr
.optional
&& f
->sym
->attr
.value
2644 && !f
->sym
->attr
.dimension
&& f
->sym
->ts
.type
!= BT_CLASS
2645 && !gfc_bt_struct (f
->sym
->ts
.type
))
2646 hidden_typelist
= TREE_CHAIN (hidden_typelist
);
2648 for (f
= gfc_sym_get_dummy_args (sym
); f
; f
= f
->next
)
2650 char name
[GFC_MAX_SYMBOL_LEN
+ 2];
2652 /* Ignore alternate returns. */
2656 type
= TREE_VALUE (typelist
);
2658 if (f
->sym
->ts
.type
== BT_CHARACTER
2659 && (!sym
->attr
.is_bind_c
|| sym
->attr
.entry_master
))
2661 tree len_type
= TREE_VALUE (hidden_typelist
);
2662 tree length
= NULL_TREE
;
2663 if (!f
->sym
->ts
.deferred
)
2664 gcc_assert (len_type
== gfc_charlen_type_node
);
2666 gcc_assert (POINTER_TYPE_P (len_type
));
2668 strcpy (&name
[1], f
->sym
->name
);
2670 length
= build_decl (input_location
,
2671 PARM_DECL
, get_identifier (name
), len_type
);
2673 hidden_arglist
= chainon (hidden_arglist
, length
);
2674 DECL_CONTEXT (length
) = fndecl
;
2675 DECL_ARTIFICIAL (length
) = 1;
2676 DECL_ARG_TYPE (length
) = len_type
;
2677 TREE_READONLY (length
) = 1;
2678 gfc_finish_decl (length
);
2680 /* Marking the length DECL_HIDDEN_STRING_LENGTH will lead
2681 to tail calls being disabled. Only do that if we
2682 potentially have broken callers. */
2683 if (flag_tail_call_workaround
2685 && f
->sym
->ts
.u
.cl
->length
2686 && f
->sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
2687 && (flag_tail_call_workaround
== 2
2688 || f
->sym
->ns
->implicit_interface_calls
))
2689 DECL_HIDDEN_STRING_LENGTH (length
) = 1;
2691 /* Remember the passed value. */
2692 if (!f
->sym
->ts
.u
.cl
|| f
->sym
->ts
.u
.cl
->passed_length
)
2694 /* This can happen if the same type is used for multiple
2695 arguments. We need to copy cl as otherwise
2696 cl->passed_length gets overwritten. */
2697 f
->sym
->ts
.u
.cl
= gfc_new_charlen (f
->sym
->ns
, f
->sym
->ts
.u
.cl
);
2699 f
->sym
->ts
.u
.cl
->passed_length
= length
;
2701 /* Use the passed value for assumed length variables. */
2702 if (!f
->sym
->ts
.u
.cl
->length
)
2704 TREE_USED (length
) = 1;
2705 gcc_assert (!f
->sym
->ts
.u
.cl
->backend_decl
);
2706 f
->sym
->ts
.u
.cl
->backend_decl
= length
;
2709 hidden_typelist
= TREE_CHAIN (hidden_typelist
);
2711 if (f
->sym
->ts
.u
.cl
->backend_decl
== NULL
2712 || f
->sym
->ts
.u
.cl
->backend_decl
== length
)
2714 if (POINTER_TYPE_P (len_type
))
2715 f
->sym
->ts
.u
.cl
->backend_decl
2716 = build_fold_indirect_ref_loc (input_location
, length
);
2717 else if (f
->sym
->ts
.u
.cl
->backend_decl
== NULL
)
2718 gfc_create_string_length (f
->sym
);
2720 /* Make sure PARM_DECL type doesn't point to incomplete type. */
2721 if (f
->sym
->attr
.flavor
== FL_PROCEDURE
)
2722 type
= build_pointer_type (gfc_get_function_type (f
->sym
));
2724 type
= gfc_sym_type (f
->sym
);
2727 /* For scalar intrinsic types, VALUE passes the value,
2728 hence, the optional status cannot be transferred via a NULL pointer.
2729 Thus, we will use a hidden argument in that case. */
2730 if (f
->sym
->attr
.optional
&& f
->sym
->attr
.value
2731 && !f
->sym
->attr
.dimension
&& f
->sym
->ts
.type
!= BT_CLASS
2732 && !gfc_bt_struct (f
->sym
->ts
.type
))
2735 strcpy (&name
[1], f
->sym
->name
);
2737 tmp
= build_decl (input_location
,
2738 PARM_DECL
, get_identifier (name
),
2741 optval_arglist
= chainon (optval_arglist
, tmp
);
2742 DECL_CONTEXT (tmp
) = fndecl
;
2743 DECL_ARTIFICIAL (tmp
) = 1;
2744 DECL_ARG_TYPE (tmp
) = boolean_type_node
;
2745 TREE_READONLY (tmp
) = 1;
2746 gfc_finish_decl (tmp
);
2748 /* The presence flag must be boolean. */
2749 gcc_assert (TREE_VALUE (optval_typelist
) == boolean_type_node
);
2750 optval_typelist
= TREE_CHAIN (optval_typelist
);
2753 /* For non-constant length array arguments, make sure they use
2754 a different type node from TYPE_ARG_TYPES type. */
2755 if (f
->sym
->attr
.dimension
2756 && type
== TREE_VALUE (typelist
)
2757 && TREE_CODE (type
) == POINTER_TYPE
2758 && GFC_ARRAY_TYPE_P (type
)
2759 && f
->sym
->as
->type
!= AS_ASSUMED_SIZE
2760 && ! COMPLETE_TYPE_P (TREE_TYPE (type
)))
2762 if (f
->sym
->attr
.flavor
== FL_PROCEDURE
)
2763 type
= build_pointer_type (gfc_get_function_type (f
->sym
));
2765 type
= gfc_sym_type (f
->sym
);
2768 if (f
->sym
->attr
.proc_pointer
)
2769 type
= build_pointer_type (type
);
2771 if (f
->sym
->attr
.volatile_
)
2772 type
= build_qualified_type (type
, TYPE_QUAL_VOLATILE
);
2774 /* Build the argument declaration. For C descriptors, we use a
2775 '_'-prefixed name for the parm_decl and inside the proc the
2778 if (sym
->attr
.is_bind_c
&& is_CFI_desc (f
->sym
, NULL
))
2780 strcpy (&name
[1], f
->sym
->name
);
2782 parm_name
= get_identifier (name
);
2785 parm_name
= gfc_sym_identifier (f
->sym
);
2786 parm
= build_decl (input_location
, PARM_DECL
, parm_name
, type
);
2788 if (f
->sym
->attr
.volatile_
)
2790 TREE_THIS_VOLATILE (parm
) = 1;
2791 TREE_SIDE_EFFECTS (parm
) = 1;
2794 /* Fill in arg stuff. */
2795 DECL_CONTEXT (parm
) = fndecl
;
2796 DECL_ARG_TYPE (parm
) = TREE_VALUE (typelist
);
2797 /* All implementation args except for VALUE are read-only. */
2798 if (!f
->sym
->attr
.value
)
2799 TREE_READONLY (parm
) = 1;
2800 if (POINTER_TYPE_P (type
)
2801 && (!f
->sym
->attr
.proc_pointer
2802 && f
->sym
->attr
.flavor
!= FL_PROCEDURE
))
2803 DECL_BY_REFERENCE (parm
) = 1;
2804 if (f
->sym
->attr
.optional
)
2806 gfc_allocate_lang_decl (parm
);
2807 GFC_DECL_OPTIONAL_ARGUMENT (parm
) = 1;
2810 gfc_finish_decl (parm
);
2811 gfc_finish_decl_attrs (parm
, &f
->sym
->attr
);
2813 f
->sym
->backend_decl
= parm
;
2815 /* Coarrays which are descriptorless or assumed-shape pass with
2816 -fcoarray=lib the token and the offset as hidden arguments. */
2817 if (flag_coarray
== GFC_FCOARRAY_LIB
2818 && ((f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.codimension
2819 && !f
->sym
->attr
.allocatable
)
2820 || (f
->sym
->ts
.type
== BT_CLASS
2821 && CLASS_DATA (f
->sym
)->attr
.codimension
2822 && !CLASS_DATA (f
->sym
)->attr
.allocatable
)))
2828 gcc_assert (f
->sym
->backend_decl
!= NULL_TREE
2829 && !sym
->attr
.is_bind_c
);
2830 caf_type
= f
->sym
->ts
.type
== BT_CLASS
2831 ? TREE_TYPE (CLASS_DATA (f
->sym
)->backend_decl
)
2832 : TREE_TYPE (f
->sym
->backend_decl
);
2834 token
= build_decl (input_location
, PARM_DECL
,
2835 create_tmp_var_name ("caf_token"),
2836 build_qualified_type (pvoid_type_node
,
2837 TYPE_QUAL_RESTRICT
));
2838 if ((f
->sym
->ts
.type
!= BT_CLASS
2839 && f
->sym
->as
->type
!= AS_DEFERRED
)
2840 || (f
->sym
->ts
.type
== BT_CLASS
2841 && CLASS_DATA (f
->sym
)->as
->type
!= AS_DEFERRED
))
2843 gcc_assert (DECL_LANG_SPECIFIC (f
->sym
->backend_decl
) == NULL
2844 || GFC_DECL_TOKEN (f
->sym
->backend_decl
) == NULL_TREE
);
2845 if (DECL_LANG_SPECIFIC (f
->sym
->backend_decl
) == NULL
)
2846 gfc_allocate_lang_decl (f
->sym
->backend_decl
);
2847 GFC_DECL_TOKEN (f
->sym
->backend_decl
) = token
;
2851 gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) == NULL_TREE
);
2852 GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) = token
;
2855 DECL_CONTEXT (token
) = fndecl
;
2856 DECL_ARTIFICIAL (token
) = 1;
2857 DECL_ARG_TYPE (token
) = TREE_VALUE (typelist
);
2858 TREE_READONLY (token
) = 1;
2859 hidden_arglist
= chainon (hidden_arglist
, token
);
2860 hidden_typelist
= TREE_CHAIN (hidden_typelist
);
2861 gfc_finish_decl (token
);
2863 offset
= build_decl (input_location
, PARM_DECL
,
2864 create_tmp_var_name ("caf_offset"),
2865 gfc_array_index_type
);
2867 if ((f
->sym
->ts
.type
!= BT_CLASS
2868 && f
->sym
->as
->type
!= AS_DEFERRED
)
2869 || (f
->sym
->ts
.type
== BT_CLASS
2870 && CLASS_DATA (f
->sym
)->as
->type
!= AS_DEFERRED
))
2872 gcc_assert (GFC_DECL_CAF_OFFSET (f
->sym
->backend_decl
)
2874 GFC_DECL_CAF_OFFSET (f
->sym
->backend_decl
) = offset
;
2878 gcc_assert (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) == NULL_TREE
);
2879 GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) = offset
;
2881 DECL_CONTEXT (offset
) = fndecl
;
2882 DECL_ARTIFICIAL (offset
) = 1;
2883 DECL_ARG_TYPE (offset
) = TREE_VALUE (typelist
);
2884 TREE_READONLY (offset
) = 1;
2885 hidden_arglist
= chainon (hidden_arglist
, offset
);
2886 hidden_typelist
= TREE_CHAIN (hidden_typelist
);
2887 gfc_finish_decl (offset
);
2890 arglist
= chainon (arglist
, parm
);
2891 typelist
= TREE_CHAIN (typelist
);
2894 /* Add hidden present status for optional+value arguments. */
2895 arglist
= chainon (arglist
, optval_arglist
);
2897 /* Add the hidden string length parameters, unless the procedure
2899 if (!sym
->attr
.is_bind_c
)
2900 arglist
= chainon (arglist
, hidden_arglist
);
2902 gcc_assert (hidden_typelist
== NULL_TREE
2903 || TREE_VALUE (hidden_typelist
) == void_type_node
);
2904 DECL_ARGUMENTS (fndecl
) = arglist
;
2907 /* Do the setup necessary before generating the body of a function. */
2910 trans_function_start (gfc_symbol
* sym
)
2914 fndecl
= sym
->backend_decl
;
2916 /* Let GCC know the current scope is this function. */
2917 current_function_decl
= fndecl
;
2919 /* Let the world know what we're about to do. */
2920 announce_function (fndecl
);
2922 if (DECL_FILE_SCOPE_P (fndecl
))
2924 /* Create RTL for function declaration. */
2925 rest_of_decl_compilation (fndecl
, 1, 0);
2928 /* Create RTL for function definition. */
2929 make_decl_rtl (fndecl
);
2931 allocate_struct_function (fndecl
, false);
2933 /* function.cc requires a push at the start of the function. */
2937 /* Create thunks for alternate entry points. */
2940 build_entry_thunks (gfc_namespace
* ns
, bool global
)
2942 gfc_formal_arglist
*formal
;
2943 gfc_formal_arglist
*thunk_formal
;
2945 gfc_symbol
*thunk_sym
;
2951 /* This should always be a toplevel function. */
2952 gcc_assert (current_function_decl
== NULL_TREE
);
2954 gfc_save_backend_locus (&old_loc
);
2955 for (el
= ns
->entries
; el
; el
= el
->next
)
2957 vec
<tree
, va_gc
> *args
= NULL
;
2958 vec
<tree
, va_gc
> *string_args
= NULL
;
2960 thunk_sym
= el
->sym
;
2962 build_function_decl (thunk_sym
, global
);
2963 create_function_arglist (thunk_sym
);
2965 trans_function_start (thunk_sym
);
2967 thunk_fndecl
= thunk_sym
->backend_decl
;
2969 gfc_init_block (&body
);
2971 /* Pass extra parameter identifying this entry point. */
2972 tmp
= build_int_cst (gfc_array_index_type
, el
->id
);
2973 vec_safe_push (args
, tmp
);
2975 if (thunk_sym
->attr
.function
)
2977 if (gfc_return_by_reference (ns
->proc_name
))
2979 tree ref
= DECL_ARGUMENTS (current_function_decl
);
2980 vec_safe_push (args
, ref
);
2981 if (ns
->proc_name
->ts
.type
== BT_CHARACTER
)
2982 vec_safe_push (args
, DECL_CHAIN (ref
));
2986 for (formal
= gfc_sym_get_dummy_args (ns
->proc_name
); formal
;
2987 formal
= formal
->next
)
2989 /* Ignore alternate returns. */
2990 if (formal
->sym
== NULL
)
2993 /* We don't have a clever way of identifying arguments, so resort to
2994 a brute-force search. */
2995 for (thunk_formal
= gfc_sym_get_dummy_args (thunk_sym
);
2997 thunk_formal
= thunk_formal
->next
)
2999 if (thunk_formal
->sym
== formal
->sym
)
3005 /* Pass the argument. */
3006 DECL_ARTIFICIAL (thunk_formal
->sym
->backend_decl
) = 1;
3007 vec_safe_push (args
, thunk_formal
->sym
->backend_decl
);
3008 if (formal
->sym
->ts
.type
== BT_CHARACTER
)
3010 tmp
= thunk_formal
->sym
->ts
.u
.cl
->backend_decl
;
3011 vec_safe_push (string_args
, tmp
);
3016 /* Pass NULL for a missing argument. */
3017 vec_safe_push (args
, null_pointer_node
);
3018 if (formal
->sym
->ts
.type
== BT_CHARACTER
)
3020 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
3021 vec_safe_push (string_args
, tmp
);
3026 /* Call the master function. */
3027 vec_safe_splice (args
, string_args
);
3028 tmp
= ns
->proc_name
->backend_decl
;
3029 tmp
= build_call_expr_loc_vec (input_location
, tmp
, args
);
3030 if (ns
->proc_name
->attr
.mixed_entry_master
)
3032 tree union_decl
, field
;
3033 tree master_type
= TREE_TYPE (ns
->proc_name
->backend_decl
);
3035 union_decl
= build_decl (input_location
,
3036 VAR_DECL
, get_identifier ("__result"),
3037 TREE_TYPE (master_type
));
3038 DECL_ARTIFICIAL (union_decl
) = 1;
3039 DECL_EXTERNAL (union_decl
) = 0;
3040 TREE_PUBLIC (union_decl
) = 0;
3041 TREE_USED (union_decl
) = 1;
3042 layout_decl (union_decl
, 0);
3043 pushdecl (union_decl
);
3045 DECL_CONTEXT (union_decl
) = current_function_decl
;
3046 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
3047 TREE_TYPE (union_decl
), union_decl
, tmp
);
3048 gfc_add_expr_to_block (&body
, tmp
);
3050 for (field
= TYPE_FIELDS (TREE_TYPE (union_decl
));
3051 field
; field
= DECL_CHAIN (field
))
3052 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field
)),
3053 thunk_sym
->result
->name
) == 0)
3055 gcc_assert (field
!= NULL_TREE
);
3056 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
3057 TREE_TYPE (field
), union_decl
, field
,
3059 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
3060 TREE_TYPE (DECL_RESULT (current_function_decl
)),
3061 DECL_RESULT (current_function_decl
), tmp
);
3062 tmp
= build1_v (RETURN_EXPR
, tmp
);
3064 else if (TREE_TYPE (DECL_RESULT (current_function_decl
))
3067 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
3068 TREE_TYPE (DECL_RESULT (current_function_decl
)),
3069 DECL_RESULT (current_function_decl
), tmp
);
3070 tmp
= build1_v (RETURN_EXPR
, tmp
);
3072 gfc_add_expr_to_block (&body
, tmp
);
3074 /* Finish off this function and send it for code generation. */
3075 DECL_SAVED_TREE (thunk_fndecl
) = gfc_finish_block (&body
);
3078 BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl
)) = thunk_fndecl
;
3079 DECL_SAVED_TREE (thunk_fndecl
)
3080 = fold_build3_loc (DECL_SOURCE_LOCATION (thunk_fndecl
), BIND_EXPR
,
3081 void_type_node
, tmp
, DECL_SAVED_TREE (thunk_fndecl
),
3082 DECL_INITIAL (thunk_fndecl
));
3084 /* Output the GENERIC tree. */
3085 dump_function (TDI_original
, thunk_fndecl
);
3087 /* Store the end of the function, so that we get good line number
3088 info for the epilogue. */
3089 cfun
->function_end_locus
= input_location
;
3091 /* We're leaving the context of this function, so zap cfun.
3092 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
3093 tree_rest_of_compilation. */
3096 current_function_decl
= NULL_TREE
;
3098 cgraph_node::finalize_function (thunk_fndecl
, true);
3100 /* We share the symbols in the formal argument list with other entry
3101 points and the master function. Clear them so that they are
3102 recreated for each function. */
3103 for (formal
= gfc_sym_get_dummy_args (thunk_sym
); formal
;
3104 formal
= formal
->next
)
3105 if (formal
->sym
!= NULL
) /* Ignore alternate returns. */
3107 formal
->sym
->backend_decl
= NULL_TREE
;
3108 if (formal
->sym
->ts
.type
== BT_CHARACTER
)
3109 formal
->sym
->ts
.u
.cl
->backend_decl
= NULL_TREE
;
3112 if (thunk_sym
->attr
.function
)
3114 if (thunk_sym
->ts
.type
== BT_CHARACTER
)
3115 thunk_sym
->ts
.u
.cl
->backend_decl
= NULL_TREE
;
3116 if (thunk_sym
->result
->ts
.type
== BT_CHARACTER
)
3117 thunk_sym
->result
->ts
.u
.cl
->backend_decl
= NULL_TREE
;
3121 gfc_restore_backend_locus (&old_loc
);
3125 /* Create a decl for a function, and create any thunks for alternate entry
3126 points. If global is true, generate the function in the global binding
3127 level, otherwise in the current binding level (which can be global). */
3130 gfc_create_function_decl (gfc_namespace
* ns
, bool global
)
3132 /* Create a declaration for the master function. */
3133 build_function_decl (ns
->proc_name
, global
);
3135 /* Compile the entry thunks. */
3137 build_entry_thunks (ns
, global
);
3139 /* Now create the read argument list. */
3140 create_function_arglist (ns
->proc_name
);
3142 if (ns
->omp_declare_simd
)
3143 gfc_trans_omp_declare_simd (ns
);
3145 /* Handle 'declare variant' directives. The applicable directives might
3146 be declared in a parent namespace, so this needs to be called even if
3147 there are no local directives. */
3149 gfc_trans_omp_declare_variant (ns
);
3152 /* Return the decl used to hold the function return value. If
3153 parent_flag is set, the context is the parent_scope. */
3156 gfc_get_fake_result_decl (gfc_symbol
* sym
, int parent_flag
)
3160 tree this_fake_result_decl
;
3161 tree this_function_decl
;
3163 char name
[GFC_MAX_SYMBOL_LEN
+ 10];
3167 this_fake_result_decl
= parent_fake_result_decl
;
3168 this_function_decl
= DECL_CONTEXT (current_function_decl
);
3172 this_fake_result_decl
= current_fake_result_decl
;
3173 this_function_decl
= current_function_decl
;
3177 && sym
->ns
->proc_name
->backend_decl
== this_function_decl
3178 && sym
->ns
->proc_name
->attr
.entry_master
3179 && sym
!= sym
->ns
->proc_name
)
3182 if (this_fake_result_decl
!= NULL
)
3183 for (t
= TREE_CHAIN (this_fake_result_decl
); t
; t
= TREE_CHAIN (t
))
3184 if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t
)), sym
->name
) == 0)
3187 return TREE_VALUE (t
);
3188 decl
= gfc_get_fake_result_decl (sym
->ns
->proc_name
, parent_flag
);
3191 this_fake_result_decl
= parent_fake_result_decl
;
3193 this_fake_result_decl
= current_fake_result_decl
;
3195 if (decl
&& sym
->ns
->proc_name
->attr
.mixed_entry_master
)
3199 for (field
= TYPE_FIELDS (TREE_TYPE (decl
));
3200 field
; field
= DECL_CHAIN (field
))
3201 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field
)),
3205 gcc_assert (field
!= NULL_TREE
);
3206 decl
= fold_build3_loc (input_location
, COMPONENT_REF
,
3207 TREE_TYPE (field
), decl
, field
, NULL_TREE
);
3210 var
= create_tmp_var_raw (TREE_TYPE (decl
), sym
->name
);
3212 gfc_add_decl_to_parent_function (var
);
3214 gfc_add_decl_to_function (var
);
3216 SET_DECL_VALUE_EXPR (var
, decl
);
3217 DECL_HAS_VALUE_EXPR_P (var
) = 1;
3218 GFC_DECL_RESULT (var
) = 1;
3220 TREE_CHAIN (this_fake_result_decl
)
3221 = tree_cons (get_identifier (sym
->name
), var
,
3222 TREE_CHAIN (this_fake_result_decl
));
3226 if (this_fake_result_decl
!= NULL_TREE
)
3227 return TREE_VALUE (this_fake_result_decl
);
3229 /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
3234 if (sym
->ts
.type
== BT_CHARACTER
)
3236 if (sym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
3237 length
= gfc_create_string_length (sym
);
3239 length
= sym
->ts
.u
.cl
->backend_decl
;
3240 if (VAR_P (length
) && DECL_CONTEXT (length
) == NULL_TREE
)
3241 gfc_add_decl_to_function (length
);
3244 if (gfc_return_by_reference (sym
))
3246 decl
= DECL_ARGUMENTS (this_function_decl
);
3248 if (sym
->ns
->proc_name
->backend_decl
== this_function_decl
3249 && sym
->ns
->proc_name
->attr
.entry_master
)
3250 decl
= DECL_CHAIN (decl
);
3252 TREE_USED (decl
) = 1;
3254 decl
= gfc_build_dummy_array_decl (sym
, decl
);
3258 sprintf (name
, "__result_%.20s",
3259 IDENTIFIER_POINTER (DECL_NAME (this_function_decl
)));
3261 if (!sym
->attr
.mixed_entry_master
&& sym
->attr
.function
)
3262 decl
= build_decl (DECL_SOURCE_LOCATION (this_function_decl
),
3263 VAR_DECL
, get_identifier (name
),
3264 gfc_sym_type (sym
));
3266 decl
= build_decl (DECL_SOURCE_LOCATION (this_function_decl
),
3267 VAR_DECL
, get_identifier (name
),
3268 TREE_TYPE (TREE_TYPE (this_function_decl
)));
3269 DECL_ARTIFICIAL (decl
) = 1;
3270 DECL_EXTERNAL (decl
) = 0;
3271 TREE_PUBLIC (decl
) = 0;
3272 TREE_USED (decl
) = 1;
3273 GFC_DECL_RESULT (decl
) = 1;
3274 TREE_ADDRESSABLE (decl
) = 1;
3276 layout_decl (decl
, 0);
3277 gfc_finish_decl_attrs (decl
, &sym
->attr
);
3280 gfc_add_decl_to_parent_function (decl
);
3282 gfc_add_decl_to_function (decl
);
3286 parent_fake_result_decl
= build_tree_list (NULL
, decl
);
3288 current_fake_result_decl
= build_tree_list (NULL
, decl
);
3290 if (sym
->attr
.assign
)
3291 DECL_LANG_SPECIFIC (decl
) = DECL_LANG_SPECIFIC (sym
->backend_decl
);
3297 /* Builds a function decl. The remaining parameters are the types of the
3298 function arguments. Negative nargs indicates a varargs function. */
3301 build_library_function_decl_1 (tree name
, const char *spec
,
3302 tree rettype
, int nargs
, va_list p
)
3304 vec
<tree
, va_gc
> *arglist
;
3309 /* Library functions must be declared with global scope. */
3310 gcc_assert (current_function_decl
== NULL_TREE
);
3312 /* Create a list of the argument types. */
3313 vec_alloc (arglist
, abs (nargs
));
3314 for (n
= abs (nargs
); n
> 0; n
--)
3316 tree argtype
= va_arg (p
, tree
);
3317 arglist
->quick_push (argtype
);
3320 /* Build the function type and decl. */
3322 fntype
= build_function_type_vec (rettype
, arglist
);
3324 fntype
= build_varargs_function_type_vec (rettype
, arglist
);
3327 tree attr_args
= build_tree_list (NULL_TREE
,
3328 build_string (strlen (spec
), spec
));
3329 tree attrs
= tree_cons (get_identifier ("fn spec"),
3330 attr_args
, TYPE_ATTRIBUTES (fntype
));
3331 fntype
= build_type_attribute_variant (fntype
, attrs
);
3333 fndecl
= build_decl (input_location
,
3334 FUNCTION_DECL
, name
, fntype
);
3336 /* Mark this decl as external. */
3337 DECL_EXTERNAL (fndecl
) = 1;
3338 TREE_PUBLIC (fndecl
) = 1;
3342 rest_of_decl_compilation (fndecl
, 1, 0);
3347 /* Builds a function decl. The remaining parameters are the types of the
3348 function arguments. Negative nargs indicates a varargs function. */
3351 gfc_build_library_function_decl (tree name
, tree rettype
, int nargs
, ...)
3355 va_start (args
, nargs
);
3356 ret
= build_library_function_decl_1 (name
, NULL
, rettype
, nargs
, args
);
3361 /* Builds a function decl. The remaining parameters are the types of the
3362 function arguments. Negative nargs indicates a varargs function.
3363 The SPEC parameter specifies the function argument and return type
3364 specification according to the fnspec function type attribute. */
3367 gfc_build_library_function_decl_with_spec (tree name
, const char *spec
,
3368 tree rettype
, int nargs
, ...)
3372 va_start (args
, nargs
);
3375 attr_fnspec
fnspec (spec
, strlen (spec
));
3378 ret
= build_library_function_decl_1 (name
, spec
, rettype
, nargs
, args
);
3384 gfc_build_intrinsic_function_decls (void)
3386 tree gfc_int4_type_node
= gfc_get_int_type (4);
3387 tree gfc_pint4_type_node
= build_pointer_type (gfc_int4_type_node
);
3388 tree gfc_int8_type_node
= gfc_get_int_type (8);
3389 tree gfc_pint8_type_node
= build_pointer_type (gfc_int8_type_node
);
3390 tree gfc_int16_type_node
= gfc_get_int_type (16);
3391 tree gfc_logical4_type_node
= gfc_get_logical_type (4);
3392 tree pchar1_type_node
= gfc_get_pchar_type (1);
3393 tree pchar4_type_node
= gfc_get_pchar_type (4);
3395 /* String functions. */
3396 gfor_fndecl_compare_string
= gfc_build_library_function_decl_with_spec (
3397 get_identifier (PREFIX("compare_string")), ". . R . R ",
3398 integer_type_node
, 4, gfc_charlen_type_node
, pchar1_type_node
,
3399 gfc_charlen_type_node
, pchar1_type_node
);
3400 DECL_PURE_P (gfor_fndecl_compare_string
) = 1;
3401 TREE_NOTHROW (gfor_fndecl_compare_string
) = 1;
3403 gfor_fndecl_concat_string
= gfc_build_library_function_decl_with_spec (
3404 get_identifier (PREFIX("concat_string")), ". . W . R . R ",
3405 void_type_node
, 6, gfc_charlen_type_node
, pchar1_type_node
,
3406 gfc_charlen_type_node
, pchar1_type_node
,
3407 gfc_charlen_type_node
, pchar1_type_node
);
3408 TREE_NOTHROW (gfor_fndecl_concat_string
) = 1;
3410 gfor_fndecl_string_len_trim
= gfc_build_library_function_decl_with_spec (
3411 get_identifier (PREFIX("string_len_trim")), ". . R ",
3412 gfc_charlen_type_node
, 2, gfc_charlen_type_node
, pchar1_type_node
);
3413 DECL_PURE_P (gfor_fndecl_string_len_trim
) = 1;
3414 TREE_NOTHROW (gfor_fndecl_string_len_trim
) = 1;
3416 gfor_fndecl_string_index
= gfc_build_library_function_decl_with_spec (
3417 get_identifier (PREFIX("string_index")), ". . R . R . ",
3418 gfc_charlen_type_node
, 5, gfc_charlen_type_node
, pchar1_type_node
,
3419 gfc_charlen_type_node
, pchar1_type_node
, gfc_logical4_type_node
);
3420 DECL_PURE_P (gfor_fndecl_string_index
) = 1;
3421 TREE_NOTHROW (gfor_fndecl_string_index
) = 1;
3423 gfor_fndecl_string_scan
= gfc_build_library_function_decl_with_spec (
3424 get_identifier (PREFIX("string_scan")), ". . R . R . ",
3425 gfc_charlen_type_node
, 5, gfc_charlen_type_node
, pchar1_type_node
,
3426 gfc_charlen_type_node
, pchar1_type_node
, gfc_logical4_type_node
);
3427 DECL_PURE_P (gfor_fndecl_string_scan
) = 1;
3428 TREE_NOTHROW (gfor_fndecl_string_scan
) = 1;
3430 gfor_fndecl_string_verify
= gfc_build_library_function_decl_with_spec (
3431 get_identifier (PREFIX("string_verify")), ". . R . R . ",
3432 gfc_charlen_type_node
, 5, gfc_charlen_type_node
, pchar1_type_node
,
3433 gfc_charlen_type_node
, pchar1_type_node
, gfc_logical4_type_node
);
3434 DECL_PURE_P (gfor_fndecl_string_verify
) = 1;
3435 TREE_NOTHROW (gfor_fndecl_string_verify
) = 1;
3437 gfor_fndecl_string_trim
= gfc_build_library_function_decl_with_spec (
3438 get_identifier (PREFIX("string_trim")), ". W w . R ",
3439 void_type_node
, 4, build_pointer_type (gfc_charlen_type_node
),
3440 build_pointer_type (pchar1_type_node
), gfc_charlen_type_node
,
3443 gfor_fndecl_string_minmax
= gfc_build_library_function_decl_with_spec (
3444 get_identifier (PREFIX("string_minmax")), ". W w . R ",
3445 void_type_node
, -4, build_pointer_type (gfc_charlen_type_node
),
3446 build_pointer_type (pchar1_type_node
), integer_type_node
,
3449 gfor_fndecl_adjustl
= gfc_build_library_function_decl_with_spec (
3450 get_identifier (PREFIX("adjustl")), ". W . R ",
3451 void_type_node
, 3, pchar1_type_node
, gfc_charlen_type_node
,
3453 TREE_NOTHROW (gfor_fndecl_adjustl
) = 1;
3455 gfor_fndecl_adjustr
= gfc_build_library_function_decl_with_spec (
3456 get_identifier (PREFIX("adjustr")), ". W . R ",
3457 void_type_node
, 3, pchar1_type_node
, gfc_charlen_type_node
,
3459 TREE_NOTHROW (gfor_fndecl_adjustr
) = 1;
3461 gfor_fndecl_select_string
= gfc_build_library_function_decl_with_spec (
3462 get_identifier (PREFIX("select_string")), ". R . R . ",
3463 integer_type_node
, 4, pvoid_type_node
, integer_type_node
,
3464 pchar1_type_node
, gfc_charlen_type_node
);
3465 DECL_PURE_P (gfor_fndecl_select_string
) = 1;
3466 TREE_NOTHROW (gfor_fndecl_select_string
) = 1;
3468 gfor_fndecl_compare_string_char4
= gfc_build_library_function_decl_with_spec (
3469 get_identifier (PREFIX("compare_string_char4")), ". . R . R ",
3470 integer_type_node
, 4, gfc_charlen_type_node
, pchar4_type_node
,
3471 gfc_charlen_type_node
, pchar4_type_node
);
3472 DECL_PURE_P (gfor_fndecl_compare_string_char4
) = 1;
3473 TREE_NOTHROW (gfor_fndecl_compare_string_char4
) = 1;
3475 gfor_fndecl_concat_string_char4
= gfc_build_library_function_decl_with_spec (
3476 get_identifier (PREFIX("concat_string_char4")), ". . W . R . R ",
3477 void_type_node
, 6, gfc_charlen_type_node
, pchar4_type_node
,
3478 gfc_charlen_type_node
, pchar4_type_node
, gfc_charlen_type_node
,
3480 TREE_NOTHROW (gfor_fndecl_concat_string_char4
) = 1;
3482 gfor_fndecl_string_len_trim_char4
= gfc_build_library_function_decl_with_spec (
3483 get_identifier (PREFIX("string_len_trim_char4")), ". . R ",
3484 gfc_charlen_type_node
, 2, gfc_charlen_type_node
, pchar4_type_node
);
3485 DECL_PURE_P (gfor_fndecl_string_len_trim_char4
) = 1;
3486 TREE_NOTHROW (gfor_fndecl_string_len_trim_char4
) = 1;
3488 gfor_fndecl_string_index_char4
= gfc_build_library_function_decl_with_spec (
3489 get_identifier (PREFIX("string_index_char4")), ". . R . R . ",
3490 gfc_charlen_type_node
, 5, gfc_charlen_type_node
, pchar4_type_node
,
3491 gfc_charlen_type_node
, pchar4_type_node
, gfc_logical4_type_node
);
3492 DECL_PURE_P (gfor_fndecl_string_index_char4
) = 1;
3493 TREE_NOTHROW (gfor_fndecl_string_index_char4
) = 1;
3495 gfor_fndecl_string_scan_char4
= gfc_build_library_function_decl_with_spec (
3496 get_identifier (PREFIX("string_scan_char4")), ". . R . R . ",
3497 gfc_charlen_type_node
, 5, gfc_charlen_type_node
, pchar4_type_node
,
3498 gfc_charlen_type_node
, pchar4_type_node
, gfc_logical4_type_node
);
3499 DECL_PURE_P (gfor_fndecl_string_scan_char4
) = 1;
3500 TREE_NOTHROW (gfor_fndecl_string_scan_char4
) = 1;
3502 gfor_fndecl_string_verify_char4
= gfc_build_library_function_decl_with_spec (
3503 get_identifier (PREFIX("string_verify_char4")), ". . R . R . ",
3504 gfc_charlen_type_node
, 5, gfc_charlen_type_node
, pchar4_type_node
,
3505 gfc_charlen_type_node
, pchar4_type_node
, gfc_logical4_type_node
);
3506 DECL_PURE_P (gfor_fndecl_string_verify_char4
) = 1;
3507 TREE_NOTHROW (gfor_fndecl_string_verify_char4
) = 1;
3509 gfor_fndecl_string_trim_char4
= gfc_build_library_function_decl_with_spec (
3510 get_identifier (PREFIX("string_trim_char4")), ". W w . R ",
3511 void_type_node
, 4, build_pointer_type (gfc_charlen_type_node
),
3512 build_pointer_type (pchar4_type_node
), gfc_charlen_type_node
,
3515 gfor_fndecl_string_minmax_char4
= gfc_build_library_function_decl_with_spec (
3516 get_identifier (PREFIX("string_minmax_char4")), ". W w . R ",
3517 void_type_node
, -4, build_pointer_type (gfc_charlen_type_node
),
3518 build_pointer_type (pchar4_type_node
), integer_type_node
,
3521 gfor_fndecl_adjustl_char4
= gfc_build_library_function_decl_with_spec (
3522 get_identifier (PREFIX("adjustl_char4")), ". W . R ",
3523 void_type_node
, 3, pchar4_type_node
, gfc_charlen_type_node
,
3525 TREE_NOTHROW (gfor_fndecl_adjustl_char4
) = 1;
3527 gfor_fndecl_adjustr_char4
= gfc_build_library_function_decl_with_spec (
3528 get_identifier (PREFIX("adjustr_char4")), ". W . R ",
3529 void_type_node
, 3, pchar4_type_node
, gfc_charlen_type_node
,
3531 TREE_NOTHROW (gfor_fndecl_adjustr_char4
) = 1;
3533 gfor_fndecl_select_string_char4
= gfc_build_library_function_decl_with_spec (
3534 get_identifier (PREFIX("select_string_char4")), ". R . R . ",
3535 integer_type_node
, 4, pvoid_type_node
, integer_type_node
,
3536 pvoid_type_node
, gfc_charlen_type_node
);
3537 DECL_PURE_P (gfor_fndecl_select_string_char4
) = 1;
3538 TREE_NOTHROW (gfor_fndecl_select_string_char4
) = 1;
3541 /* Conversion between character kinds. */
3543 gfor_fndecl_convert_char1_to_char4
= gfc_build_library_function_decl_with_spec (
3544 get_identifier (PREFIX("convert_char1_to_char4")), ". w . R ",
3545 void_type_node
, 3, build_pointer_type (pchar4_type_node
),
3546 gfc_charlen_type_node
, pchar1_type_node
);
3548 gfor_fndecl_convert_char4_to_char1
= gfc_build_library_function_decl_with_spec (
3549 get_identifier (PREFIX("convert_char4_to_char1")), ". w . R ",
3550 void_type_node
, 3, build_pointer_type (pchar1_type_node
),
3551 gfc_charlen_type_node
, pchar4_type_node
);
3553 /* Misc. functions. */
3555 gfor_fndecl_ttynam
= gfc_build_library_function_decl_with_spec (
3556 get_identifier (PREFIX("ttynam")), ". W . . ",
3557 void_type_node
, 3, pchar_type_node
, gfc_charlen_type_node
,
3560 gfor_fndecl_fdate
= gfc_build_library_function_decl_with_spec (
3561 get_identifier (PREFIX("fdate")), ". W . ",
3562 void_type_node
, 2, pchar_type_node
, gfc_charlen_type_node
);
3564 gfor_fndecl_ctime
= gfc_build_library_function_decl_with_spec (
3565 get_identifier (PREFIX("ctime")), ". W . . ",
3566 void_type_node
, 3, pchar_type_node
, gfc_charlen_type_node
,
3567 gfc_int8_type_node
);
3569 gfor_fndecl_random_init
= gfc_build_library_function_decl (
3570 get_identifier (PREFIX("random_init")),
3571 void_type_node
, 3, gfc_logical4_type_node
, gfc_logical4_type_node
,
3572 gfc_int4_type_node
);
3574 // gfor_fndecl_caf_rand_init is defined in the lib-coarray section below.
3576 gfor_fndecl_sc_kind
= gfc_build_library_function_decl_with_spec (
3577 get_identifier (PREFIX("selected_char_kind")), ". . R ",
3578 gfc_int4_type_node
, 2, gfc_charlen_type_node
, pchar_type_node
);
3579 DECL_PURE_P (gfor_fndecl_sc_kind
) = 1;
3580 TREE_NOTHROW (gfor_fndecl_sc_kind
) = 1;
3582 gfor_fndecl_si_kind
= gfc_build_library_function_decl_with_spec (
3583 get_identifier (PREFIX("selected_int_kind")), ". R ",
3584 gfc_int4_type_node
, 1, pvoid_type_node
);
3585 DECL_PURE_P (gfor_fndecl_si_kind
) = 1;
3586 TREE_NOTHROW (gfor_fndecl_si_kind
) = 1;
3588 gfor_fndecl_sr_kind
= gfc_build_library_function_decl_with_spec (
3589 get_identifier (PREFIX("selected_real_kind2008")), ". R R ",
3590 gfc_int4_type_node
, 3, pvoid_type_node
, pvoid_type_node
,
3592 DECL_PURE_P (gfor_fndecl_sr_kind
) = 1;
3593 TREE_NOTHROW (gfor_fndecl_sr_kind
) = 1;
3595 gfor_fndecl_system_clock4
= gfc_build_library_function_decl (
3596 get_identifier (PREFIX("system_clock_4")),
3597 void_type_node
, 3, gfc_pint4_type_node
, gfc_pint4_type_node
,
3598 gfc_pint4_type_node
);
3600 gfor_fndecl_system_clock8
= gfc_build_library_function_decl (
3601 get_identifier (PREFIX("system_clock_8")),
3602 void_type_node
, 3, gfc_pint8_type_node
, gfc_pint8_type_node
,
3603 gfc_pint8_type_node
);
3605 /* Power functions. */
3607 tree ctype
, rtype
, itype
, jtype
;
3608 int rkind
, ikind
, jkind
;
3611 static int ikinds
[NIKINDS
] = {4, 8, 16};
3612 static int rkinds
[NRKINDS
] = {4, 8, 10, 16};
3613 char name
[PREFIX_LEN
+ 12]; /* _gfortran_pow_?n_?n */
3615 for (ikind
=0; ikind
< NIKINDS
; ikind
++)
3617 itype
= gfc_get_int_type (ikinds
[ikind
]);
3619 for (jkind
=0; jkind
< NIKINDS
; jkind
++)
3621 jtype
= gfc_get_int_type (ikinds
[jkind
]);
3624 sprintf (name
, PREFIX("pow_i%d_i%d"), ikinds
[ikind
],
3626 gfor_fndecl_math_powi
[jkind
][ikind
].integer
=
3627 gfc_build_library_function_decl (get_identifier (name
),
3628 jtype
, 2, jtype
, itype
);
3629 TREE_READONLY (gfor_fndecl_math_powi
[jkind
][ikind
].integer
) = 1;
3630 TREE_NOTHROW (gfor_fndecl_math_powi
[jkind
][ikind
].integer
) = 1;
3634 for (rkind
= 0; rkind
< NRKINDS
; rkind
++)
3636 rtype
= gfc_get_real_type (rkinds
[rkind
]);
3639 sprintf (name
, PREFIX("pow_r%d_i%d"),
3640 gfc_type_abi_kind (BT_REAL
, rkinds
[rkind
]),
3642 gfor_fndecl_math_powi
[rkind
][ikind
].real
=
3643 gfc_build_library_function_decl (get_identifier (name
),
3644 rtype
, 2, rtype
, itype
);
3645 TREE_READONLY (gfor_fndecl_math_powi
[rkind
][ikind
].real
) = 1;
3646 TREE_NOTHROW (gfor_fndecl_math_powi
[rkind
][ikind
].real
) = 1;
3649 ctype
= gfc_get_complex_type (rkinds
[rkind
]);
3652 sprintf (name
, PREFIX("pow_c%d_i%d"),
3653 gfc_type_abi_kind (BT_REAL
, rkinds
[rkind
]),
3655 gfor_fndecl_math_powi
[rkind
][ikind
].cmplx
=
3656 gfc_build_library_function_decl (get_identifier (name
),
3657 ctype
, 2,ctype
, itype
);
3658 TREE_READONLY (gfor_fndecl_math_powi
[rkind
][ikind
].cmplx
) = 1;
3659 TREE_NOTHROW (gfor_fndecl_math_powi
[rkind
][ikind
].cmplx
) = 1;
3667 gfor_fndecl_math_ishftc4
= gfc_build_library_function_decl (
3668 get_identifier (PREFIX("ishftc4")),
3669 gfc_int4_type_node
, 3, gfc_int4_type_node
, gfc_int4_type_node
,
3670 gfc_int4_type_node
);
3671 TREE_READONLY (gfor_fndecl_math_ishftc4
) = 1;
3672 TREE_NOTHROW (gfor_fndecl_math_ishftc4
) = 1;
3674 gfor_fndecl_math_ishftc8
= gfc_build_library_function_decl (
3675 get_identifier (PREFIX("ishftc8")),
3676 gfc_int8_type_node
, 3, gfc_int8_type_node
, gfc_int4_type_node
,
3677 gfc_int4_type_node
);
3678 TREE_READONLY (gfor_fndecl_math_ishftc8
) = 1;
3679 TREE_NOTHROW (gfor_fndecl_math_ishftc8
) = 1;
3681 if (gfc_int16_type_node
)
3683 gfor_fndecl_math_ishftc16
= gfc_build_library_function_decl (
3684 get_identifier (PREFIX("ishftc16")),
3685 gfc_int16_type_node
, 3, gfc_int16_type_node
, gfc_int4_type_node
,
3686 gfc_int4_type_node
);
3687 TREE_READONLY (gfor_fndecl_math_ishftc16
) = 1;
3688 TREE_NOTHROW (gfor_fndecl_math_ishftc16
) = 1;
3691 /* BLAS functions. */
3693 tree pint
= build_pointer_type (integer_type_node
);
3694 tree ps
= build_pointer_type (gfc_get_real_type (gfc_default_real_kind
));
3695 tree pd
= build_pointer_type (gfc_get_real_type (gfc_default_double_kind
));
3696 tree pc
= build_pointer_type (gfc_get_complex_type (gfc_default_real_kind
));
3697 tree pz
= build_pointer_type
3698 (gfc_get_complex_type (gfc_default_double_kind
));
3700 gfor_fndecl_sgemm
= gfc_build_library_function_decl
3702 (flag_underscoring
? "sgemm_" : "sgemm"),
3703 void_type_node
, 15, pchar_type_node
,
3704 pchar_type_node
, pint
, pint
, pint
, ps
, ps
, pint
,
3705 ps
, pint
, ps
, ps
, pint
, integer_type_node
,
3707 gfor_fndecl_dgemm
= gfc_build_library_function_decl
3709 (flag_underscoring
? "dgemm_" : "dgemm"),
3710 void_type_node
, 15, pchar_type_node
,
3711 pchar_type_node
, pint
, pint
, pint
, pd
, pd
, pint
,
3712 pd
, pint
, pd
, pd
, pint
, integer_type_node
,
3714 gfor_fndecl_cgemm
= gfc_build_library_function_decl
3716 (flag_underscoring
? "cgemm_" : "cgemm"),
3717 void_type_node
, 15, pchar_type_node
,
3718 pchar_type_node
, pint
, pint
, pint
, pc
, pc
, pint
,
3719 pc
, pint
, pc
, pc
, pint
, integer_type_node
,
3721 gfor_fndecl_zgemm
= gfc_build_library_function_decl
3723 (flag_underscoring
? "zgemm_" : "zgemm"),
3724 void_type_node
, 15, pchar_type_node
,
3725 pchar_type_node
, pint
, pint
, pint
, pz
, pz
, pint
,
3726 pz
, pint
, pz
, pz
, pint
, integer_type_node
,
3730 /* Other functions. */
3731 gfor_fndecl_iargc
= gfc_build_library_function_decl (
3732 get_identifier (PREFIX ("iargc")), gfc_int4_type_node
, 0);
3733 TREE_NOTHROW (gfor_fndecl_iargc
) = 1;
3735 gfor_fndecl_kill_sub
= gfc_build_library_function_decl (
3736 get_identifier (PREFIX ("kill_sub")), void_type_node
,
3737 3, gfc_int4_type_node
, gfc_int4_type_node
, gfc_pint4_type_node
);
3739 gfor_fndecl_kill
= gfc_build_library_function_decl (
3740 get_identifier (PREFIX ("kill")), gfc_int4_type_node
,
3741 2, gfc_int4_type_node
, gfc_int4_type_node
);
3743 gfor_fndecl_is_contiguous0
= gfc_build_library_function_decl_with_spec (
3744 get_identifier (PREFIX("is_contiguous0")), ". R ",
3745 gfc_int4_type_node
, 1, pvoid_type_node
);
3746 DECL_PURE_P (gfor_fndecl_is_contiguous0
) = 1;
3747 TREE_NOTHROW (gfor_fndecl_is_contiguous0
) = 1;
3751 /* Make prototypes for runtime library functions. */
3754 gfc_build_builtin_function_decls (void)
3756 tree gfc_int8_type_node
= gfc_get_int_type (8);
3758 gfor_fndecl_stop_numeric
= gfc_build_library_function_decl (
3759 get_identifier (PREFIX("stop_numeric")),
3760 void_type_node
, 2, integer_type_node
, boolean_type_node
);
3761 /* STOP doesn't return. */
3762 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric
) = 1;
3764 gfor_fndecl_stop_string
= gfc_build_library_function_decl_with_spec (
3765 get_identifier (PREFIX("stop_string")), ". R . . ",
3766 void_type_node
, 3, pchar_type_node
, size_type_node
,
3768 /* STOP doesn't return. */
3769 TREE_THIS_VOLATILE (gfor_fndecl_stop_string
) = 1;
3771 gfor_fndecl_error_stop_numeric
= gfc_build_library_function_decl (
3772 get_identifier (PREFIX("error_stop_numeric")),
3773 void_type_node
, 2, integer_type_node
, boolean_type_node
);
3774 /* ERROR STOP doesn't return. */
3775 TREE_THIS_VOLATILE (gfor_fndecl_error_stop_numeric
) = 1;
3777 gfor_fndecl_error_stop_string
= gfc_build_library_function_decl_with_spec (
3778 get_identifier (PREFIX("error_stop_string")), ". R . . ",
3779 void_type_node
, 3, pchar_type_node
, size_type_node
,
3781 /* ERROR STOP doesn't return. */
3782 TREE_THIS_VOLATILE (gfor_fndecl_error_stop_string
) = 1;
3784 gfor_fndecl_pause_numeric
= gfc_build_library_function_decl (
3785 get_identifier (PREFIX("pause_numeric")),
3786 void_type_node
, 1, gfc_int8_type_node
);
3788 gfor_fndecl_pause_string
= gfc_build_library_function_decl_with_spec (
3789 get_identifier (PREFIX("pause_string")), ". R . ",
3790 void_type_node
, 2, pchar_type_node
, size_type_node
);
3792 gfor_fndecl_runtime_error
= gfc_build_library_function_decl_with_spec (
3793 get_identifier (PREFIX("runtime_error")), ". R ",
3794 void_type_node
, -1, pchar_type_node
);
3795 /* The runtime_error function does not return. */
3796 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error
) = 1;
3798 gfor_fndecl_runtime_error_at
= gfc_build_library_function_decl_with_spec (
3799 get_identifier (PREFIX("runtime_error_at")), ". R R ",
3800 void_type_node
, -2, pchar_type_node
, pchar_type_node
);
3801 /* The runtime_error_at function does not return. */
3802 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at
) = 1;
3804 gfor_fndecl_runtime_warning_at
= gfc_build_library_function_decl_with_spec (
3805 get_identifier (PREFIX("runtime_warning_at")), ". R R ",
3806 void_type_node
, -2, pchar_type_node
, pchar_type_node
);
3808 gfor_fndecl_generate_error
= gfc_build_library_function_decl_with_spec (
3809 get_identifier (PREFIX("generate_error")), ". R . R ",
3810 void_type_node
, 3, pvoid_type_node
, integer_type_node
,
3813 gfor_fndecl_os_error_at
= gfc_build_library_function_decl_with_spec (
3814 get_identifier (PREFIX("os_error_at")), ". R R ",
3815 void_type_node
, -2, pchar_type_node
, pchar_type_node
);
3816 /* The os_error_at function does not return. */
3817 TREE_THIS_VOLATILE (gfor_fndecl_os_error_at
) = 1;
3819 gfor_fndecl_set_args
= gfc_build_library_function_decl (
3820 get_identifier (PREFIX("set_args")),
3821 void_type_node
, 2, integer_type_node
,
3822 build_pointer_type (pchar_type_node
));
3824 gfor_fndecl_set_fpe
= gfc_build_library_function_decl (
3825 get_identifier (PREFIX("set_fpe")),
3826 void_type_node
, 1, integer_type_node
);
3828 gfor_fndecl_ieee_procedure_entry
= gfc_build_library_function_decl (
3829 get_identifier (PREFIX("ieee_procedure_entry")),
3830 void_type_node
, 1, pvoid_type_node
);
3832 gfor_fndecl_ieee_procedure_exit
= gfc_build_library_function_decl (
3833 get_identifier (PREFIX("ieee_procedure_exit")),
3834 void_type_node
, 1, pvoid_type_node
);
3836 /* Keep the array dimension in sync with the call, later in this file. */
3837 gfor_fndecl_set_options
= gfc_build_library_function_decl_with_spec (
3838 get_identifier (PREFIX("set_options")), ". . R ",
3839 void_type_node
, 2, integer_type_node
,
3840 build_pointer_type (integer_type_node
));
3842 gfor_fndecl_set_convert
= gfc_build_library_function_decl (
3843 get_identifier (PREFIX("set_convert")),
3844 void_type_node
, 1, integer_type_node
);
3846 gfor_fndecl_set_record_marker
= gfc_build_library_function_decl (
3847 get_identifier (PREFIX("set_record_marker")),
3848 void_type_node
, 1, integer_type_node
);
3850 gfor_fndecl_set_max_subrecord_length
= gfc_build_library_function_decl (
3851 get_identifier (PREFIX("set_max_subrecord_length")),
3852 void_type_node
, 1, integer_type_node
);
3854 gfor_fndecl_in_pack
= gfc_build_library_function_decl_with_spec (
3855 get_identifier (PREFIX("internal_pack")), ". r ",
3856 pvoid_type_node
, 1, pvoid_type_node
);
3858 gfor_fndecl_in_unpack
= gfc_build_library_function_decl_with_spec (
3859 get_identifier (PREFIX("internal_unpack")), ". w R ",
3860 void_type_node
, 2, pvoid_type_node
, pvoid_type_node
);
3862 gfor_fndecl_associated
= gfc_build_library_function_decl_with_spec (
3863 get_identifier (PREFIX("associated")), ". R R ",
3864 integer_type_node
, 2, ppvoid_type_node
, ppvoid_type_node
);
3865 DECL_PURE_P (gfor_fndecl_associated
) = 1;
3866 TREE_NOTHROW (gfor_fndecl_associated
) = 1;
3868 /* Coarray library calls. */
3869 if (flag_coarray
== GFC_FCOARRAY_LIB
)
3871 tree pint_type
, pppchar_type
;
3873 pint_type
= build_pointer_type (integer_type_node
);
3875 = build_pointer_type (build_pointer_type (pchar_type_node
));
3877 gfor_fndecl_caf_init
= gfc_build_library_function_decl_with_spec (
3878 get_identifier (PREFIX("caf_init")), ". W W ",
3879 void_type_node
, 2, pint_type
, pppchar_type
);
3881 gfor_fndecl_caf_finalize
= gfc_build_library_function_decl (
3882 get_identifier (PREFIX("caf_finalize")), void_type_node
, 0);
3884 gfor_fndecl_caf_this_image
= gfc_build_library_function_decl (
3885 get_identifier (PREFIX("caf_this_image")), integer_type_node
,
3886 1, integer_type_node
);
3888 gfor_fndecl_caf_num_images
= gfc_build_library_function_decl (
3889 get_identifier (PREFIX("caf_num_images")), integer_type_node
,
3890 2, integer_type_node
, integer_type_node
);
3892 gfor_fndecl_caf_register
= gfc_build_library_function_decl_with_spec (
3893 get_identifier (PREFIX("caf_register")), ". . . W w w w . ",
3895 size_type_node
, integer_type_node
, ppvoid_type_node
, pvoid_type_node
,
3896 pint_type
, pchar_type_node
, size_type_node
);
3898 gfor_fndecl_caf_deregister
= gfc_build_library_function_decl_with_spec (
3899 get_identifier (PREFIX("caf_deregister")), ". W . w w . ",
3901 ppvoid_type_node
, integer_type_node
, pint_type
, pchar_type_node
,
3904 gfor_fndecl_caf_get
= gfc_build_library_function_decl_with_spec (
3905 get_identifier (PREFIX("caf_get")), ". r . . r r w . . . w ",
3907 pvoid_type_node
, size_type_node
, integer_type_node
, pvoid_type_node
,
3908 pvoid_type_node
, pvoid_type_node
, integer_type_node
, integer_type_node
,
3909 boolean_type_node
, pint_type
);
3911 gfor_fndecl_caf_send
= gfc_build_library_function_decl_with_spec (
3912 get_identifier (PREFIX("caf_send")), ". r . . w r r . . . w ",
3914 pvoid_type_node
, size_type_node
, integer_type_node
, pvoid_type_node
,
3915 pvoid_type_node
, pvoid_type_node
, integer_type_node
, integer_type_node
,
3916 boolean_type_node
, pint_type
, pvoid_type_node
);
3918 gfor_fndecl_caf_sendget
= gfc_build_library_function_decl_with_spec (
3919 get_identifier (PREFIX("caf_sendget")), ". r . . w r r . . r r . . . w ",
3920 void_type_node
, 14, pvoid_type_node
, size_type_node
, integer_type_node
,
3921 pvoid_type_node
, pvoid_type_node
, pvoid_type_node
, size_type_node
,
3922 integer_type_node
, pvoid_type_node
, pvoid_type_node
, integer_type_node
,
3923 integer_type_node
, boolean_type_node
, integer_type_node
);
3925 gfor_fndecl_caf_get_by_ref
= gfc_build_library_function_decl_with_spec (
3926 get_identifier (PREFIX("caf_get_by_ref")), ". r . w r . . . . w . ",
3928 10, pvoid_type_node
, integer_type_node
, pvoid_type_node
,
3929 pvoid_type_node
, integer_type_node
, integer_type_node
,
3930 boolean_type_node
, boolean_type_node
, pint_type
, integer_type_node
);
3932 gfor_fndecl_caf_send_by_ref
= gfc_build_library_function_decl_with_spec (
3933 get_identifier (PREFIX("caf_send_by_ref")), ". r . r r . . . . w . ",
3934 void_type_node
, 10, pvoid_type_node
, integer_type_node
, pvoid_type_node
,
3935 pvoid_type_node
, integer_type_node
, integer_type_node
,
3936 boolean_type_node
, boolean_type_node
, pint_type
, integer_type_node
);
3938 gfor_fndecl_caf_sendget_by_ref
3939 = gfc_build_library_function_decl_with_spec (
3940 get_identifier (PREFIX("caf_sendget_by_ref")),
3941 ". r . r r . r . . . w w . . ",
3942 void_type_node
, 13, pvoid_type_node
, integer_type_node
,
3943 pvoid_type_node
, pvoid_type_node
, integer_type_node
,
3944 pvoid_type_node
, integer_type_node
, integer_type_node
,
3945 boolean_type_node
, pint_type
, pint_type
, integer_type_node
,
3948 gfor_fndecl_caf_sync_all
= gfc_build_library_function_decl_with_spec (
3949 get_identifier (PREFIX("caf_sync_all")), ". w w . ", void_type_node
,
3950 3, pint_type
, pchar_type_node
, size_type_node
);
3952 gfor_fndecl_caf_sync_memory
= gfc_build_library_function_decl_with_spec (
3953 get_identifier (PREFIX("caf_sync_memory")), ". w w . ", void_type_node
,
3954 3, pint_type
, pchar_type_node
, size_type_node
);
3956 gfor_fndecl_caf_sync_images
= gfc_build_library_function_decl_with_spec (
3957 get_identifier (PREFIX("caf_sync_images")), ". . r w w . ", void_type_node
,
3958 5, integer_type_node
, pint_type
, pint_type
,
3959 pchar_type_node
, size_type_node
);
3961 gfor_fndecl_caf_error_stop
= gfc_build_library_function_decl (
3962 get_identifier (PREFIX("caf_error_stop")),
3963 void_type_node
, 1, integer_type_node
);
3964 /* CAF's ERROR STOP doesn't return. */
3965 TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop
) = 1;
3967 gfor_fndecl_caf_error_stop_str
= gfc_build_library_function_decl_with_spec (
3968 get_identifier (PREFIX("caf_error_stop_str")), ". r . ",
3969 void_type_node
, 2, pchar_type_node
, size_type_node
);
3970 /* CAF's ERROR STOP doesn't return. */
3971 TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop_str
) = 1;
3973 gfor_fndecl_caf_stop_numeric
= gfc_build_library_function_decl (
3974 get_identifier (PREFIX("caf_stop_numeric")),
3975 void_type_node
, 1, integer_type_node
);
3976 /* CAF's STOP doesn't return. */
3977 TREE_THIS_VOLATILE (gfor_fndecl_caf_stop_numeric
) = 1;
3979 gfor_fndecl_caf_stop_str
= gfc_build_library_function_decl_with_spec (
3980 get_identifier (PREFIX("caf_stop_str")), ". r . ",
3981 void_type_node
, 2, pchar_type_node
, size_type_node
);
3982 /* CAF's STOP doesn't return. */
3983 TREE_THIS_VOLATILE (gfor_fndecl_caf_stop_str
) = 1;
3985 gfor_fndecl_caf_atomic_def
= gfc_build_library_function_decl_with_spec (
3986 get_identifier (PREFIX("caf_atomic_define")), ". r . . w w . . ",
3987 void_type_node
, 7, pvoid_type_node
, size_type_node
, integer_type_node
,
3988 pvoid_type_node
, pint_type
, integer_type_node
, integer_type_node
);
3990 gfor_fndecl_caf_atomic_ref
= gfc_build_library_function_decl_with_spec (
3991 get_identifier (PREFIX("caf_atomic_ref")), ". r . . w w . . ",
3992 void_type_node
, 7, pvoid_type_node
, size_type_node
, integer_type_node
,
3993 pvoid_type_node
, pint_type
, integer_type_node
, integer_type_node
);
3995 gfor_fndecl_caf_atomic_cas
= gfc_build_library_function_decl_with_spec (
3996 get_identifier (PREFIX("caf_atomic_cas")), ". r . . w r r w . . ",
3997 void_type_node
, 9, pvoid_type_node
, size_type_node
, integer_type_node
,
3998 pvoid_type_node
, pvoid_type_node
, pvoid_type_node
, pint_type
,
3999 integer_type_node
, integer_type_node
);
4001 gfor_fndecl_caf_atomic_op
= gfc_build_library_function_decl_with_spec (
4002 get_identifier (PREFIX("caf_atomic_op")), ". . r . . r w w . . ",
4003 void_type_node
, 9, integer_type_node
, pvoid_type_node
, size_type_node
,
4004 integer_type_node
, pvoid_type_node
, pvoid_type_node
, pint_type
,
4005 integer_type_node
, integer_type_node
);
4007 gfor_fndecl_caf_lock
= gfc_build_library_function_decl_with_spec (
4008 get_identifier (PREFIX("caf_lock")), ". r . . w w w . ",
4009 void_type_node
, 7, pvoid_type_node
, size_type_node
, integer_type_node
,
4010 pint_type
, pint_type
, pchar_type_node
, size_type_node
);
4012 gfor_fndecl_caf_unlock
= gfc_build_library_function_decl_with_spec (
4013 get_identifier (PREFIX("caf_unlock")), ". r . . w w . ",
4014 void_type_node
, 6, pvoid_type_node
, size_type_node
, integer_type_node
,
4015 pint_type
, pchar_type_node
, size_type_node
);
4017 gfor_fndecl_caf_event_post
= gfc_build_library_function_decl_with_spec (
4018 get_identifier (PREFIX("caf_event_post")), ". r . . w w . ",
4019 void_type_node
, 6, pvoid_type_node
, size_type_node
, integer_type_node
,
4020 pint_type
, pchar_type_node
, size_type_node
);
4022 gfor_fndecl_caf_event_wait
= gfc_build_library_function_decl_with_spec (
4023 get_identifier (PREFIX("caf_event_wait")), ". r . . w w . ",
4024 void_type_node
, 6, pvoid_type_node
, size_type_node
, integer_type_node
,
4025 pint_type
, pchar_type_node
, size_type_node
);
4027 gfor_fndecl_caf_event_query
= gfc_build_library_function_decl_with_spec (
4028 get_identifier (PREFIX("caf_event_query")), ". r . . w w ",
4029 void_type_node
, 5, pvoid_type_node
, size_type_node
, integer_type_node
,
4030 pint_type
, pint_type
);
4032 gfor_fndecl_caf_fail_image
= gfc_build_library_function_decl (
4033 get_identifier (PREFIX("caf_fail_image")), void_type_node
, 0);
4034 /* CAF's FAIL doesn't return. */
4035 TREE_THIS_VOLATILE (gfor_fndecl_caf_fail_image
) = 1;
4037 gfor_fndecl_caf_failed_images
4038 = gfc_build_library_function_decl_with_spec (
4039 get_identifier (PREFIX("caf_failed_images")), ". w . r ",
4040 void_type_node
, 3, pvoid_type_node
, ppvoid_type_node
,
4043 gfor_fndecl_caf_form_team
4044 = gfc_build_library_function_decl_with_spec (
4045 get_identifier (PREFIX("caf_form_team")), ". . W . ",
4046 void_type_node
, 3, integer_type_node
, ppvoid_type_node
,
4049 gfor_fndecl_caf_change_team
4050 = gfc_build_library_function_decl_with_spec (
4051 get_identifier (PREFIX("caf_change_team")), ". w . ",
4052 void_type_node
, 2, ppvoid_type_node
,
4055 gfor_fndecl_caf_end_team
4056 = gfc_build_library_function_decl (
4057 get_identifier (PREFIX("caf_end_team")), void_type_node
, 0);
4059 gfor_fndecl_caf_get_team
4060 = gfc_build_library_function_decl (
4061 get_identifier (PREFIX("caf_get_team")),
4062 void_type_node
, 1, integer_type_node
);
4064 gfor_fndecl_caf_sync_team
4065 = gfc_build_library_function_decl_with_spec (
4066 get_identifier (PREFIX("caf_sync_team")), ". r . ",
4067 void_type_node
, 2, ppvoid_type_node
,
4070 gfor_fndecl_caf_team_number
4071 = gfc_build_library_function_decl_with_spec (
4072 get_identifier (PREFIX("caf_team_number")), ". r ",
4073 integer_type_node
, 1, integer_type_node
);
4075 gfor_fndecl_caf_image_status
4076 = gfc_build_library_function_decl_with_spec (
4077 get_identifier (PREFIX("caf_image_status")), ". . r ",
4078 integer_type_node
, 2, integer_type_node
, ppvoid_type_node
);
4080 gfor_fndecl_caf_stopped_images
4081 = gfc_build_library_function_decl_with_spec (
4082 get_identifier (PREFIX("caf_stopped_images")), ". w r r ",
4083 void_type_node
, 3, pvoid_type_node
, ppvoid_type_node
,
4086 gfor_fndecl_co_broadcast
= gfc_build_library_function_decl_with_spec (
4087 get_identifier (PREFIX("caf_co_broadcast")), ". w . w w . ",
4088 void_type_node
, 5, pvoid_type_node
, integer_type_node
,
4089 pint_type
, pchar_type_node
, size_type_node
);
4091 gfor_fndecl_co_max
= gfc_build_library_function_decl_with_spec (
4092 get_identifier (PREFIX("caf_co_max")), ". w . w w . . ",
4093 void_type_node
, 6, pvoid_type_node
, integer_type_node
,
4094 pint_type
, pchar_type_node
, integer_type_node
, size_type_node
);
4096 gfor_fndecl_co_min
= gfc_build_library_function_decl_with_spec (
4097 get_identifier (PREFIX("caf_co_min")), ". w . w w . . ",
4098 void_type_node
, 6, pvoid_type_node
, integer_type_node
,
4099 pint_type
, pchar_type_node
, integer_type_node
, size_type_node
);
4101 gfor_fndecl_co_reduce
= gfc_build_library_function_decl_with_spec (
4102 get_identifier (PREFIX("caf_co_reduce")), ". w r . . w w . . ",
4103 void_type_node
, 8, pvoid_type_node
,
4104 build_pointer_type (build_varargs_function_type_list (void_type_node
,
4106 integer_type_node
, integer_type_node
, pint_type
, pchar_type_node
,
4107 integer_type_node
, size_type_node
);
4109 gfor_fndecl_co_sum
= gfc_build_library_function_decl_with_spec (
4110 get_identifier (PREFIX("caf_co_sum")), ". w . w w . ",
4111 void_type_node
, 5, pvoid_type_node
, integer_type_node
,
4112 pint_type
, pchar_type_node
, size_type_node
);
4114 gfor_fndecl_caf_is_present
= gfc_build_library_function_decl_with_spec (
4115 get_identifier (PREFIX("caf_is_present")), ". r . r ",
4116 integer_type_node
, 3, pvoid_type_node
, integer_type_node
,
4119 gfor_fndecl_caf_random_init
= gfc_build_library_function_decl (
4120 get_identifier (PREFIX("caf_random_init")),
4121 void_type_node
, 2, logical_type_node
, logical_type_node
);
4124 gfc_build_intrinsic_function_decls ();
4125 gfc_build_intrinsic_lib_fndecls ();
4126 gfc_build_io_library_fndecls ();
4130 /* Evaluate the length of dummy character variables. */
4133 gfc_trans_dummy_character (gfc_symbol
*sym
, gfc_charlen
*cl
,
4134 gfc_wrapped_block
*block
)
4138 gfc_finish_decl (cl
->backend_decl
);
4140 gfc_start_block (&init
);
4142 /* Evaluate the string length expression. */
4143 gfc_conv_string_length (cl
, NULL
, &init
);
4145 gfc_trans_vla_type_sizes (sym
, &init
);
4147 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
4151 /* Allocate and cleanup an automatic character variable. */
4154 gfc_trans_auto_character_variable (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
4160 gcc_assert (sym
->backend_decl
);
4161 gcc_assert (sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
);
4163 gfc_init_block (&init
);
4165 /* Evaluate the string length expression. */
4166 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
4168 gfc_trans_vla_type_sizes (sym
, &init
);
4170 decl
= sym
->backend_decl
;
4172 /* Emit a DECL_EXPR for this variable, which will cause the
4173 gimplifier to allocate storage, and all that good stuff. */
4174 tmp
= fold_build1_loc (input_location
, DECL_EXPR
, TREE_TYPE (decl
), decl
);
4175 gfc_add_expr_to_block (&init
, tmp
);
4177 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
4180 /* Set the initial value of ASSIGN statement auxiliary variable explicitly. */
4183 gfc_trans_assign_aux_var (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
4187 gcc_assert (sym
->backend_decl
);
4188 gfc_start_block (&init
);
4190 /* Set the initial value to length. See the comments in
4191 function gfc_add_assign_aux_vars in this file. */
4192 gfc_add_modify (&init
, GFC_DECL_STRING_LEN (sym
->backend_decl
),
4193 build_int_cst (gfc_charlen_type_node
, -2));
4195 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
4199 gfc_trans_vla_one_sizepos (tree
*tp
, stmtblock_t
*body
)
4201 tree t
= *tp
, var
, val
;
4203 if (t
== NULL
|| t
== error_mark_node
)
4205 if (TREE_CONSTANT (t
) || DECL_P (t
))
4208 if (TREE_CODE (t
) == SAVE_EXPR
)
4210 if (SAVE_EXPR_RESOLVED_P (t
))
4212 *tp
= TREE_OPERAND (t
, 0);
4215 val
= TREE_OPERAND (t
, 0);
4220 var
= gfc_create_var_np (TREE_TYPE (t
), NULL
);
4221 gfc_add_decl_to_function (var
);
4222 gfc_add_modify (body
, var
, unshare_expr (val
));
4223 if (TREE_CODE (t
) == SAVE_EXPR
)
4224 TREE_OPERAND (t
, 0) = var
;
4229 gfc_trans_vla_type_sizes_1 (tree type
, stmtblock_t
*body
)
4233 if (type
== NULL
|| type
== error_mark_node
)
4236 type
= TYPE_MAIN_VARIANT (type
);
4238 if (TREE_CODE (type
) == INTEGER_TYPE
)
4240 gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type
), body
);
4241 gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type
), body
);
4243 for (t
= TYPE_NEXT_VARIANT (type
); t
; t
= TYPE_NEXT_VARIANT (t
))
4245 TYPE_MIN_VALUE (t
) = TYPE_MIN_VALUE (type
);
4246 TYPE_MAX_VALUE (t
) = TYPE_MAX_VALUE (type
);
4249 else if (TREE_CODE (type
) == ARRAY_TYPE
)
4251 gfc_trans_vla_type_sizes_1 (TREE_TYPE (type
), body
);
4252 gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type
), body
);
4253 gfc_trans_vla_one_sizepos (&TYPE_SIZE (type
), body
);
4254 gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type
), body
);
4256 for (t
= TYPE_NEXT_VARIANT (type
); t
; t
= TYPE_NEXT_VARIANT (t
))
4258 TYPE_SIZE (t
) = TYPE_SIZE (type
);
4259 TYPE_SIZE_UNIT (t
) = TYPE_SIZE_UNIT (type
);
4264 /* Make sure all type sizes and array domains are either constant,
4265 or variable or parameter decls. This is a simplified variant
4266 of gimplify_type_sizes, but we can't use it here, as none of the
4267 variables in the expressions have been gimplified yet.
4268 As type sizes and domains for various variable length arrays
4269 contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
4270 time, without this routine gimplify_type_sizes in the middle-end
4271 could result in the type sizes being gimplified earlier than where
4272 those variables are initialized. */
4275 gfc_trans_vla_type_sizes (gfc_symbol
*sym
, stmtblock_t
*body
)
4277 tree type
= TREE_TYPE (sym
->backend_decl
);
4279 if (TREE_CODE (type
) == FUNCTION_TYPE
4280 && (sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.entry
))
4282 if (! current_fake_result_decl
)
4285 type
= TREE_TYPE (TREE_VALUE (current_fake_result_decl
));
4288 while (POINTER_TYPE_P (type
))
4289 type
= TREE_TYPE (type
);
4291 if (GFC_DESCRIPTOR_TYPE_P (type
))
4293 tree etype
= GFC_TYPE_ARRAY_DATAPTR_TYPE (type
);
4295 while (POINTER_TYPE_P (etype
))
4296 etype
= TREE_TYPE (etype
);
4298 gfc_trans_vla_type_sizes_1 (etype
, body
);
4301 gfc_trans_vla_type_sizes_1 (type
, body
);
4305 /* Initialize a derived type by building an lvalue from the symbol
4306 and using trans_assignment to do the work. Set dealloc to false
4307 if no deallocation prior the assignment is needed. */
4309 gfc_init_default_dt (gfc_symbol
* sym
, stmtblock_t
* block
, bool dealloc
)
4317 /* Initialization of PDTs is done elsewhere. */
4318 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.pdt_type
)
4321 gcc_assert (!sym
->attr
.allocatable
);
4322 gfc_set_sym_referenced (sym
);
4323 e
= gfc_lval_expr_from_sym (sym
);
4324 tmp
= gfc_trans_assignment (e
, sym
->value
, false, dealloc
);
4325 if (sym
->attr
.dummy
&& (sym
->attr
.optional
4326 || sym
->ns
->proc_name
->attr
.entry_master
))
4328 present
= gfc_conv_expr_present (sym
);
4329 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), present
,
4330 tmp
, build_empty_stmt (input_location
));
4332 gfc_add_expr_to_block (block
, tmp
);
4337 /* Initialize INTENT(OUT) derived type dummies. As well as giving
4338 them their default initializer, if they do not have allocatable
4339 components, they have their allocatable components deallocated. */
4342 init_intent_out_dt (gfc_symbol
* proc_sym
, gfc_wrapped_block
* block
)
4345 gfc_formal_arglist
*f
;
4349 bool dealloc_with_value
= false;
4351 gfc_init_block (&init
);
4352 for (f
= gfc_sym_get_dummy_args (proc_sym
); f
; f
= f
->next
)
4353 if (f
->sym
&& f
->sym
->attr
.intent
== INTENT_OUT
4354 && !f
->sym
->attr
.pointer
4355 && f
->sym
->ts
.type
== BT_DERIVED
)
4360 /* Note: Allocatables are excluded as they are already handled
4362 if (!f
->sym
->attr
.allocatable
4363 && gfc_is_finalizable (s
->ts
.u
.derived
, NULL
))
4368 gfc_init_block (&block
);
4369 s
->attr
.referenced
= 1;
4370 e
= gfc_lval_expr_from_sym (s
);
4371 gfc_add_finalizer_call (&block
, e
);
4373 tmp
= gfc_finish_block (&block
);
4376 /* Note: Allocatables are excluded as they are already handled
4378 if (tmp
== NULL_TREE
&& !s
->attr
.allocatable
4379 && s
->ts
.u
.derived
->attr
.alloc_comp
)
4381 tmp
= gfc_deallocate_alloc_comp (s
->ts
.u
.derived
,
4383 s
->as
? s
->as
->rank
: 0);
4384 dealloc_with_value
= s
->value
;
4387 if (tmp
!= NULL_TREE
&& (s
->attr
.optional
4388 || s
->ns
->proc_name
->attr
.entry_master
))
4390 present
= gfc_conv_expr_present (s
);
4391 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
4392 present
, tmp
, build_empty_stmt (input_location
));
4395 if (tmp
!= NULL_TREE
&& !dealloc_with_value
)
4396 gfc_add_expr_to_block (&init
, tmp
);
4397 else if (s
->value
&& !s
->attr
.allocatable
)
4399 gfc_add_expr_to_block (&init
, tmp
);
4400 gfc_init_default_dt (s
, &init
, false);
4401 dealloc_with_value
= false;
4404 else if (f
->sym
&& f
->sym
->attr
.intent
== INTENT_OUT
4405 && f
->sym
->ts
.type
== BT_CLASS
4406 && !CLASS_DATA (f
->sym
)->attr
.class_pointer
4407 && !CLASS_DATA (f
->sym
)->attr
.allocatable
)
4412 gfc_init_block (&block
);
4413 f
->sym
->attr
.referenced
= 1;
4414 e
= gfc_lval_expr_from_sym (f
->sym
);
4415 gfc_add_finalizer_call (&block
, e
);
4417 tmp
= gfc_finish_block (&block
);
4419 if (f
->sym
->attr
.optional
|| f
->sym
->ns
->proc_name
->attr
.entry_master
)
4421 present
= gfc_conv_expr_present (f
->sym
);
4422 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
4424 build_empty_stmt (input_location
));
4426 gfc_add_expr_to_block (&init
, tmp
);
4428 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
4432 /* Helper function to manage deferred string lengths. */
4435 gfc_null_and_pass_deferred_len (gfc_symbol
*sym
, stmtblock_t
*init
,
4440 /* Character length passed by reference. */
4441 tmp
= sym
->ts
.u
.cl
->passed_length
;
4442 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
4443 tmp
= fold_convert (gfc_charlen_type_node
, tmp
);
4445 if (!sym
->attr
.dummy
|| sym
->attr
.intent
== INTENT_OUT
)
4446 /* Zero the string length when entering the scope. */
4447 gfc_add_modify (init
, sym
->ts
.u
.cl
->backend_decl
,
4448 build_int_cst (gfc_charlen_type_node
, 0));
4453 tmp2
= fold_build2_loc (input_location
, MODIFY_EXPR
,
4454 gfc_charlen_type_node
,
4455 sym
->ts
.u
.cl
->backend_decl
, tmp
);
4456 if (sym
->attr
.optional
)
4458 tree present
= gfc_conv_expr_present (sym
);
4459 tmp2
= build3_loc (input_location
, COND_EXPR
,
4460 void_type_node
, present
, tmp2
,
4461 build_empty_stmt (input_location
));
4463 gfc_add_expr_to_block (init
, tmp2
);
4466 gfc_restore_backend_locus (loc
);
4468 /* Pass the final character length back. */
4469 if (sym
->attr
.intent
!= INTENT_IN
)
4471 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
4472 gfc_charlen_type_node
, tmp
,
4473 sym
->ts
.u
.cl
->backend_decl
);
4474 if (sym
->attr
.optional
)
4476 tree present
= gfc_conv_expr_present (sym
);
4477 tmp
= build3_loc (input_location
, COND_EXPR
,
4478 void_type_node
, present
, tmp
,
4479 build_empty_stmt (input_location
));
4489 /* Get the result expression for a procedure. */
4492 get_proc_result (gfc_symbol
* sym
)
4494 if (sym
->attr
.subroutine
|| sym
== sym
->result
)
4496 if (current_fake_result_decl
!= NULL
)
4497 return TREE_VALUE (current_fake_result_decl
);
4502 return sym
->result
->backend_decl
;
4506 /* Generate function entry and exit code, and add it to the function body.
4508 Allocation and initialization of array variables.
4509 Allocation of character string variables.
4510 Initialization and possibly repacking of dummy arrays.
4511 Initialization of ASSIGN statement auxiliary variable.
4512 Initialization of ASSOCIATE names.
4513 Automatic deallocation. */
4516 gfc_trans_deferred_vars (gfc_symbol
* proc_sym
, gfc_wrapped_block
* block
)
4520 gfc_formal_arglist
*f
;
4521 stmtblock_t tmpblock
;
4522 bool seen_trans_deferred_array
= false;
4523 bool is_pdt_type
= false;
4529 /* Deal with implicit return variables. Explicit return variables will
4530 already have been added. */
4531 if (gfc_return_by_reference (proc_sym
) && proc_sym
->result
== proc_sym
)
4533 if (!current_fake_result_decl
)
4535 gfc_entry_list
*el
= NULL
;
4536 if (proc_sym
->attr
.entry_master
)
4538 for (el
= proc_sym
->ns
->entries
; el
; el
= el
->next
)
4539 if (el
->sym
!= el
->sym
->result
)
4542 /* TODO: move to the appropriate place in resolve.cc. */
4543 if (warn_return_type
> 0 && el
== NULL
)
4544 gfc_warning (OPT_Wreturn_type
,
4545 "Return value of function %qs at %L not set",
4546 proc_sym
->name
, &proc_sym
->declared_at
);
4548 else if (proc_sym
->as
)
4550 tree result
= TREE_VALUE (current_fake_result_decl
);
4551 gfc_save_backend_locus (&loc
);
4552 gfc_set_backend_locus (&proc_sym
->declared_at
);
4553 gfc_trans_dummy_array_bias (proc_sym
, result
, block
);
4555 /* An automatic character length, pointer array result. */
4556 if (proc_sym
->ts
.type
== BT_CHARACTER
4557 && VAR_P (proc_sym
->ts
.u
.cl
->backend_decl
))
4560 if (proc_sym
->ts
.deferred
)
4562 gfc_start_block (&init
);
4563 tmp
= gfc_null_and_pass_deferred_len (proc_sym
, &init
, &loc
);
4564 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), tmp
);
4567 gfc_trans_dummy_character (proc_sym
, proc_sym
->ts
.u
.cl
, block
);
4570 else if (proc_sym
->ts
.type
== BT_CHARACTER
)
4572 if (proc_sym
->ts
.deferred
)
4575 gfc_save_backend_locus (&loc
);
4576 gfc_set_backend_locus (&proc_sym
->declared_at
);
4577 gfc_start_block (&init
);
4578 /* Zero the string length on entry. */
4579 gfc_add_modify (&init
, proc_sym
->ts
.u
.cl
->backend_decl
,
4580 build_int_cst (gfc_charlen_type_node
, 0));
4581 /* Null the pointer. */
4582 e
= gfc_lval_expr_from_sym (proc_sym
);
4583 gfc_init_se (&se
, NULL
);
4584 se
.want_pointer
= 1;
4585 gfc_conv_expr (&se
, e
);
4588 gfc_add_modify (&init
, tmp
,
4589 fold_convert (TREE_TYPE (se
.expr
),
4590 null_pointer_node
));
4591 gfc_restore_backend_locus (&loc
);
4593 /* Pass back the string length on exit. */
4594 tmp
= proc_sym
->ts
.u
.cl
->backend_decl
;
4595 if (TREE_CODE (tmp
) != INDIRECT_REF
4596 && proc_sym
->ts
.u
.cl
->passed_length
)
4598 tmp
= proc_sym
->ts
.u
.cl
->passed_length
;
4599 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
4600 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
4601 TREE_TYPE (tmp
), tmp
,
4604 proc_sym
->ts
.u
.cl
->backend_decl
));
4609 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), tmp
);
4611 else if (VAR_P (proc_sym
->ts
.u
.cl
->backend_decl
))
4612 gfc_trans_dummy_character (proc_sym
, proc_sym
->ts
.u
.cl
, block
);
4615 gcc_assert (flag_f2c
&& proc_sym
->ts
.type
== BT_COMPLEX
);
4617 else if (proc_sym
== proc_sym
->result
&& IS_CLASS_ARRAY (proc_sym
))
4619 /* Nullify explicit return class arrays on entry. */
4621 tmp
= get_proc_result (proc_sym
);
4622 if (tmp
&& GFC_CLASS_TYPE_P (TREE_TYPE (tmp
)))
4624 gfc_start_block (&init
);
4625 tmp
= gfc_class_data_get (tmp
);
4626 type
= TREE_TYPE (gfc_conv_descriptor_data_get (tmp
));
4627 gfc_conv_descriptor_data_set (&init
, tmp
, build_int_cst (type
, 0));
4628 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
4633 /* Initialize the INTENT(OUT) derived type dummy arguments. This
4634 should be done here so that the offsets and lbounds of arrays
4636 gfc_save_backend_locus (&loc
);
4637 gfc_set_backend_locus (&proc_sym
->declared_at
);
4638 init_intent_out_dt (proc_sym
, block
);
4639 gfc_restore_backend_locus (&loc
);
4641 for (sym
= proc_sym
->tlink
; sym
!= proc_sym
; sym
= sym
->tlink
)
4643 bool alloc_comp_or_fini
= (sym
->ts
.type
== BT_DERIVED
)
4644 && (sym
->ts
.u
.derived
->attr
.alloc_comp
4645 || gfc_is_finalizable (sym
->ts
.u
.derived
,
4650 if (sym
->ts
.type
== BT_DERIVED
4651 && sym
->ts
.u
.derived
4652 && sym
->ts
.u
.derived
->attr
.pdt_type
)
4655 gfc_init_block (&tmpblock
);
4656 if (!(sym
->attr
.dummy
4657 || sym
->attr
.pointer
4658 || sym
->attr
.allocatable
))
4660 tmp
= gfc_allocate_pdt_comp (sym
->ts
.u
.derived
,
4662 sym
->as
? sym
->as
->rank
: 0,
4664 gfc_add_expr_to_block (&tmpblock
, tmp
);
4665 if (!sym
->attr
.result
)
4666 tmp
= gfc_deallocate_pdt_comp (sym
->ts
.u
.derived
,
4668 sym
->as
? sym
->as
->rank
: 0);
4671 gfc_add_init_cleanup (block
, gfc_finish_block (&tmpblock
), tmp
);
4673 else if (sym
->attr
.dummy
)
4675 tmp
= gfc_check_pdt_dummy (sym
->ts
.u
.derived
,
4677 sym
->as
? sym
->as
->rank
: 0,
4679 gfc_add_expr_to_block (&tmpblock
, tmp
);
4680 gfc_add_init_cleanup (block
, gfc_finish_block (&tmpblock
), NULL
);
4683 else if (sym
->ts
.type
== BT_CLASS
4684 && CLASS_DATA (sym
)->ts
.u
.derived
4685 && CLASS_DATA (sym
)->ts
.u
.derived
->attr
.pdt_type
)
4687 gfc_component
*data
= CLASS_DATA (sym
);
4689 gfc_init_block (&tmpblock
);
4690 if (!(sym
->attr
.dummy
4691 || CLASS_DATA (sym
)->attr
.pointer
4692 || CLASS_DATA (sym
)->attr
.allocatable
))
4694 tmp
= gfc_class_data_get (sym
->backend_decl
);
4695 tmp
= gfc_allocate_pdt_comp (data
->ts
.u
.derived
, tmp
,
4696 data
->as
? data
->as
->rank
: 0,
4698 gfc_add_expr_to_block (&tmpblock
, tmp
);
4699 tmp
= gfc_class_data_get (sym
->backend_decl
);
4700 if (!sym
->attr
.result
)
4701 tmp
= gfc_deallocate_pdt_comp (data
->ts
.u
.derived
, tmp
,
4702 data
->as
? data
->as
->rank
: 0);
4705 gfc_add_init_cleanup (block
, gfc_finish_block (&tmpblock
), tmp
);
4707 else if (sym
->attr
.dummy
)
4709 tmp
= gfc_class_data_get (sym
->backend_decl
);
4710 tmp
= gfc_check_pdt_dummy (data
->ts
.u
.derived
, tmp
,
4711 data
->as
? data
->as
->rank
: 0,
4713 gfc_add_expr_to_block (&tmpblock
, tmp
);
4714 gfc_add_init_cleanup (block
, gfc_finish_block (&tmpblock
), NULL
);
4718 if (sym
->attr
.pointer
&& sym
->attr
.dimension
4719 && sym
->attr
.save
== SAVE_NONE
4720 && !sym
->attr
.use_assoc
4721 && !sym
->attr
.host_assoc
4723 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym
->backend_decl
)))
4725 gfc_init_block (&tmpblock
);
4726 gfc_conv_descriptor_span_set (&tmpblock
, sym
->backend_decl
,
4727 build_int_cst (gfc_array_index_type
, 0));
4728 gfc_add_init_cleanup (block
, gfc_finish_block (&tmpblock
),
4732 if (sym
->ts
.type
== BT_CLASS
4733 && (sym
->attr
.save
|| flag_max_stack_var_size
== 0)
4734 && CLASS_DATA (sym
)->attr
.allocatable
)
4738 if (UNLIMITED_POLY (sym
))
4739 vptr
= null_pointer_node
;
4743 vsym
= gfc_find_derived_vtab (sym
->ts
.u
.derived
);
4744 vptr
= gfc_get_symbol_decl (vsym
);
4745 vptr
= gfc_build_addr_expr (NULL
, vptr
);
4748 if (CLASS_DATA (sym
)->attr
.dimension
4749 || (CLASS_DATA (sym
)->attr
.codimension
4750 && flag_coarray
!= GFC_FCOARRAY_LIB
))
4752 tmp
= gfc_class_data_get (sym
->backend_decl
);
4753 tmp
= gfc_build_null_descriptor (TREE_TYPE (tmp
));
4756 tmp
= null_pointer_node
;
4758 DECL_INITIAL (sym
->backend_decl
)
4759 = gfc_class_set_static_fields (sym
->backend_decl
, vptr
, tmp
);
4760 TREE_CONSTANT (DECL_INITIAL (sym
->backend_decl
)) = 1;
4762 else if ((sym
->attr
.dimension
|| sym
->attr
.codimension
4763 || (IS_CLASS_ARRAY (sym
) && !CLASS_DATA (sym
)->attr
.allocatable
)))
4765 bool is_classarray
= IS_CLASS_ARRAY (sym
);
4766 symbol_attribute
*array_attr
;
4768 array_type type_of_array
;
4770 array_attr
= is_classarray
? &CLASS_DATA (sym
)->attr
: &sym
->attr
;
4771 as
= is_classarray
? CLASS_DATA (sym
)->as
: sym
->as
;
4772 /* Assumed-size Cray pointees need to be treated as AS_EXPLICIT. */
4773 type_of_array
= as
->type
;
4774 if (type_of_array
== AS_ASSUMED_SIZE
&& as
->cp_was_assumed
)
4775 type_of_array
= AS_EXPLICIT
;
4776 switch (type_of_array
)
4779 if (sym
->attr
.dummy
|| sym
->attr
.result
)
4780 gfc_trans_dummy_array_bias (sym
, sym
->backend_decl
, block
);
4781 /* Allocatable and pointer arrays need to processed
4783 else if ((sym
->ts
.type
!= BT_CLASS
&& sym
->attr
.pointer
)
4784 || (sym
->ts
.type
== BT_CLASS
4785 && CLASS_DATA (sym
)->attr
.class_pointer
)
4786 || array_attr
->allocatable
)
4788 if (TREE_STATIC (sym
->backend_decl
))
4790 gfc_save_backend_locus (&loc
);
4791 gfc_set_backend_locus (&sym
->declared_at
);
4792 gfc_trans_static_array_pointer (sym
);
4793 gfc_restore_backend_locus (&loc
);
4797 seen_trans_deferred_array
= true;
4798 gfc_trans_deferred_array (sym
, block
);
4801 else if (sym
->attr
.codimension
4802 && TREE_STATIC (sym
->backend_decl
))
4804 gfc_init_block (&tmpblock
);
4805 gfc_trans_array_cobounds (TREE_TYPE (sym
->backend_decl
),
4807 gfc_add_init_cleanup (block
, gfc_finish_block (&tmpblock
),
4813 gfc_save_backend_locus (&loc
);
4814 gfc_set_backend_locus (&sym
->declared_at
);
4816 if (alloc_comp_or_fini
)
4818 seen_trans_deferred_array
= true;
4819 gfc_trans_deferred_array (sym
, block
);
4821 else if (sym
->ts
.type
== BT_DERIVED
4824 && sym
->attr
.save
== SAVE_NONE
)
4826 gfc_start_block (&tmpblock
);
4827 gfc_init_default_dt (sym
, &tmpblock
, false);
4828 gfc_add_init_cleanup (block
,
4829 gfc_finish_block (&tmpblock
),
4833 gfc_trans_auto_array_allocation (sym
->backend_decl
,
4835 gfc_restore_backend_locus (&loc
);
4839 case AS_ASSUMED_SIZE
:
4840 /* Must be a dummy parameter. */
4841 gcc_assert (sym
->attr
.dummy
|| as
->cp_was_assumed
);
4843 /* We should always pass assumed size arrays the g77 way. */
4844 if (sym
->attr
.dummy
)
4845 gfc_trans_g77_array (sym
, block
);
4848 case AS_ASSUMED_SHAPE
:
4849 /* Must be a dummy parameter. */
4850 gcc_assert (sym
->attr
.dummy
);
4852 gfc_trans_dummy_array_bias (sym
, sym
->backend_decl
, block
);
4855 case AS_ASSUMED_RANK
:
4857 seen_trans_deferred_array
= true;
4858 gfc_trans_deferred_array (sym
, block
);
4859 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.deferred
4860 && sym
->attr
.result
)
4862 gfc_start_block (&init
);
4863 gfc_save_backend_locus (&loc
);
4864 gfc_set_backend_locus (&sym
->declared_at
);
4865 tmp
= gfc_null_and_pass_deferred_len (sym
, &init
, &loc
);
4866 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), tmp
);
4873 if (alloc_comp_or_fini
&& !seen_trans_deferred_array
)
4874 gfc_trans_deferred_array (sym
, block
);
4876 else if ((!sym
->attr
.dummy
|| sym
->ts
.deferred
)
4877 && (sym
->ts
.type
== BT_CLASS
4878 && CLASS_DATA (sym
)->attr
.class_pointer
))
4879 gfc_trans_class_array (sym
, block
);
4880 else if ((!sym
->attr
.dummy
|| sym
->ts
.deferred
)
4881 && (sym
->attr
.allocatable
4882 || (sym
->attr
.pointer
&& sym
->attr
.result
)
4883 || (sym
->ts
.type
== BT_CLASS
4884 && CLASS_DATA (sym
)->attr
.allocatable
)))
4886 if (!sym
->attr
.save
&& flag_max_stack_var_size
!= 0)
4888 tree descriptor
= NULL_TREE
;
4890 gfc_save_backend_locus (&loc
);
4891 gfc_set_backend_locus (&sym
->declared_at
);
4892 gfc_start_block (&init
);
4894 if (sym
->ts
.type
== BT_CHARACTER
4895 && sym
->attr
.allocatable
4896 && !sym
->attr
.dimension
4897 && sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
4898 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_VARIABLE
)
4899 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
4901 if (!sym
->attr
.pointer
)
4903 /* Nullify and automatic deallocation of allocatable
4905 e
= gfc_lval_expr_from_sym (sym
);
4906 if (sym
->ts
.type
== BT_CLASS
)
4907 gfc_add_data_component (e
);
4909 gfc_init_se (&se
, NULL
);
4910 if (sym
->ts
.type
!= BT_CLASS
4911 || sym
->ts
.u
.derived
->attr
.dimension
4912 || sym
->ts
.u
.derived
->attr
.codimension
)
4914 se
.want_pointer
= 1;
4915 gfc_conv_expr (&se
, e
);
4917 else if (sym
->ts
.type
== BT_CLASS
4918 && !CLASS_DATA (sym
)->attr
.dimension
4919 && !CLASS_DATA (sym
)->attr
.codimension
)
4921 se
.want_pointer
= 1;
4922 gfc_conv_expr (&se
, e
);
4926 se
.descriptor_only
= 1;
4927 gfc_conv_expr (&se
, e
);
4928 descriptor
= se
.expr
;
4929 se
.expr
= gfc_conv_descriptor_data_addr (se
.expr
);
4930 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
4934 if (!sym
->attr
.dummy
|| sym
->attr
.intent
== INTENT_OUT
)
4936 /* Nullify when entering the scope. */
4937 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
4938 TREE_TYPE (se
.expr
), se
.expr
,
4939 fold_convert (TREE_TYPE (se
.expr
),
4940 null_pointer_node
));
4941 if (sym
->attr
.optional
)
4943 tree present
= gfc_conv_expr_present (sym
);
4944 tmp
= build3_loc (input_location
, COND_EXPR
,
4945 void_type_node
, present
, tmp
,
4946 build_empty_stmt (input_location
));
4948 gfc_add_expr_to_block (&init
, tmp
);
4952 if ((sym
->attr
.dummy
|| sym
->attr
.result
)
4953 && sym
->ts
.type
== BT_CHARACTER
4955 && sym
->ts
.u
.cl
->passed_length
)
4956 tmp
= gfc_null_and_pass_deferred_len (sym
, &init
, &loc
);
4959 gfc_restore_backend_locus (&loc
);
4963 /* Initialize descriptor's TKR information. */
4964 if (sym
->ts
.type
== BT_CLASS
)
4965 gfc_trans_class_array (sym
, block
);
4967 /* Deallocate when leaving the scope. Nullifying is not
4969 if (!sym
->attr
.result
&& !sym
->attr
.dummy
&& !sym
->attr
.pointer
4970 && !sym
->ns
->proc_name
->attr
.is_main_program
)
4972 if (sym
->ts
.type
== BT_CLASS
4973 && CLASS_DATA (sym
)->attr
.codimension
)
4974 tmp
= gfc_deallocate_with_status (descriptor
, NULL_TREE
,
4975 NULL_TREE
, NULL_TREE
,
4976 NULL_TREE
, true, NULL
,
4977 GFC_CAF_COARRAY_ANALYZE
);
4980 gfc_expr
*expr
= gfc_lval_expr_from_sym (sym
);
4981 tmp
= gfc_deallocate_scalar_with_status (se
.expr
,
4986 gfc_free_expr (expr
);
4990 if (sym
->ts
.type
== BT_CLASS
)
4992 /* Initialize _vptr to declared type. */
4996 gfc_save_backend_locus (&loc
);
4997 gfc_set_backend_locus (&sym
->declared_at
);
4998 e
= gfc_lval_expr_from_sym (sym
);
4999 gfc_add_vptr_component (e
);
5000 gfc_init_se (&se
, NULL
);
5001 se
.want_pointer
= 1;
5002 gfc_conv_expr (&se
, e
);
5004 if (UNLIMITED_POLY (sym
))
5005 rhs
= build_int_cst (TREE_TYPE (se
.expr
), 0);
5008 vtab
= gfc_find_derived_vtab (sym
->ts
.u
.derived
);
5009 rhs
= gfc_build_addr_expr (TREE_TYPE (se
.expr
),
5010 gfc_get_symbol_decl (vtab
));
5012 gfc_add_modify (&init
, se
.expr
, rhs
);
5013 gfc_restore_backend_locus (&loc
);
5016 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), tmp
);
5019 else if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.deferred
)
5024 /* If we get to here, all that should be left are pointers. */
5025 gcc_assert (sym
->attr
.pointer
);
5027 if (sym
->attr
.dummy
)
5029 gfc_start_block (&init
);
5030 gfc_save_backend_locus (&loc
);
5031 gfc_set_backend_locus (&sym
->declared_at
);
5032 tmp
= gfc_null_and_pass_deferred_len (sym
, &init
, &loc
);
5033 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), tmp
);
5036 else if (sym
->ts
.deferred
)
5037 gfc_fatal_error ("Deferred type parameter not yet supported");
5038 else if (alloc_comp_or_fini
)
5039 gfc_trans_deferred_array (sym
, block
);
5040 else if (sym
->ts
.type
== BT_CHARACTER
)
5042 gfc_save_backend_locus (&loc
);
5043 gfc_set_backend_locus (&sym
->declared_at
);
5044 if (sym
->attr
.dummy
|| sym
->attr
.result
)
5045 gfc_trans_dummy_character (sym
, sym
->ts
.u
.cl
, block
);
5047 gfc_trans_auto_character_variable (sym
, block
);
5048 gfc_restore_backend_locus (&loc
);
5050 else if (sym
->attr
.assign
)
5052 gfc_save_backend_locus (&loc
);
5053 gfc_set_backend_locus (&sym
->declared_at
);
5054 gfc_trans_assign_aux_var (sym
, block
);
5055 gfc_restore_backend_locus (&loc
);
5057 else if (sym
->ts
.type
== BT_DERIVED
5060 && sym
->attr
.save
== SAVE_NONE
)
5062 gfc_start_block (&tmpblock
);
5063 gfc_init_default_dt (sym
, &tmpblock
, false);
5064 gfc_add_init_cleanup (block
, gfc_finish_block (&tmpblock
),
5067 else if (!(UNLIMITED_POLY(sym
)) && !is_pdt_type
)
5071 gfc_init_block (&tmpblock
);
5073 for (f
= gfc_sym_get_dummy_args (proc_sym
); f
; f
= f
->next
)
5075 if (f
->sym
&& f
->sym
->tlink
== NULL
&& f
->sym
->ts
.type
== BT_CHARACTER
5076 && f
->sym
->ts
.u
.cl
->backend_decl
)
5078 if (TREE_CODE (f
->sym
->ts
.u
.cl
->backend_decl
) == PARM_DECL
)
5079 gfc_trans_vla_type_sizes (f
->sym
, &tmpblock
);
5083 if (gfc_return_by_reference (proc_sym
) && proc_sym
->ts
.type
== BT_CHARACTER
5084 && current_fake_result_decl
!= NULL
)
5086 gcc_assert (proc_sym
->ts
.u
.cl
->backend_decl
!= NULL
);
5087 if (TREE_CODE (proc_sym
->ts
.u
.cl
->backend_decl
) == PARM_DECL
)
5088 gfc_trans_vla_type_sizes (proc_sym
, &tmpblock
);
5091 gfc_add_init_cleanup (block
, gfc_finish_block (&tmpblock
), NULL_TREE
);
5095 struct module_hasher
: ggc_ptr_hash
<module_htab_entry
>
5097 typedef const char *compare_type
;
5099 static hashval_t
hash (module_htab_entry
*s
)
5101 return htab_hash_string (s
->name
);
5105 equal (module_htab_entry
*a
, const char *b
)
5107 return !strcmp (a
->name
, b
);
5111 static GTY (()) hash_table
<module_hasher
> *module_htab
;
5113 /* Hash and equality functions for module_htab's decls. */
5116 module_decl_hasher::hash (tree t
)
5118 const_tree n
= DECL_NAME (t
);
5120 n
= TYPE_NAME (TREE_TYPE (t
));
5121 return htab_hash_string (IDENTIFIER_POINTER (n
));
5125 module_decl_hasher::equal (tree t1
, const char *x2
)
5127 const_tree n1
= DECL_NAME (t1
);
5128 if (n1
== NULL_TREE
)
5129 n1
= TYPE_NAME (TREE_TYPE (t1
));
5130 return strcmp (IDENTIFIER_POINTER (n1
), x2
) == 0;
5133 struct module_htab_entry
*
5134 gfc_find_module (const char *name
)
5137 module_htab
= hash_table
<module_hasher
>::create_ggc (10);
5139 module_htab_entry
**slot
5140 = module_htab
->find_slot_with_hash (name
, htab_hash_string (name
), INSERT
);
5143 module_htab_entry
*entry
= ggc_cleared_alloc
<module_htab_entry
> ();
5145 entry
->name
= gfc_get_string ("%s", name
);
5146 entry
->decls
= hash_table
<module_decl_hasher
>::create_ggc (10);
5153 gfc_module_add_decl (struct module_htab_entry
*entry
, tree decl
)
5157 if (DECL_NAME (decl
))
5158 name
= IDENTIFIER_POINTER (DECL_NAME (decl
));
5161 gcc_assert (TREE_CODE (decl
) == TYPE_DECL
);
5162 name
= IDENTIFIER_POINTER (TYPE_NAME (TREE_TYPE (decl
)));
5165 = entry
->decls
->find_slot_with_hash (name
, htab_hash_string (name
),
5172 /* Generate debugging symbols for namelists. This function must come after
5173 generate_local_decl to ensure that the variables in the namelist are
5174 already declared. */
5177 generate_namelist_decl (gfc_symbol
* sym
)
5181 vec
<constructor_elt
, va_gc
> *nml_decls
= NULL
;
5183 gcc_assert (sym
->attr
.flavor
== FL_NAMELIST
);
5184 for (nml
= sym
->namelist
; nml
; nml
= nml
->next
)
5186 if (nml
->sym
->backend_decl
== NULL_TREE
)
5188 nml
->sym
->attr
.referenced
= 1;
5189 nml
->sym
->backend_decl
= gfc_get_symbol_decl (nml
->sym
);
5191 DECL_IGNORED_P (nml
->sym
->backend_decl
) = 0;
5192 CONSTRUCTOR_APPEND_ELT (nml_decls
, NULL_TREE
, nml
->sym
->backend_decl
);
5195 decl
= make_node (NAMELIST_DECL
);
5196 TREE_TYPE (decl
) = void_type_node
;
5197 NAMELIST_DECL_ASSOCIATED_DECL (decl
) = build_constructor (NULL_TREE
, nml_decls
);
5198 DECL_NAME (decl
) = get_identifier (sym
->name
);
5203 /* Output an initialized decl for a module variable. */
5206 gfc_create_module_variable (gfc_symbol
* sym
)
5210 /* Module functions with alternate entries are dealt with later and
5211 would get caught by the next condition. */
5212 if (sym
->attr
.entry
)
5215 /* Make sure we convert the types of the derived types from iso_c_binding
5217 if (sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.is_iso_c
5218 && sym
->ts
.type
== BT_DERIVED
)
5219 sym
->backend_decl
= gfc_typenode_for_spec (&(sym
->ts
));
5221 if (gfc_fl_struct (sym
->attr
.flavor
)
5222 && sym
->backend_decl
5223 && TREE_CODE (sym
->backend_decl
) == RECORD_TYPE
)
5225 decl
= sym
->backend_decl
;
5226 gcc_assert (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
);
5228 if (!sym
->attr
.use_assoc
&& !sym
->attr
.used_in_submodule
)
5230 gcc_assert (TYPE_CONTEXT (decl
) == NULL_TREE
5231 || TYPE_CONTEXT (decl
) == sym
->ns
->proc_name
->backend_decl
);
5232 gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl
)) == NULL_TREE
5233 || DECL_CONTEXT (TYPE_STUB_DECL (decl
))
5234 == sym
->ns
->proc_name
->backend_decl
);
5236 TYPE_CONTEXT (decl
) = sym
->ns
->proc_name
->backend_decl
;
5237 DECL_CONTEXT (TYPE_STUB_DECL (decl
)) = sym
->ns
->proc_name
->backend_decl
;
5238 gfc_module_add_decl (cur_module
, TYPE_STUB_DECL (decl
));
5241 /* Only output variables, procedure pointers and array valued,
5242 or derived type, parameters. */
5243 if (sym
->attr
.flavor
!= FL_VARIABLE
5244 && !(sym
->attr
.flavor
== FL_PARAMETER
5245 && (sym
->attr
.dimension
|| sym
->ts
.type
== BT_DERIVED
))
5246 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc_pointer
))
5249 if ((sym
->attr
.in_common
|| sym
->attr
.in_equivalence
) && sym
->backend_decl
)
5251 decl
= sym
->backend_decl
;
5252 gcc_assert (DECL_FILE_SCOPE_P (decl
));
5253 gcc_assert (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
);
5254 DECL_CONTEXT (decl
) = sym
->ns
->proc_name
->backend_decl
;
5255 gfc_module_add_decl (cur_module
, decl
);
5258 /* Don't generate variables from other modules. Variables from
5259 COMMONs and Cray pointees will already have been generated. */
5260 if (sym
->attr
.use_assoc
|| sym
->attr
.used_in_submodule
5261 || sym
->attr
.in_common
|| sym
->attr
.cray_pointee
)
5264 /* Equivalenced variables arrive here after creation. */
5265 if (sym
->backend_decl
5266 && (sym
->equiv_built
|| sym
->attr
.in_equivalence
))
5269 if (sym
->backend_decl
&& !sym
->attr
.vtab
&& !sym
->attr
.target
)
5270 gfc_internal_error ("backend decl for module variable %qs already exists",
5273 if (sym
->module
&& !sym
->attr
.result
&& !sym
->attr
.dummy
5274 && (sym
->attr
.access
== ACCESS_UNKNOWN
5275 && (sym
->ns
->default_access
== ACCESS_PRIVATE
5276 || (sym
->ns
->default_access
== ACCESS_UNKNOWN
5277 && flag_module_private
))))
5278 sym
->attr
.access
= ACCESS_PRIVATE
;
5280 if (warn_unused_variable
&& !sym
->attr
.referenced
5281 && sym
->attr
.access
== ACCESS_PRIVATE
)
5282 gfc_warning (OPT_Wunused_value
,
5283 "Unused PRIVATE module variable %qs declared at %L",
5284 sym
->name
, &sym
->declared_at
);
5286 /* We always want module variables to be created. */
5287 sym
->attr
.referenced
= 1;
5288 /* Create the decl. */
5289 decl
= gfc_get_symbol_decl (sym
);
5291 /* Create the variable. */
5293 gcc_assert (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
5294 || (sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
5295 && sym
->fn_result_spec
));
5296 DECL_CONTEXT (decl
) = sym
->ns
->proc_name
->backend_decl
;
5297 rest_of_decl_compilation (decl
, 1, 0);
5298 gfc_module_add_decl (cur_module
, decl
);
5300 /* Also add length of strings. */
5301 if (sym
->ts
.type
== BT_CHARACTER
)
5305 length
= sym
->ts
.u
.cl
->backend_decl
;
5306 gcc_assert (length
|| sym
->attr
.proc_pointer
);
5307 if (length
&& !INTEGER_CST_P (length
))
5310 rest_of_decl_compilation (length
, 1, 0);
5314 if (sym
->attr
.codimension
&& !sym
->attr
.dummy
&& !sym
->attr
.allocatable
5315 && sym
->attr
.referenced
&& !sym
->attr
.use_assoc
)
5316 has_coarray_vars
= true;
5319 /* Emit debug information for USE statements. */
5322 gfc_trans_use_stmts (gfc_namespace
* ns
)
5324 gfc_use_list
*use_stmt
;
5325 for (use_stmt
= ns
->use_stmts
; use_stmt
; use_stmt
= use_stmt
->next
)
5327 struct module_htab_entry
*entry
5328 = gfc_find_module (use_stmt
->module_name
);
5329 gfc_use_rename
*rent
;
5331 if (entry
->namespace_decl
== NULL
)
5333 entry
->namespace_decl
5334 = build_decl (input_location
,
5336 get_identifier (use_stmt
->module_name
),
5338 DECL_EXTERNAL (entry
->namespace_decl
) = 1;
5340 gfc_set_backend_locus (&use_stmt
->where
);
5341 if (!use_stmt
->only_flag
)
5342 (*debug_hooks
->imported_module_or_decl
) (entry
->namespace_decl
,
5344 ns
->proc_name
->backend_decl
,
5346 for (rent
= use_stmt
->rename
; rent
; rent
= rent
->next
)
5348 tree decl
, local_name
;
5350 if (rent
->op
!= INTRINSIC_NONE
)
5353 hashval_t hash
= htab_hash_string (rent
->use_name
);
5354 tree
*slot
= entry
->decls
->find_slot_with_hash (rent
->use_name
, hash
,
5360 st
= gfc_find_symtree (ns
->sym_root
,
5362 ? rent
->local_name
: rent
->use_name
);
5364 /* The following can happen if a derived type is renamed. */
5368 name
= xstrdup (rent
->local_name
[0]
5369 ? rent
->local_name
: rent
->use_name
);
5370 name
[0] = (char) TOUPPER ((unsigned char) name
[0]);
5371 st
= gfc_find_symtree (ns
->sym_root
, name
);
5376 /* Sometimes, generic interfaces wind up being over-ruled by a
5377 local symbol (see PR41062). */
5378 if (!st
->n
.sym
->attr
.use_assoc
)
5380 *slot
= error_mark_node
;
5381 entry
->decls
->clear_slot (slot
);
5385 if (st
->n
.sym
->backend_decl
5386 && DECL_P (st
->n
.sym
->backend_decl
)
5387 && st
->n
.sym
->module
5388 && strcmp (st
->n
.sym
->module
, use_stmt
->module_name
) == 0)
5390 gcc_assert (DECL_EXTERNAL (entry
->namespace_decl
)
5391 || !VAR_P (st
->n
.sym
->backend_decl
));
5392 decl
= copy_node (st
->n
.sym
->backend_decl
);
5393 DECL_CONTEXT (decl
) = entry
->namespace_decl
;
5394 DECL_EXTERNAL (decl
) = 1;
5395 DECL_IGNORED_P (decl
) = 0;
5396 DECL_INITIAL (decl
) = NULL_TREE
;
5398 else if (st
->n
.sym
->attr
.flavor
== FL_NAMELIST
5399 && st
->n
.sym
->attr
.use_only
5400 && st
->n
.sym
->module
5401 && strcmp (st
->n
.sym
->module
, use_stmt
->module_name
)
5404 decl
= generate_namelist_decl (st
->n
.sym
);
5405 DECL_CONTEXT (decl
) = entry
->namespace_decl
;
5406 DECL_EXTERNAL (decl
) = 1;
5407 DECL_IGNORED_P (decl
) = 0;
5408 DECL_INITIAL (decl
) = NULL_TREE
;
5412 *slot
= error_mark_node
;
5413 entry
->decls
->clear_slot (slot
);
5418 decl
= (tree
) *slot
;
5419 if (rent
->local_name
[0])
5420 local_name
= get_identifier (rent
->local_name
);
5422 local_name
= NULL_TREE
;
5423 gfc_set_backend_locus (&rent
->where
);
5424 (*debug_hooks
->imported_module_or_decl
) (decl
, local_name
,
5425 ns
->proc_name
->backend_decl
,
5426 !use_stmt
->only_flag
,
5433 /* Return true if expr is a constant initializer that gfc_conv_initializer
5437 check_constant_initializer (gfc_expr
*expr
, gfc_typespec
*ts
, bool array
,
5447 if (expr
->expr_type
== EXPR_CONSTANT
|| expr
->expr_type
== EXPR_NULL
)
5449 else if (expr
->expr_type
== EXPR_STRUCTURE
)
5450 return check_constant_initializer (expr
, ts
, false, false);
5451 else if (expr
->expr_type
!= EXPR_ARRAY
)
5453 for (c
= gfc_constructor_first (expr
->value
.constructor
);
5454 c
; c
= gfc_constructor_next (c
))
5458 if (c
->expr
->expr_type
== EXPR_STRUCTURE
)
5460 if (!check_constant_initializer (c
->expr
, ts
, false, false))
5463 else if (c
->expr
->expr_type
!= EXPR_CONSTANT
)
5468 else switch (ts
->type
)
5471 if (expr
->expr_type
!= EXPR_STRUCTURE
)
5473 cm
= expr
->ts
.u
.derived
->components
;
5474 for (c
= gfc_constructor_first (expr
->value
.constructor
);
5475 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
5477 if (!c
->expr
|| cm
->attr
.allocatable
)
5479 if (!check_constant_initializer (c
->expr
, &cm
->ts
,
5486 return expr
->expr_type
== EXPR_CONSTANT
;
5490 /* Emit debug info for parameters and unreferenced variables with
5494 gfc_emit_parameter_debug_info (gfc_symbol
*sym
)
5498 if (sym
->attr
.flavor
!= FL_PARAMETER
5499 && (sym
->attr
.flavor
!= FL_VARIABLE
|| sym
->attr
.referenced
))
5502 if (sym
->backend_decl
!= NULL
5503 || sym
->value
== NULL
5504 || sym
->attr
.use_assoc
5507 || sym
->attr
.function
5508 || sym
->attr
.intrinsic
5509 || sym
->attr
.pointer
5510 || sym
->attr
.allocatable
5511 || sym
->attr
.cray_pointee
5512 || sym
->attr
.threadprivate
5513 || sym
->attr
.is_bind_c
5514 || sym
->attr
.subref_array_pointer
5515 || sym
->attr
.assign
)
5518 if (sym
->ts
.type
== BT_CHARACTER
)
5520 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
5521 if (sym
->ts
.u
.cl
->backend_decl
== NULL
5522 || TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) != INTEGER_CST
)
5525 else if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.alloc_comp
)
5532 if (sym
->as
->type
!= AS_EXPLICIT
)
5534 for (n
= 0; n
< sym
->as
->rank
; n
++)
5535 if (sym
->as
->lower
[n
]->expr_type
!= EXPR_CONSTANT
5536 || sym
->as
->upper
[n
] == NULL
5537 || sym
->as
->upper
[n
]->expr_type
!= EXPR_CONSTANT
)
5541 if (!check_constant_initializer (sym
->value
, &sym
->ts
,
5542 sym
->attr
.dimension
, false))
5545 if (flag_coarray
== GFC_FCOARRAY_LIB
&& sym
->attr
.codimension
)
5548 /* Create the decl for the variable or constant. */
5549 decl
= build_decl (input_location
,
5550 sym
->attr
.flavor
== FL_PARAMETER
? CONST_DECL
: VAR_DECL
,
5551 gfc_sym_identifier (sym
), gfc_sym_type (sym
));
5552 if (sym
->attr
.flavor
== FL_PARAMETER
)
5553 TREE_READONLY (decl
) = 1;
5554 gfc_set_decl_location (decl
, &sym
->declared_at
);
5555 if (sym
->attr
.dimension
)
5556 GFC_DECL_PACKED_ARRAY (decl
) = 1;
5557 DECL_CONTEXT (decl
) = sym
->ns
->proc_name
->backend_decl
;
5558 TREE_STATIC (decl
) = 1;
5559 TREE_USED (decl
) = 1;
5560 if (DECL_CONTEXT (decl
) && TREE_CODE (DECL_CONTEXT (decl
)) == NAMESPACE_DECL
)
5561 TREE_PUBLIC (decl
) = 1;
5562 DECL_INITIAL (decl
) = gfc_conv_initializer (sym
->value
, &sym
->ts
,
5564 sym
->attr
.dimension
,
5566 debug_hooks
->early_global_decl (decl
);
5571 generate_coarray_sym_init (gfc_symbol
*sym
)
5573 tree tmp
, size
, decl
, token
, desc
;
5574 bool is_lock_type
, is_event_type
;
5577 symbol_attribute attr
;
5579 if (sym
->attr
.dummy
|| sym
->attr
.allocatable
|| !sym
->attr
.codimension
5580 || sym
->attr
.use_assoc
|| !sym
->attr
.referenced
5581 || sym
->attr
.associate_var
5582 || sym
->attr
.select_type_temporary
)
5585 decl
= sym
->backend_decl
;
5586 TREE_USED(decl
) = 1;
5587 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
5589 is_lock_type
= sym
->ts
.type
== BT_DERIVED
5590 && sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
5591 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
;
5593 is_event_type
= sym
->ts
.type
== BT_DERIVED
5594 && sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
5595 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
;
5597 /* FIXME: Workaround for PR middle-end/49106, cf. also PR middle-end/49108
5598 to make sure the variable is not optimized away. */
5599 DECL_PRESERVE_P (DECL_CONTEXT (decl
)) = 1;
5601 /* For lock types, we pass the array size as only the library knows the
5602 size of the variable. */
5603 if (is_lock_type
|| is_event_type
)
5604 size
= gfc_index_one_node
;
5606 size
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (decl
)));
5608 /* Ensure that we do not have size=0 for zero-sized arrays. */
5609 size
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
5610 fold_convert (size_type_node
, size
),
5611 build_int_cst (size_type_node
, 1));
5613 if (GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl
)))
5615 tmp
= GFC_TYPE_ARRAY_SIZE (TREE_TYPE (decl
));
5616 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5617 fold_convert (size_type_node
, tmp
), size
);
5620 gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (decl
)) != NULL_TREE
);
5621 token
= gfc_build_addr_expr (ppvoid_type_node
,
5622 GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE(decl
)));
5624 reg_type
= sym
->attr
.artificial
? GFC_CAF_CRITICAL
: GFC_CAF_LOCK_STATIC
;
5625 else if (is_event_type
)
5626 reg_type
= GFC_CAF_EVENT_STATIC
;
5628 reg_type
= GFC_CAF_COARRAY_STATIC
;
5630 /* Compile the symbol attribute. */
5631 if (sym
->ts
.type
== BT_CLASS
)
5633 attr
= CLASS_DATA (sym
)->attr
;
5634 /* The pointer attribute is always set on classes, overwrite it with the
5635 class_pointer attribute, which denotes the pointer for classes. */
5636 attr
.pointer
= attr
.class_pointer
;
5640 gfc_init_se (&se
, NULL
);
5641 desc
= gfc_conv_scalar_to_descriptor (&se
, decl
, attr
);
5642 gfc_add_block_to_block (&caf_init_block
, &se
.pre
);
5644 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_register
, 7, size
,
5645 build_int_cst (integer_type_node
, reg_type
),
5646 token
, gfc_build_addr_expr (pvoid_type_node
, desc
),
5647 null_pointer_node
, /* stat. */
5648 null_pointer_node
, /* errgmsg. */
5649 build_zero_cst (size_type_node
)); /* errmsg_len. */
5650 gfc_add_expr_to_block (&caf_init_block
, tmp
);
5651 gfc_add_modify (&caf_init_block
, decl
, fold_convert (TREE_TYPE (decl
),
5652 gfc_conv_descriptor_data_get (desc
)));
5654 /* Handle "static" initializer. */
5657 if (sym
->value
->expr_type
== EXPR_ARRAY
)
5659 gfc_constructor
*c
, *cnext
;
5661 /* Test if the array has more than one element. */
5662 c
= gfc_constructor_first (sym
->value
->value
.constructor
);
5663 gcc_assert (c
); /* Empty constructor should not happen here. */
5664 cnext
= gfc_constructor_next (c
);
5668 /* An EXPR_ARRAY with a rank > 1 here has to come from a
5669 DATA statement. Set its rank here as not to confuse
5670 the following steps. */
5671 sym
->value
->rank
= 1;
5675 /* There is only a single value in the constructor, use
5676 it directly for the assignment. */
5678 new_expr
= gfc_copy_expr (c
->expr
);
5679 gfc_free_expr (sym
->value
);
5680 sym
->value
= new_expr
;
5684 sym
->attr
.pointer
= 1;
5685 tmp
= gfc_trans_assignment (gfc_lval_expr_from_sym (sym
), sym
->value
,
5687 sym
->attr
.pointer
= 0;
5688 gfc_add_expr_to_block (&caf_init_block
, tmp
);
5690 else if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.pointer_comp
)
5692 tmp
= gfc_nullify_alloc_comp (sym
->ts
.u
.derived
, decl
, sym
->as
5693 ? sym
->as
->rank
: 0,
5694 GFC_STRUCTURE_CAF_MODE_IN_COARRAY
);
5695 gfc_add_expr_to_block (&caf_init_block
, tmp
);
5700 /* Generate constructor function to initialize static, nonallocatable
5704 generate_coarray_init (gfc_namespace
* ns
__attribute((unused
)))
5706 tree fndecl
, tmp
, decl
, save_fn_decl
;
5708 save_fn_decl
= current_function_decl
;
5709 push_function_context ();
5711 tmp
= build_function_type_list (void_type_node
, NULL_TREE
);
5712 fndecl
= build_decl (input_location
, FUNCTION_DECL
,
5713 create_tmp_var_name ("_caf_init"), tmp
);
5715 DECL_STATIC_CONSTRUCTOR (fndecl
) = 1;
5716 SET_DECL_INIT_PRIORITY (fndecl
, DEFAULT_INIT_PRIORITY
);
5718 decl
= build_decl (input_location
, RESULT_DECL
, NULL_TREE
, void_type_node
);
5719 DECL_ARTIFICIAL (decl
) = 1;
5720 DECL_IGNORED_P (decl
) = 1;
5721 DECL_CONTEXT (decl
) = fndecl
;
5722 DECL_RESULT (fndecl
) = decl
;
5725 current_function_decl
= fndecl
;
5726 announce_function (fndecl
);
5728 rest_of_decl_compilation (fndecl
, 0, 0);
5729 make_decl_rtl (fndecl
);
5730 allocate_struct_function (fndecl
, false);
5733 gfc_init_block (&caf_init_block
);
5735 gfc_traverse_ns (ns
, generate_coarray_sym_init
);
5737 DECL_SAVED_TREE (fndecl
) = gfc_finish_block (&caf_init_block
);
5741 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl
)) = fndecl
;
5743 DECL_SAVED_TREE (fndecl
)
5744 = fold_build3_loc (DECL_SOURCE_LOCATION (fndecl
), BIND_EXPR
, void_type_node
,
5745 decl
, DECL_SAVED_TREE (fndecl
), DECL_INITIAL (fndecl
));
5746 dump_function (TDI_original
, fndecl
);
5748 cfun
->function_end_locus
= input_location
;
5751 if (decl_function_context (fndecl
))
5752 (void) cgraph_node::create (fndecl
);
5754 cgraph_node::finalize_function (fndecl
, true);
5756 pop_function_context ();
5757 current_function_decl
= save_fn_decl
;
5762 create_module_nml_decl (gfc_symbol
*sym
)
5764 if (sym
->attr
.flavor
== FL_NAMELIST
)
5766 tree decl
= generate_namelist_decl (sym
);
5768 gcc_assert (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
);
5769 DECL_CONTEXT (decl
) = sym
->ns
->proc_name
->backend_decl
;
5770 rest_of_decl_compilation (decl
, 1, 0);
5771 gfc_module_add_decl (cur_module
, decl
);
5776 /* Generate all the required code for module variables. */
5779 gfc_generate_module_vars (gfc_namespace
* ns
)
5781 module_namespace
= ns
;
5782 cur_module
= gfc_find_module (ns
->proc_name
->name
);
5784 /* Check if the frontend left the namespace in a reasonable state. */
5785 gcc_assert (ns
->proc_name
&& !ns
->proc_name
->tlink
);
5787 /* Generate COMMON blocks. */
5788 gfc_trans_common (ns
);
5790 has_coarray_vars
= false;
5792 /* Create decls for all the module variables. */
5793 gfc_traverse_ns (ns
, gfc_create_module_variable
);
5794 gfc_traverse_ns (ns
, create_module_nml_decl
);
5796 if (flag_coarray
== GFC_FCOARRAY_LIB
&& has_coarray_vars
)
5797 generate_coarray_init (ns
);
5801 gfc_trans_use_stmts (ns
);
5802 gfc_traverse_ns (ns
, gfc_emit_parameter_debug_info
);
5807 gfc_generate_contained_functions (gfc_namespace
* parent
)
5811 /* We create all the prototypes before generating any code. */
5812 for (ns
= parent
->contained
; ns
; ns
= ns
->sibling
)
5814 /* Skip namespaces from used modules. */
5815 if (ns
->parent
!= parent
)
5818 gfc_create_function_decl (ns
, false);
5821 for (ns
= parent
->contained
; ns
; ns
= ns
->sibling
)
5823 /* Skip namespaces from used modules. */
5824 if (ns
->parent
!= parent
)
5827 gfc_generate_function_code (ns
);
5832 /* Drill down through expressions for the array specification bounds and
5833 character length calling generate_local_decl for all those variables
5834 that have not already been declared. */
5837 generate_local_decl (gfc_symbol
*);
5839 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
5842 expr_decls (gfc_expr
*e
, gfc_symbol
*sym
,
5843 int *f ATTRIBUTE_UNUSED
)
5845 if (e
->expr_type
!= EXPR_VARIABLE
5846 || sym
== e
->symtree
->n
.sym
5847 || e
->symtree
->n
.sym
->mark
5848 || e
->symtree
->n
.sym
->ns
!= sym
->ns
)
5851 generate_local_decl (e
->symtree
->n
.sym
);
5856 generate_expr_decls (gfc_symbol
*sym
, gfc_expr
*e
)
5858 gfc_traverse_expr (e
, sym
, expr_decls
, 0);
5862 /* Check for dependencies in the character length and array spec. */
5865 generate_dependency_declarations (gfc_symbol
*sym
)
5869 if (sym
->ts
.type
== BT_CHARACTER
5871 && sym
->ts
.u
.cl
->length
5872 && sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
5873 generate_expr_decls (sym
, sym
->ts
.u
.cl
->length
);
5875 if (sym
->as
&& sym
->as
->rank
)
5877 for (i
= 0; i
< sym
->as
->rank
; i
++)
5879 generate_expr_decls (sym
, sym
->as
->lower
[i
]);
5880 generate_expr_decls (sym
, sym
->as
->upper
[i
]);
5886 /* Generate decls for all local variables. We do this to ensure correct
5887 handling of expressions which only appear in the specification of
5891 generate_local_decl (gfc_symbol
* sym
)
5893 if (sym
->attr
.flavor
== FL_VARIABLE
)
5895 if (sym
->attr
.codimension
&& !sym
->attr
.dummy
&& !sym
->attr
.allocatable
5896 && sym
->attr
.referenced
&& !sym
->attr
.use_assoc
)
5897 has_coarray_vars
= true;
5899 if (!sym
->attr
.dummy
&& !sym
->ns
->proc_name
->attr
.entry_master
)
5900 generate_dependency_declarations (sym
);
5902 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_WEAK
))
5904 if (sym
->attr
.dummy
)
5905 gfc_error ("Symbol %qs at %L has the WEAK attribute but is a "
5906 "dummy argument", sym
->name
, &sym
->declared_at
);
5908 gfc_error ("Symbol %qs at %L has the WEAK attribute but is a "
5909 "local variable", sym
->name
, &sym
->declared_at
);
5912 if (sym
->attr
.referenced
)
5913 gfc_get_symbol_decl (sym
);
5915 /* Warnings for unused dummy arguments. */
5916 else if (sym
->attr
.dummy
&& !sym
->attr
.in_namelist
)
5918 /* INTENT(out) dummy arguments are likely meant to be set. */
5919 if (warn_unused_dummy_argument
&& sym
->attr
.intent
== INTENT_OUT
)
5921 if (sym
->ts
.type
!= BT_DERIVED
)
5922 gfc_warning (OPT_Wunused_dummy_argument
,
5923 "Dummy argument %qs at %L was declared "
5924 "INTENT(OUT) but was not set", sym
->name
,
5926 else if (!gfc_has_default_initializer (sym
->ts
.u
.derived
)
5927 && !sym
->ts
.u
.derived
->attr
.zero_comp
)
5928 gfc_warning (OPT_Wunused_dummy_argument
,
5929 "Derived-type dummy argument %qs at %L was "
5930 "declared INTENT(OUT) but was not set and "
5931 "does not have a default initializer",
5932 sym
->name
, &sym
->declared_at
);
5933 if (sym
->backend_decl
!= NULL_TREE
)
5934 suppress_warning (sym
->backend_decl
);
5936 else if (warn_unused_dummy_argument
)
5938 if (!sym
->attr
.artificial
)
5939 gfc_warning (OPT_Wunused_dummy_argument
,
5940 "Unused dummy argument %qs at %L", sym
->name
,
5943 if (sym
->backend_decl
!= NULL_TREE
)
5944 suppress_warning (sym
->backend_decl
);
5948 /* Warn for unused variables, but not if they're inside a common
5949 block or a namelist. */
5950 else if (warn_unused_variable
5951 && !(sym
->attr
.in_common
|| sym
->mark
|| sym
->attr
.in_namelist
))
5953 if (sym
->attr
.use_only
)
5955 gfc_warning (OPT_Wunused_variable
,
5956 "Unused module variable %qs which has been "
5957 "explicitly imported at %L", sym
->name
,
5959 if (sym
->backend_decl
!= NULL_TREE
)
5960 suppress_warning (sym
->backend_decl
);
5962 else if (!sym
->attr
.use_assoc
)
5964 /* Corner case: the symbol may be an entry point. At this point,
5965 it may appear to be an unused variable. Suppress warning. */
5969 for (el
= sym
->ns
->entries
; el
; el
=el
->next
)
5970 if (strcmp(sym
->name
, el
->sym
->name
) == 0)
5974 gfc_warning (OPT_Wunused_variable
,
5975 "Unused variable %qs declared at %L",
5976 sym
->name
, &sym
->declared_at
);
5977 if (sym
->backend_decl
!= NULL_TREE
)
5978 suppress_warning (sym
->backend_decl
);
5982 /* For variable length CHARACTER parameters, the PARM_DECL already
5983 references the length variable, so force gfc_get_symbol_decl
5984 even when not referenced. If optimize > 0, it will be optimized
5985 away anyway. But do this only after emitting -Wunused-parameter
5986 warning if requested. */
5987 if (sym
->attr
.dummy
&& !sym
->attr
.referenced
5988 && sym
->ts
.type
== BT_CHARACTER
5989 && sym
->ts
.u
.cl
->backend_decl
!= NULL
5990 && VAR_P (sym
->ts
.u
.cl
->backend_decl
))
5992 sym
->attr
.referenced
= 1;
5993 gfc_get_symbol_decl (sym
);
5996 /* INTENT(out) dummy arguments and result variables with allocatable
5997 components are reset by default and need to be set referenced to
5998 generate the code for nullification and automatic lengths. */
5999 if (!sym
->attr
.referenced
6000 && sym
->ts
.type
== BT_DERIVED
6001 && sym
->ts
.u
.derived
->attr
.alloc_comp
6002 && !sym
->attr
.pointer
6003 && ((sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
)
6005 (sym
->attr
.result
&& sym
!= sym
->result
)))
6007 sym
->attr
.referenced
= 1;
6008 gfc_get_symbol_decl (sym
);
6011 /* Check for dependencies in the array specification and string
6012 length, adding the necessary declarations to the function. We
6013 mark the symbol now, as well as in traverse_ns, to prevent
6014 getting stuck in a circular dependency. */
6017 else if (sym
->attr
.flavor
== FL_PARAMETER
)
6019 if (warn_unused_parameter
6020 && !sym
->attr
.referenced
)
6022 if (!sym
->attr
.use_assoc
)
6023 gfc_warning (OPT_Wunused_parameter
,
6024 "Unused parameter %qs declared at %L", sym
->name
,
6026 else if (sym
->attr
.use_only
)
6027 gfc_warning (OPT_Wunused_parameter
,
6028 "Unused parameter %qs which has been explicitly "
6029 "imported at %L", sym
->name
, &sym
->declared_at
);
6032 if (sym
->ns
&& sym
->ns
->construct_entities
)
6034 /* Construction of the intrinsic modules within a BLOCK
6035 construct, where ONLY and RENAMED entities are included,
6036 seems to be bogus. This is a workaround that can be removed
6037 if someone ever takes on the task to creating full-fledge
6038 modules. See PR 69455. */
6039 if (sym
->attr
.referenced
6040 && sym
->from_intmod
!= INTMOD_ISO_C_BINDING
6041 && sym
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
)
6042 gfc_get_symbol_decl (sym
);
6046 else if (sym
->attr
.flavor
== FL_PROCEDURE
)
6048 /* TODO: move to the appropriate place in resolve.cc. */
6049 if (warn_return_type
> 0
6050 && sym
->attr
.function
6052 && sym
!= sym
->result
6053 && !sym
->result
->attr
.referenced
6054 && !sym
->attr
.use_assoc
6055 && sym
->attr
.if_source
!= IFSRC_IFBODY
)
6057 gfc_warning (OPT_Wreturn_type
,
6058 "Return value %qs of function %qs declared at "
6059 "%L not set", sym
->result
->name
, sym
->name
,
6060 &sym
->result
->declared_at
);
6062 /* Prevents "Unused variable" warning for RESULT variables. */
6063 sym
->result
->mark
= 1;
6067 if (sym
->attr
.dummy
== 1)
6069 /* The tree type for scalar character dummy arguments of BIND(C)
6070 procedures, if they are passed by value, should be unsigned char.
6071 The value attribute implies the dummy is a scalar. */
6072 if (sym
->attr
.value
== 1 && sym
->backend_decl
!= NULL
6073 && sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.is_c_interop
6074 && sym
->ns
->proc_name
!= NULL
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
6076 /* We used to modify the tree here. Now it is done earlier in
6077 the front-end, so we only check it here to avoid regressions. */
6078 gcc_assert (TREE_CODE (TREE_TYPE (sym
->backend_decl
)) == INTEGER_TYPE
);
6079 gcc_assert (TYPE_UNSIGNED (TREE_TYPE (sym
->backend_decl
)) == 1);
6080 gcc_assert (TYPE_PRECISION (TREE_TYPE (sym
->backend_decl
)) == CHAR_TYPE_SIZE
);
6081 gcc_assert (DECL_BY_REFERENCE (sym
->backend_decl
) == 0);
6084 /* Unused procedure passed as dummy argument. */
6085 if (sym
->attr
.flavor
== FL_PROCEDURE
)
6087 if (!sym
->attr
.referenced
&& !sym
->attr
.artificial
)
6089 if (warn_unused_dummy_argument
)
6090 gfc_warning (OPT_Wunused_dummy_argument
,
6091 "Unused dummy argument %qs at %L", sym
->name
,
6095 /* Silence bogus "unused parameter" warnings from the
6097 if (sym
->backend_decl
!= NULL_TREE
)
6098 suppress_warning (sym
->backend_decl
);
6102 /* Make sure we convert the types of the derived types from iso_c_binding
6104 if (sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.is_iso_c
6105 && sym
->ts
.type
== BT_DERIVED
)
6106 sym
->backend_decl
= gfc_typenode_for_spec (&(sym
->ts
));
6111 generate_local_nml_decl (gfc_symbol
* sym
)
6113 if (sym
->attr
.flavor
== FL_NAMELIST
&& !sym
->attr
.use_assoc
)
6115 tree decl
= generate_namelist_decl (sym
);
6122 generate_local_vars (gfc_namespace
* ns
)
6124 gfc_traverse_ns (ns
, generate_local_decl
);
6125 gfc_traverse_ns (ns
, generate_local_nml_decl
);
6129 /* Generate a switch statement to jump to the correct entry point. Also
6130 creates the label decls for the entry points. */
6133 gfc_trans_entry_master_switch (gfc_entry_list
* el
)
6140 gfc_init_block (&block
);
6141 for (; el
; el
= el
->next
)
6143 /* Add the case label. */
6144 label
= gfc_build_label_decl (NULL_TREE
);
6145 val
= build_int_cst (gfc_array_index_type
, el
->id
);
6146 tmp
= build_case_label (val
, NULL_TREE
, label
);
6147 gfc_add_expr_to_block (&block
, tmp
);
6149 /* And jump to the actual entry point. */
6150 label
= gfc_build_label_decl (NULL_TREE
);
6151 tmp
= build1_v (GOTO_EXPR
, label
);
6152 gfc_add_expr_to_block (&block
, tmp
);
6154 /* Save the label decl. */
6157 tmp
= gfc_finish_block (&block
);
6158 /* The first argument selects the entry point. */
6159 val
= DECL_ARGUMENTS (current_function_decl
);
6160 tmp
= fold_build2_loc (input_location
, SWITCH_EXPR
, NULL_TREE
, val
, tmp
);
6165 /* Add code to string lengths of actual arguments passed to a function against
6166 the expected lengths of the dummy arguments. */
6169 add_argument_checking (stmtblock_t
*block
, gfc_symbol
*sym
)
6171 gfc_formal_arglist
*formal
;
6173 for (formal
= gfc_sym_get_dummy_args (sym
); formal
; formal
= formal
->next
)
6174 if (formal
->sym
&& formal
->sym
->ts
.type
== BT_CHARACTER
6175 && !formal
->sym
->ts
.deferred
)
6177 enum tree_code comparison
;
6182 const char *message
;
6188 gcc_assert (cl
->passed_length
!= NULL_TREE
);
6189 gcc_assert (cl
->backend_decl
!= NULL_TREE
);
6191 /* For POINTER, ALLOCATABLE and assumed-shape dummy arguments, the
6192 string lengths must match exactly. Otherwise, it is only required
6193 that the actual string length is *at least* the expected one.
6194 Sequence association allows for a mismatch of the string length
6195 if the actual argument is (part of) an array, but only if the
6196 dummy argument is an array. (See "Sequence association" in
6197 Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.) */
6198 if (fsym
->attr
.pointer
|| fsym
->attr
.allocatable
6199 || (fsym
->as
&& (fsym
->as
->type
== AS_ASSUMED_SHAPE
6200 || fsym
->as
->type
== AS_ASSUMED_RANK
)))
6202 comparison
= NE_EXPR
;
6203 message
= _("Actual string length does not match the declared one"
6204 " for dummy argument '%s' (%ld/%ld)");
6206 else if (fsym
->as
&& fsym
->as
->rank
!= 0)
6210 comparison
= LT_EXPR
;
6211 message
= _("Actual string length is shorter than the declared one"
6212 " for dummy argument '%s' (%ld/%ld)");
6215 /* Build the condition. For optional arguments, an actual length
6216 of 0 is also acceptable if the associated string is NULL, which
6217 means the argument was not passed. */
6218 cond
= fold_build2_loc (input_location
, comparison
, logical_type_node
,
6219 cl
->passed_length
, cl
->backend_decl
);
6220 if (fsym
->attr
.optional
)
6226 not_0length
= fold_build2_loc (input_location
, NE_EXPR
,
6230 (TREE_TYPE (cl
->passed_length
)));
6231 /* The symbol needs to be referenced for gfc_get_symbol_decl. */
6232 fsym
->attr
.referenced
= 1;
6233 not_absent
= gfc_conv_expr_present (fsym
);
6235 absent_failed
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
6236 logical_type_node
, not_0length
,
6239 cond
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
6240 logical_type_node
, cond
, absent_failed
);
6243 /* Build the runtime check. */
6244 argname
= gfc_build_cstring_const (fsym
->name
);
6245 argname
= gfc_build_addr_expr (pchar_type_node
, argname
);
6246 gfc_trans_runtime_check (true, false, cond
, block
, &fsym
->declared_at
,
6248 fold_convert (long_integer_type_node
,
6250 fold_convert (long_integer_type_node
,
6257 create_main_function (tree fndecl
)
6261 tree tmp
, decl
, result_decl
, argc
, argv
, typelist
, arglist
;
6264 old_context
= current_function_decl
;
6268 push_function_context ();
6269 saved_parent_function_decls
= saved_function_decls
;
6270 saved_function_decls
= NULL_TREE
;
6273 /* main() function must be declared with global scope. */
6274 gcc_assert (current_function_decl
== NULL_TREE
);
6276 /* Declare the function. */
6277 tmp
= build_function_type_list (integer_type_node
, integer_type_node
,
6278 build_pointer_type (pchar_type_node
),
6280 main_identifier_node
= get_identifier ("main");
6281 ftn_main
= build_decl (input_location
, FUNCTION_DECL
,
6282 main_identifier_node
, tmp
);
6283 DECL_EXTERNAL (ftn_main
) = 0;
6284 TREE_PUBLIC (ftn_main
) = 1;
6285 TREE_STATIC (ftn_main
) = 1;
6286 DECL_ATTRIBUTES (ftn_main
)
6287 = tree_cons (get_identifier("externally_visible"), NULL_TREE
, NULL_TREE
);
6289 /* Setup the result declaration (for "return 0"). */
6290 result_decl
= build_decl (input_location
,
6291 RESULT_DECL
, NULL_TREE
, integer_type_node
);
6292 DECL_ARTIFICIAL (result_decl
) = 1;
6293 DECL_IGNORED_P (result_decl
) = 1;
6294 DECL_CONTEXT (result_decl
) = ftn_main
;
6295 DECL_RESULT (ftn_main
) = result_decl
;
6297 pushdecl (ftn_main
);
6299 /* Get the arguments. */
6301 arglist
= NULL_TREE
;
6302 typelist
= TYPE_ARG_TYPES (TREE_TYPE (ftn_main
));
6304 tmp
= TREE_VALUE (typelist
);
6305 argc
= build_decl (input_location
, PARM_DECL
, get_identifier ("argc"), tmp
);
6306 DECL_CONTEXT (argc
) = ftn_main
;
6307 DECL_ARG_TYPE (argc
) = TREE_VALUE (typelist
);
6308 TREE_READONLY (argc
) = 1;
6309 gfc_finish_decl (argc
);
6310 arglist
= chainon (arglist
, argc
);
6312 typelist
= TREE_CHAIN (typelist
);
6313 tmp
= TREE_VALUE (typelist
);
6314 argv
= build_decl (input_location
, PARM_DECL
, get_identifier ("argv"), tmp
);
6315 DECL_CONTEXT (argv
) = ftn_main
;
6316 DECL_ARG_TYPE (argv
) = TREE_VALUE (typelist
);
6317 TREE_READONLY (argv
) = 1;
6318 DECL_BY_REFERENCE (argv
) = 1;
6319 gfc_finish_decl (argv
);
6320 arglist
= chainon (arglist
, argv
);
6322 DECL_ARGUMENTS (ftn_main
) = arglist
;
6323 current_function_decl
= ftn_main
;
6324 announce_function (ftn_main
);
6326 rest_of_decl_compilation (ftn_main
, 1, 0);
6327 make_decl_rtl (ftn_main
);
6328 allocate_struct_function (ftn_main
, false);
6331 gfc_init_block (&body
);
6333 /* Call some libgfortran initialization routines, call then MAIN__(). */
6335 /* Call _gfortran_caf_init (*argc, ***argv). */
6336 if (flag_coarray
== GFC_FCOARRAY_LIB
)
6338 tree pint_type
, pppchar_type
;
6339 pint_type
= build_pointer_type (integer_type_node
);
6341 = build_pointer_type (build_pointer_type (pchar_type_node
));
6343 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_init
, 2,
6344 gfc_build_addr_expr (pint_type
, argc
),
6345 gfc_build_addr_expr (pppchar_type
, argv
));
6346 gfc_add_expr_to_block (&body
, tmp
);
6349 /* Call _gfortran_set_args (argc, argv). */
6350 TREE_USED (argc
) = 1;
6351 TREE_USED (argv
) = 1;
6352 tmp
= build_call_expr_loc (input_location
,
6353 gfor_fndecl_set_args
, 2, argc
, argv
);
6354 gfc_add_expr_to_block (&body
, tmp
);
6356 /* Add a call to set_options to set up the runtime library Fortran
6357 language standard parameters. */
6359 tree array_type
, array
, var
;
6360 vec
<constructor_elt
, va_gc
> *v
= NULL
;
6361 static const int noptions
= 7;
6363 /* Passing a new option to the library requires three modifications:
6364 + add it to the tree_cons list below
6365 + change the noptions variable above
6366 + modify the library (runtime/compile_options.c)! */
6368 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
6369 build_int_cst (integer_type_node
,
6370 gfc_option
.warn_std
));
6371 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
6372 build_int_cst (integer_type_node
,
6373 gfc_option
.allow_std
));
6374 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
6375 build_int_cst (integer_type_node
, pedantic
));
6376 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
6377 build_int_cst (integer_type_node
, flag_backtrace
));
6378 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
6379 build_int_cst (integer_type_node
, flag_sign_zero
));
6380 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
6381 build_int_cst (integer_type_node
,
6383 & GFC_RTCHECK_BOUNDS
)));
6384 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
6385 build_int_cst (integer_type_node
,
6386 gfc_option
.fpe_summary
));
6388 array_type
= build_array_type_nelts (integer_type_node
, noptions
);
6389 array
= build_constructor (array_type
, v
);
6390 TREE_CONSTANT (array
) = 1;
6391 TREE_STATIC (array
) = 1;
6393 /* Create a static variable to hold the jump table. */
6394 var
= build_decl (input_location
, VAR_DECL
,
6395 create_tmp_var_name ("options"), array_type
);
6396 DECL_ARTIFICIAL (var
) = 1;
6397 DECL_IGNORED_P (var
) = 1;
6398 TREE_CONSTANT (var
) = 1;
6399 TREE_STATIC (var
) = 1;
6400 TREE_READONLY (var
) = 1;
6401 DECL_INITIAL (var
) = array
;
6403 var
= gfc_build_addr_expr (build_pointer_type (integer_type_node
), var
);
6405 tmp
= build_call_expr_loc (input_location
,
6406 gfor_fndecl_set_options
, 2,
6407 build_int_cst (integer_type_node
, noptions
), var
);
6408 gfc_add_expr_to_block (&body
, tmp
);
6411 /* If -ffpe-trap option was provided, add a call to set_fpe so that
6412 the library will raise a FPE when needed. */
6413 if (gfc_option
.fpe
!= 0)
6415 tmp
= build_call_expr_loc (input_location
,
6416 gfor_fndecl_set_fpe
, 1,
6417 build_int_cst (integer_type_node
,
6419 gfc_add_expr_to_block (&body
, tmp
);
6422 /* If this is the main program and an -fconvert option was provided,
6423 add a call to set_convert. */
6425 if (flag_convert
!= GFC_FLAG_CONVERT_NATIVE
)
6427 tmp
= build_call_expr_loc (input_location
,
6428 gfor_fndecl_set_convert
, 1,
6429 build_int_cst (integer_type_node
, flag_convert
));
6430 gfc_add_expr_to_block (&body
, tmp
);
6433 /* If this is the main program and an -frecord-marker option was provided,
6434 add a call to set_record_marker. */
6436 if (flag_record_marker
!= 0)
6438 tmp
= build_call_expr_loc (input_location
,
6439 gfor_fndecl_set_record_marker
, 1,
6440 build_int_cst (integer_type_node
,
6441 flag_record_marker
));
6442 gfc_add_expr_to_block (&body
, tmp
);
6445 if (flag_max_subrecord_length
!= 0)
6447 tmp
= build_call_expr_loc (input_location
,
6448 gfor_fndecl_set_max_subrecord_length
, 1,
6449 build_int_cst (integer_type_node
,
6450 flag_max_subrecord_length
));
6451 gfc_add_expr_to_block (&body
, tmp
);
6454 /* Call MAIN__(). */
6455 tmp
= build_call_expr_loc (input_location
,
6457 gfc_add_expr_to_block (&body
, tmp
);
6459 /* Mark MAIN__ as used. */
6460 TREE_USED (fndecl
) = 1;
6462 /* Coarray: Call _gfortran_caf_finalize(void). */
6463 if (flag_coarray
== GFC_FCOARRAY_LIB
)
6465 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_finalize
, 0);
6466 gfc_add_expr_to_block (&body
, tmp
);
6470 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, integer_type_node
,
6471 DECL_RESULT (ftn_main
),
6472 build_int_cst (integer_type_node
, 0));
6473 tmp
= build1_v (RETURN_EXPR
, tmp
);
6474 gfc_add_expr_to_block (&body
, tmp
);
6477 DECL_SAVED_TREE (ftn_main
) = gfc_finish_block (&body
);
6480 /* Finish off this function and send it for code generation. */
6482 BLOCK_SUPERCONTEXT (DECL_INITIAL (ftn_main
)) = ftn_main
;
6484 DECL_SAVED_TREE (ftn_main
)
6485 = fold_build3_loc (DECL_SOURCE_LOCATION (ftn_main
), BIND_EXPR
,
6486 void_type_node
, decl
, DECL_SAVED_TREE (ftn_main
),
6487 DECL_INITIAL (ftn_main
));
6489 /* Output the GENERIC tree. */
6490 dump_function (TDI_original
, ftn_main
);
6492 cgraph_node::finalize_function (ftn_main
, true);
6496 pop_function_context ();
6497 saved_function_decls
= saved_parent_function_decls
;
6499 current_function_decl
= old_context
;
6503 /* Generate an appropriate return-statement for a procedure. */
6506 gfc_generate_return (void)
6512 sym
= current_procedure_symbol
;
6513 fndecl
= sym
->backend_decl
;
6515 if (TREE_TYPE (DECL_RESULT (fndecl
)) == void_type_node
)
6519 result
= get_proc_result (sym
);
6521 /* Set the return value to the dummy result variable. The
6522 types may be different for scalar default REAL functions
6523 with -ff2c, therefore we have to convert. */
6524 if (result
!= NULL_TREE
)
6526 result
= convert (TREE_TYPE (DECL_RESULT (fndecl
)), result
);
6527 result
= fold_build2_loc (input_location
, MODIFY_EXPR
,
6528 TREE_TYPE (result
), DECL_RESULT (fndecl
),
6533 /* If the function does not have a result variable, result is
6534 NULL_TREE, and a 'return' is generated without a variable.
6535 The following generates a 'return __result_XXX' where XXX is
6536 the function name. */
6537 if (sym
== sym
->result
&& sym
->attr
.function
&& !flag_f2c
)
6539 result
= gfc_get_fake_result_decl (sym
, 0);
6540 result
= fold_build2_loc (input_location
, MODIFY_EXPR
,
6542 DECL_RESULT (fndecl
), result
);
6547 return build1_v (RETURN_EXPR
, result
);
6552 is_from_ieee_module (gfc_symbol
*sym
)
6554 if (sym
->from_intmod
== INTMOD_IEEE_FEATURES
6555 || sym
->from_intmod
== INTMOD_IEEE_EXCEPTIONS
6556 || sym
->from_intmod
== INTMOD_IEEE_ARITHMETIC
)
6557 seen_ieee_symbol
= 1;
6562 is_ieee_module_used (gfc_namespace
*ns
)
6564 seen_ieee_symbol
= 0;
6565 gfc_traverse_ns (ns
, is_from_ieee_module
);
6566 return seen_ieee_symbol
;
6570 static gfc_omp_clauses
*module_oacc_clauses
;
6574 add_clause (gfc_symbol
*sym
, gfc_omp_map_op map_op
)
6576 gfc_omp_namelist
*n
;
6578 n
= gfc_get_omp_namelist ();
6580 n
->u
.map_op
= map_op
;
6582 if (!module_oacc_clauses
)
6583 module_oacc_clauses
= gfc_get_omp_clauses ();
6585 if (module_oacc_clauses
->lists
[OMP_LIST_MAP
])
6586 n
->next
= module_oacc_clauses
->lists
[OMP_LIST_MAP
];
6588 module_oacc_clauses
->lists
[OMP_LIST_MAP
] = n
;
6593 find_module_oacc_declare_clauses (gfc_symbol
*sym
)
6595 if (sym
->attr
.use_assoc
)
6597 gfc_omp_map_op map_op
;
6599 if (sym
->attr
.oacc_declare_create
)
6600 map_op
= OMP_MAP_FORCE_ALLOC
;
6602 if (sym
->attr
.oacc_declare_copyin
)
6603 map_op
= OMP_MAP_FORCE_TO
;
6605 if (sym
->attr
.oacc_declare_deviceptr
)
6606 map_op
= OMP_MAP_FORCE_DEVICEPTR
;
6608 if (sym
->attr
.oacc_declare_device_resident
)
6609 map_op
= OMP_MAP_DEVICE_RESIDENT
;
6611 if (sym
->attr
.oacc_declare_create
6612 || sym
->attr
.oacc_declare_copyin
6613 || sym
->attr
.oacc_declare_deviceptr
6614 || sym
->attr
.oacc_declare_device_resident
)
6616 sym
->attr
.referenced
= 1;
6617 add_clause (sym
, map_op
);
6624 finish_oacc_declare (gfc_namespace
*ns
, gfc_symbol
*sym
, bool block
)
6627 gfc_oacc_declare
*oc
;
6628 locus where
= gfc_current_locus
;
6629 gfc_omp_clauses
*omp_clauses
= NULL
;
6630 gfc_omp_namelist
*n
, *p
;
6632 module_oacc_clauses
= NULL
;
6633 gfc_traverse_ns (ns
, find_module_oacc_declare_clauses
);
6635 if (module_oacc_clauses
&& sym
->attr
.flavor
== FL_PROGRAM
)
6637 gfc_oacc_declare
*new_oc
;
6639 new_oc
= gfc_get_oacc_declare ();
6640 new_oc
->next
= ns
->oacc_declare
;
6641 new_oc
->clauses
= module_oacc_clauses
;
6643 ns
->oacc_declare
= new_oc
;
6646 if (!ns
->oacc_declare
)
6649 for (oc
= ns
->oacc_declare
; oc
; oc
= oc
->next
)
6655 gfc_error ("Sorry, !$ACC DECLARE at %L is not allowed "
6656 "in BLOCK construct", &oc
->loc
);
6659 if (oc
->clauses
&& oc
->clauses
->lists
[OMP_LIST_MAP
])
6661 if (omp_clauses
== NULL
)
6663 omp_clauses
= oc
->clauses
;
6667 for (n
= oc
->clauses
->lists
[OMP_LIST_MAP
]; n
; p
= n
, n
= n
->next
)
6670 gcc_assert (p
->next
== NULL
);
6672 p
->next
= omp_clauses
->lists
[OMP_LIST_MAP
];
6673 omp_clauses
= oc
->clauses
;
6680 for (n
= omp_clauses
->lists
[OMP_LIST_MAP
]; n
; n
= n
->next
)
6682 switch (n
->u
.map_op
)
6684 case OMP_MAP_DEVICE_RESIDENT
:
6685 n
->u
.map_op
= OMP_MAP_FORCE_ALLOC
;
6693 code
= XCNEW (gfc_code
);
6694 code
->op
= EXEC_OACC_DECLARE
;
6697 code
->ext
.oacc_declare
= gfc_get_oacc_declare ();
6698 code
->ext
.oacc_declare
->clauses
= omp_clauses
;
6700 code
->block
= XCNEW (gfc_code
);
6701 code
->block
->op
= EXEC_OACC_DECLARE
;
6702 code
->block
->loc
= where
;
6705 code
->block
->next
= ns
->code
;
6713 gfc_conv_cfi_to_gfc (stmtblock_t
*init
, stmtblock_t
*finally
,
6714 tree cfi_desc
, tree gfc_desc
, gfc_symbol
*sym
)
6717 gfc_init_block (&block
);
6718 tree cfi
= build_fold_indirect_ref_loc (input_location
, cfi_desc
);
6719 tree idx
, etype
, tmp
, tmp2
, size_var
= NULL_TREE
, rank
= NULL_TREE
;
6720 bool do_copy_inout
= false;
6722 /* When allocatable + intent out, free the cfi descriptor. */
6723 if (sym
->attr
.allocatable
&& sym
->attr
.intent
== INTENT_OUT
)
6725 tmp
= gfc_get_cfi_desc_base_addr (cfi
);
6726 tree call
= builtin_decl_explicit (BUILT_IN_FREE
);
6727 call
= build_call_expr_loc (input_location
, call
, 1, tmp
);
6728 gfc_add_expr_to_block (&block
, fold_convert (void_type_node
, call
));
6729 gfc_add_modify (&block
, tmp
,
6730 fold_convert (TREE_TYPE (tmp
), null_pointer_node
));
6733 /* -fcheck=bound: Do version, rank, attribute, type and is-NULL checks. */
6734 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
6738 msg
= xasprintf ("Unexpected version %%d (expected %d) in CFI descriptor "
6739 "passed to dummy argument %s", CFI_VERSION
, sym
->name
);
6740 tmp2
= gfc_get_cfi_desc_version (cfi
);
6741 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp2
,
6742 build_int_cst (TREE_TYPE (tmp2
), CFI_VERSION
));
6743 gfc_trans_runtime_check (true, false, tmp
, &block
, &sym
->declared_at
,
6747 /* Rank check; however, for character(len=*), assumed/explicit-size arrays
6748 are permitted to differ in rank according to the Fortran rules. */
6749 if (sym
->as
&& sym
->as
->type
!= AS_ASSUMED_SIZE
6750 && sym
->as
->type
!= AS_EXPLICIT
)
6752 if (sym
->as
->rank
!= -1)
6753 msg
= xasprintf ("Invalid rank %%d (expected %d) in CFI descriptor "
6754 "passed to dummy argument %s", sym
->as
->rank
,
6757 msg
= xasprintf ("Invalid rank %%d (expected 0..%d) in CFI "
6758 "descriptor passed to dummy argument %s",
6759 CFI_MAX_RANK
, sym
->name
);
6761 tmp3
= tmp2
= tmp
= gfc_get_cfi_desc_rank (cfi
);
6762 if (sym
->as
->rank
!= -1)
6763 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6764 tmp
, build_int_cst (signed_char_type_node
,
6768 tmp
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
6769 tmp
, build_zero_cst (TREE_TYPE (tmp
)));
6770 tmp2
= fold_build2_loc (input_location
, GT_EXPR
,
6771 boolean_type_node
, tmp2
,
6772 build_int_cst (TREE_TYPE (tmp2
),
6774 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
6775 boolean_type_node
, tmp
, tmp2
);
6777 gfc_trans_runtime_check (true, false, tmp
, &block
, &sym
->declared_at
,
6782 tmp3
= tmp
= gfc_get_cfi_desc_attribute (cfi
);
6783 if (sym
->attr
.allocatable
|| sym
->attr
.pointer
)
6785 int attr
= (sym
->attr
.pointer
? CFI_attribute_pointer
6786 : CFI_attribute_allocatable
);
6787 msg
= xasprintf ("Invalid attribute %%d (expected %d) in CFI "
6788 "descriptor passed to dummy argument %s with %s "
6789 "attribute", attr
, sym
->name
,
6790 sym
->attr
.pointer
? "pointer" : "allocatable");
6791 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6792 tmp
, build_int_cst (TREE_TYPE (tmp
), attr
));
6796 int amin
= MIN (CFI_attribute_pointer
,
6797 MIN (CFI_attribute_allocatable
, CFI_attribute_other
));
6798 int amax
= MAX (CFI_attribute_pointer
,
6799 MAX (CFI_attribute_allocatable
, CFI_attribute_other
));
6800 msg
= xasprintf ("Invalid attribute %%d (expected %d..%d) in CFI "
6801 "descriptor passed to nonallocatable, nonpointer "
6802 "dummy argument %s", amin
, amax
, sym
->name
);
6804 tmp
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
, tmp
,
6805 build_int_cst (TREE_TYPE (tmp
), amin
));
6806 tmp2
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
, tmp2
,
6807 build_int_cst (TREE_TYPE (tmp2
), amax
));
6808 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
6809 boolean_type_node
, tmp
, tmp2
);
6810 gfc_trans_runtime_check (true, false, tmp
, &block
, &sym
->declared_at
,
6813 msg
= xasprintf ("Invalid unallocatated/unassociated CFI "
6814 "descriptor passed to nonallocatable, nonpointer "
6815 "dummy argument %s", sym
->name
);
6816 tmp3
= tmp
= gfc_get_cfi_desc_base_addr (cfi
),
6817 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
6818 tmp
, null_pointer_node
);
6820 gfc_trans_runtime_check (true, false, tmp
, &block
, &sym
->declared_at
,
6824 if (sym
->ts
.type
!= BT_ASSUMED
)
6826 int type
= CFI_type_other
;
6827 if (sym
->ts
.f90_type
== BT_VOID
)
6829 type
= (sym
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_FUNPTR
6830 ? CFI_type_cfunptr
: CFI_type_cptr
);
6833 switch (sym
->ts
.type
)
6839 type
= CFI_type_from_type_kind (sym
->ts
.type
, sym
->ts
.kind
);
6842 type
= CFI_type_from_type_kind (CFI_type_Character
,
6846 type
= CFI_type_struct
;
6849 type
= (sym
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_FUNPTR
6850 ? CFI_type_cfunptr
: CFI_type_cptr
);
6861 msg
= xasprintf ("Unexpected type %%d (expected %d) in CFI descriptor"
6862 " passed to dummy argument %s", type
, sym
->name
);
6863 tmp2
= tmp
= gfc_get_cfi_desc_type (cfi
);
6864 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6865 tmp
, build_int_cst (TREE_TYPE (tmp
), type
));
6866 gfc_trans_runtime_check (true, false, tmp
, &block
, &sym
->declared_at
,
6872 if (!sym
->attr
.referenced
)
6875 /* Set string length for len=* and len=:, otherwise, it is already set. */
6876 if (sym
->ts
.type
== BT_CHARACTER
&& !sym
->ts
.u
.cl
->length
)
6878 tmp
= fold_convert (gfc_array_index_type
,
6879 gfc_get_cfi_desc_elem_len (cfi
));
6880 if (sym
->ts
.kind
!= 1)
6881 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
6882 gfc_array_index_type
, tmp
,
6883 build_int_cst (gfc_charlen_type_node
,
6885 gfc_add_modify (&block
, sym
->ts
.u
.cl
->backend_decl
, tmp
);
6888 if (sym
->ts
.type
== BT_CHARACTER
6889 && !INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
))
6891 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, init
);
6892 gfc_trans_vla_type_sizes (sym
, init
);
6895 /* gfc->data = cfi->base_addr - or for scalars: gfc = cfi->base_addr.
6896 assumed-size/explicit-size arrays end up here for character(len=*)
6898 if (!sym
->attr
.dimension
|| !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc
)))
6900 tmp
= gfc_get_cfi_desc_base_addr (cfi
);
6901 gfc_add_modify (&block
, gfc_desc
,
6902 fold_convert (TREE_TYPE (gfc_desc
), tmp
));
6903 if (!sym
->attr
.dimension
)
6907 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc
)))
6909 /* gfc->dtype = ... (from declaration, not from cfi). */
6910 etype
= gfc_get_element_type (TREE_TYPE (gfc_desc
));
6911 gfc_add_modify (&block
, gfc_conv_descriptor_dtype (gfc_desc
),
6912 gfc_get_dtype_rank_type (sym
->as
->rank
, etype
));
6913 /* gfc->data = cfi->base_addr. */
6914 gfc_conv_descriptor_data_set (&block
, gfc_desc
,
6915 gfc_get_cfi_desc_base_addr (cfi
));
6918 if (sym
->ts
.type
== BT_ASSUMED
)
6920 /* For type(*), take elem_len + dtype.type from the actual argument. */
6921 gfc_add_modify (&block
, gfc_conv_descriptor_elem_len (gfc_desc
),
6922 gfc_get_cfi_desc_elem_len (cfi
));
6924 tree ctype
= gfc_get_cfi_desc_type (cfi
);
6925 ctype
= fold_build2_loc (input_location
, BIT_AND_EXPR
, TREE_TYPE (ctype
),
6926 ctype
, build_int_cst (TREE_TYPE (ctype
),
6928 tree type
= gfc_conv_descriptor_type (gfc_desc
);
6930 /* if (CFI_type_cptr) BT_VOID else BT_UNKNOWN */
6931 /* Note: BT_VOID is could also be CFI_type_funcptr, but assume c_ptr. */
6932 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, ctype
,
6933 build_int_cst (TREE_TYPE (ctype
), CFI_type_cptr
));
6934 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
, type
,
6935 build_int_cst (TREE_TYPE (type
), BT_VOID
));
6936 tmp2
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
6938 build_int_cst (TREE_TYPE (type
), BT_UNKNOWN
));
6939 tmp2
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
6941 /* if (CFI_type_struct) BT_DERIVED else < tmp2 > */
6942 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, ctype
,
6943 build_int_cst (TREE_TYPE (ctype
),
6945 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
, type
,
6946 build_int_cst (TREE_TYPE (type
), BT_DERIVED
));
6947 tmp2
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
6949 /* if (CFI_type_Character) BT_CHARACTER else < tmp2 > */
6950 /* Note: this is kind=1, CFI_type_ucs4_char is handled in the 'else if'
6951 before (see below, as generated bottom up). */
6952 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, ctype
,
6953 build_int_cst (TREE_TYPE (ctype
),
6954 CFI_type_Character
));
6955 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
, type
,
6956 build_int_cst (TREE_TYPE (type
), BT_CHARACTER
));
6957 tmp2
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
6959 /* if (CFI_type_ucs4_char) BT_CHARACTER else < tmp2 > */
6960 /* Note: gfc->elem_len = cfi->elem_len/4. */
6961 /* However, assuming that CFI_type_ucs4_char cannot be recovered, leave
6962 gfc->elem_len == cfi->elem_len, which helps with operations which use
6963 sizeof() in Fortran and cfi->elem_len in C. */
6964 tmp
= gfc_get_cfi_desc_type (cfi
);
6965 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, tmp
,
6966 build_int_cst (TREE_TYPE (tmp
),
6967 CFI_type_ucs4_char
));
6968 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
, type
,
6969 build_int_cst (TREE_TYPE (type
), BT_CHARACTER
));
6970 tmp2
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
6972 /* if (CFI_type_Complex) BT_COMPLEX + cfi->elem_len/2 else < tmp2 > */
6973 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, ctype
,
6974 build_int_cst (TREE_TYPE (ctype
),
6976 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
, type
,
6977 build_int_cst (TREE_TYPE (type
), BT_COMPLEX
));
6978 tmp2
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
6980 /* if (CFI_type_Integer || CFI_type_Logical || CFI_type_Real)
6981 ctype else <tmp2> */
6982 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, ctype
,
6983 build_int_cst (TREE_TYPE (ctype
),
6985 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, ctype
,
6986 build_int_cst (TREE_TYPE (ctype
),
6988 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, boolean_type_node
,
6990 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, ctype
,
6991 build_int_cst (TREE_TYPE (ctype
),
6993 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, boolean_type_node
,
6995 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
6996 type
, fold_convert (TREE_TYPE (type
), ctype
));
6997 tmp2
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
6999 gfc_add_expr_to_block (&block
, tmp2
);
7002 if (sym
->as
->rank
< 0)
7004 /* Set gfc->dtype.rank, if assumed-rank. */
7005 rank
= gfc_get_cfi_desc_rank (cfi
);
7006 gfc_add_modify (&block
, gfc_conv_descriptor_rank (gfc_desc
), rank
);
7008 else if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc
)))
7009 /* In that case, the CFI rank and the declared rank can differ. */
7010 rank
= gfc_get_cfi_desc_rank (cfi
);
7012 rank
= build_int_cst (signed_char_type_node
, sym
->as
->rank
);
7014 /* With bind(C), the standard requires that both Fortran callers and callees
7015 handle noncontiguous arrays passed to an dummy with 'contiguous' attribute
7016 and with character(len=*) + assumed-size/explicit-size arrays.
7017 cf. Fortran 2018, 18.3.6, paragraph 5 (and for the caller: para. 6). */
7018 if ((sym
->ts
.type
== BT_CHARACTER
&& !sym
->ts
.u
.cl
->length
7019 && (sym
->as
->type
== AS_ASSUMED_SIZE
|| sym
->as
->type
== AS_EXPLICIT
))
7020 || sym
->attr
.contiguous
)
7022 do_copy_inout
= true;
7023 gcc_assert (!sym
->attr
.pointer
);
7026 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc
)))
7027 data
= gfc_conv_descriptor_data_get (gfc_desc
);
7028 else if (!POINTER_TYPE_P (TREE_TYPE (gfc_desc
)))
7029 data
= gfc_build_addr_expr (NULL
, gfc_desc
);
7033 /* Is copy-in/out needed? */
7034 /* do_copyin = rank != 0 && !assumed-size */
7035 tree cond_var
= gfc_create_var (boolean_type_node
, "do_copyin");
7036 tree cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7037 rank
, build_zero_cst (TREE_TYPE (rank
)));
7038 /* dim[rank-1].extent != -1 -> assumed size*/
7039 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (rank
),
7040 rank
, build_int_cst (TREE_TYPE (rank
), 1));
7041 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7042 gfc_get_cfi_dim_extent (cfi
, tmp
),
7043 build_int_cst (gfc_array_index_type
, -1));
7044 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
7045 boolean_type_node
, cond
, tmp
);
7046 gfc_add_modify (&block
, cond_var
, cond
);
7047 /* if (do_copyin) do_copyin = ... || ... || ... */
7048 gfc_init_block (&block2
);
7049 /* dim[0].sm != elem_len */
7050 tmp
= fold_convert (gfc_array_index_type
,
7051 gfc_get_cfi_desc_elem_len (cfi
));
7052 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7053 gfc_get_cfi_dim_sm (cfi
, gfc_index_zero_node
),
7055 gfc_add_modify (&block2
, cond_var
, cond
);
7057 /* for (i = 1; i < rank; ++i)
7058 cond &&= dim[i].sm != (dv->dim[i - 1].sm * dv->dim[i - 1].extent) */
7059 idx
= gfc_create_var (TREE_TYPE (rank
), "idx");
7060 stmtblock_t loop_body
;
7061 gfc_init_block (&loop_body
);
7062 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (idx
),
7063 idx
, build_int_cst (TREE_TYPE (idx
), 1));
7064 tree tmp2
= gfc_get_cfi_dim_sm (cfi
, tmp
);
7065 tmp
= gfc_get_cfi_dim_extent (cfi
, tmp
);
7066 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
7068 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7069 gfc_get_cfi_dim_sm (cfi
, idx
), tmp
);
7070 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
, boolean_type_node
,
7072 gfc_add_modify (&loop_body
, cond_var
, cond
);
7073 gfc_simple_for_loop (&block2
, idx
, build_int_cst (TREE_TYPE (idx
), 1),
7074 rank
, LT_EXPR
, build_int_cst (TREE_TYPE (idx
), 1),
7075 gfc_finish_block (&loop_body
));
7076 tmp
= build3_v (COND_EXPR
, cond_var
, gfc_finish_block (&block2
),
7077 build_empty_stmt (input_location
));
7078 gfc_add_expr_to_block (&block
, tmp
);
7081 gfc_init_block (&block2
);
7082 /* size = dim[0].extent; for (i = 1; i < rank; ++i) size *= dim[i].extent */
7083 size_var
= gfc_create_var (size_type_node
, "size");
7084 tmp
= fold_convert (size_type_node
,
7085 gfc_get_cfi_dim_extent (cfi
, gfc_index_zero_node
));
7086 gfc_add_modify (&block2
, size_var
, tmp
);
7088 gfc_init_block (&loop_body
);
7089 tmp
= fold_convert (size_type_node
,
7090 gfc_get_cfi_dim_extent (cfi
, idx
));
7091 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
7092 size_var
, fold_convert (size_type_node
, tmp
));
7093 gfc_add_modify (&loop_body
, size_var
, tmp
);
7094 gfc_simple_for_loop (&block2
, idx
, build_int_cst (TREE_TYPE (idx
), 1),
7095 rank
, LT_EXPR
, build_int_cst (TREE_TYPE (idx
), 1),
7096 gfc_finish_block (&loop_body
));
7097 /* data = malloc (size * elem_len) */
7098 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
7099 size_var
, gfc_get_cfi_desc_elem_len (cfi
));
7100 tree call
= builtin_decl_explicit (BUILT_IN_MALLOC
);
7101 call
= build_call_expr_loc (input_location
, call
, 1, tmp
);
7102 gfc_add_modify (&block2
, data
, fold_convert (TREE_TYPE (data
), call
));
7105 for (idx = 0; idx < size; ++idx)
7109 for (dim = 0; dim < rank; ++dim)
7111 shift += (tmpidx % extent[d]) * sm[d]
7112 tmpidx = tmpidx / extend[d]
7114 memcpy (lhs + idx*elem_len, rhs + shift, elem_len)
7116 idx
= gfc_create_var (size_type_node
, "arrayidx");
7117 gfc_init_block (&loop_body
);
7118 tree shift
= gfc_create_var (size_type_node
, "shift");
7119 tree tmpidx
= gfc_create_var (size_type_node
, "tmpidx");
7120 gfc_add_modify (&loop_body
, shift
, build_zero_cst (TREE_TYPE (shift
)));
7121 gfc_add_modify (&loop_body
, tmpidx
, idx
);
7122 stmtblock_t inner_loop
;
7123 gfc_init_block (&inner_loop
);
7124 tree dim
= gfc_create_var (TREE_TYPE (rank
), "dim");
7125 /* shift += (tmpidx % extent[d]) * sm[d] */
7126 tmp
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
,
7127 size_type_node
, tmpidx
,
7128 fold_convert (size_type_node
,
7129 gfc_get_cfi_dim_extent (cfi
, dim
)));
7130 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7131 size_type_node
, tmp
,
7132 fold_convert (size_type_node
,
7133 gfc_get_cfi_dim_sm (cfi
, dim
)));
7134 gfc_add_modify (&inner_loop
, shift
,
7135 fold_build2_loc (input_location
, PLUS_EXPR
,
7136 size_type_node
, shift
, tmp
));
7137 /* tmpidx = tmpidx / extend[d] */
7138 tmp
= fold_convert (size_type_node
, gfc_get_cfi_dim_extent (cfi
, dim
));
7139 gfc_add_modify (&inner_loop
, tmpidx
,
7140 fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
7141 size_type_node
, tmpidx
, tmp
));
7142 gfc_simple_for_loop (&loop_body
, dim
, build_zero_cst (TREE_TYPE (rank
)),
7143 rank
, LT_EXPR
, build_int_cst (TREE_TYPE (dim
), 1),
7144 gfc_finish_block (&inner_loop
));
7146 tmp
= fold_convert (pchar_type_node
, gfc_get_cfi_desc_base_addr (cfi
));
7147 tmp
= fold_build2 (POINTER_PLUS_EXPR
, pchar_type_node
, tmp
, shift
);
7149 /* memcpy (lhs + idx*elem_len, rhs + shift, elem_len) */
7151 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc
)))
7152 elem_len
= gfc_conv_descriptor_elem_len (gfc_desc
);
7154 elem_len
= gfc_get_cfi_desc_elem_len (cfi
);
7155 lhs
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
7157 lhs
= fold_build2_loc (input_location
, POINTER_PLUS_EXPR
, pchar_type_node
,
7158 fold_convert (pchar_type_node
, data
), lhs
);
7159 tmp
= fold_convert (pvoid_type_node
, tmp
);
7160 lhs
= fold_convert (pvoid_type_node
, lhs
);
7161 call
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
7162 call
= build_call_expr_loc (input_location
, call
, 3, lhs
, tmp
, elem_len
);
7163 gfc_add_expr_to_block (&loop_body
, fold_convert (void_type_node
, call
));
7164 gfc_simple_for_loop (&block2
, idx
, build_zero_cst (TREE_TYPE (idx
)),
7165 size_var
, LT_EXPR
, build_int_cst (TREE_TYPE (idx
), 1),
7166 gfc_finish_block (&loop_body
));
7167 /* if (cond) { block2 } */
7168 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
7169 data
, fold_convert (TREE_TYPE (data
),
7170 null_pointer_node
));
7171 tmp
= build3_v (COND_EXPR
, cond_var
, gfc_finish_block (&block2
),
7172 build_empty_stmt (input_location
));
7173 gfc_add_expr_to_block (&block
, tmp
);
7176 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc
)))
7179 type
= TREE_TYPE (gfc_desc
);
7180 gfc_trans_array_bounds (type
, sym
, &offset
, &block
);
7181 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type
)))
7182 gfc_add_modify (&block
, GFC_TYPE_ARRAY_OFFSET (type
), offset
);
7186 /* If cfi->data != NULL. */
7188 gfc_init_block (&block2
);
7190 /* if do_copy_inout: gfc->dspan = gfc->dtype.elem_len
7191 We use gfc instead of cfi on the RHS as this might be a constant. */
7192 tmp
= fold_convert (gfc_array_index_type
,
7193 gfc_conv_descriptor_elem_len (gfc_desc
));
7196 /* gfc->dspan = ((cfi->dim[0].sm % gfc->elem_len)
7197 ? cfi->dim[0].sm : gfc->elem_len). */
7199 tree tmp2
= gfc_get_cfi_dim_sm (cfi
, gfc_rank_cst
[0]);
7200 cond
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
,
7201 gfc_array_index_type
, tmp2
, tmp
);
7202 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7203 cond
, gfc_index_zero_node
);
7204 tmp
= build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
, cond
,
7207 gfc_conv_descriptor_span_set (&block2
, gfc_desc
, tmp
);
7209 /* Calculate offset + set lbound, ubound and stride. */
7210 gfc_conv_descriptor_offset_set (&block2
, gfc_desc
, gfc_index_zero_node
);
7211 if (sym
->as
->rank
> 0 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
)
7212 for (int i
= 0; i
< sym
->as
->rank
; ++i
)
7215 gfc_init_se (&se
, NULL
);
7216 if (sym
->as
->lower
[i
])
7218 gfc_conv_expr (&se
, sym
->as
->lower
[i
]);
7222 tmp
= gfc_index_one_node
;
7223 gfc_add_block_to_block (&block2
, &se
.pre
);
7224 gfc_conv_descriptor_lbound_set (&block2
, gfc_desc
, gfc_rank_cst
[i
],
7226 gfc_add_block_to_block (&block2
, &se
.post
);
7229 /* Loop: for (i = 0; i < rank; ++i). */
7230 idx
= gfc_create_var (TREE_TYPE (rank
), "idx");
7233 stmtblock_t loop_body
;
7234 gfc_init_block (&loop_body
);
7235 /* gfc->dim[i].lbound = ... */
7236 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
7238 tmp
= gfc_get_cfi_dim_lbound (cfi
, idx
);
7239 gfc_conv_descriptor_lbound_set (&loop_body
, gfc_desc
, idx
, tmp
);
7241 else if (sym
->as
->rank
< 0)
7242 gfc_conv_descriptor_lbound_set (&loop_body
, gfc_desc
, idx
,
7243 gfc_index_one_node
);
7245 /* gfc->dim[i].ubound = gfc->dim[i].lbound + cfi->dim[i].extent - 1. */
7246 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7247 gfc_conv_descriptor_lbound_get (gfc_desc
, idx
),
7248 gfc_index_one_node
);
7249 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
7250 gfc_get_cfi_dim_extent (cfi
, idx
), tmp
);
7251 gfc_conv_descriptor_ubound_set (&loop_body
, gfc_desc
, idx
, tmp
);
7255 /* gfc->dim[i].stride
7256 = idx == 0 ? 1 : gfc->dim[i-1].stride * cfi->dim[i-1].extent */
7257 tree cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
7258 idx
, build_zero_cst (TREE_TYPE (idx
)));
7259 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (idx
),
7260 idx
, build_int_cst (TREE_TYPE (idx
), 1));
7261 tree tmp2
= gfc_get_cfi_dim_extent (cfi
, tmp
);
7262 tmp
= gfc_conv_descriptor_stride_get (gfc_desc
, tmp
);
7263 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp2
),
7265 tmp
= build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
, cond
,
7266 gfc_index_one_node
, tmp
);
7270 /* gfc->dim[i].stride = cfi->dim[i].sm / cfi>elem_len */
7271 tmp
= gfc_get_cfi_dim_sm (cfi
, idx
);
7272 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
7273 gfc_array_index_type
, tmp
,
7274 fold_convert (gfc_array_index_type
,
7275 gfc_get_cfi_desc_elem_len (cfi
)));
7277 gfc_conv_descriptor_stride_set (&loop_body
, gfc_desc
, idx
, tmp
);
7278 /* gfc->offset -= gfc->dim[i].stride * gfc->dim[i].lbound. */
7279 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7280 gfc_conv_descriptor_stride_get (gfc_desc
, idx
),
7281 gfc_conv_descriptor_lbound_get (gfc_desc
, idx
));
7282 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7283 gfc_conv_descriptor_offset_get (gfc_desc
), tmp
);
7284 gfc_conv_descriptor_offset_set (&loop_body
, gfc_desc
, tmp
);
7286 /* Generate loop. */
7287 gfc_simple_for_loop (&block2
, idx
, build_zero_cst (TREE_TYPE (idx
)),
7288 rank
, LT_EXPR
, build_int_cst (TREE_TYPE (idx
), 1),
7289 gfc_finish_block (&loop_body
));
7290 if (sym
->attr
.allocatable
|| sym
->attr
.pointer
)
7292 tmp
= gfc_get_cfi_desc_base_addr (cfi
),
7293 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7294 tmp
, null_pointer_node
);
7295 tmp
= build3_v (COND_EXPR
, tmp
, gfc_finish_block (&block2
),
7296 build_empty_stmt (input_location
));
7297 gfc_add_expr_to_block (&block
, tmp
);
7300 gfc_add_block_to_block (&block
, &block2
);
7303 /* If optional arg: 'if (arg) { block } else { local_arg = NULL; }'. */
7304 if (sym
->attr
.optional
)
7306 tree present
= fold_build2_loc (input_location
, NE_EXPR
,
7307 boolean_type_node
, cfi_desc
,
7309 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
7311 fold_convert (TREE_TYPE (sym
->backend_decl
),
7312 null_pointer_node
));
7313 tmp
= build3_v (COND_EXPR
, present
, gfc_finish_block (&block
), tmp
);
7314 gfc_add_expr_to_block (init
, tmp
);
7317 gfc_add_block_to_block (init
, &block
);
7319 if (!sym
->attr
.referenced
)
7322 /* If pointer not changed, nothing to be done (except copy out) */
7323 if (!do_copy_inout
&& ((!sym
->attr
.pointer
&& !sym
->attr
.allocatable
)
7324 || sym
->attr
.intent
== INTENT_IN
))
7327 gfc_init_block (&block
);
7329 /* For bind(C), Fortran does not permit mixing 'pointer' with 'contiguous' (or
7330 len=*). Thus, when copy out is needed, the bounds ofthe descriptor remain
7335 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc
)))
7336 data
= gfc_conv_descriptor_data_get (gfc_desc
);
7337 else if (!POINTER_TYPE_P (TREE_TYPE (gfc_desc
)))
7338 data
= gfc_build_addr_expr (NULL
, gfc_desc
);
7341 gfc_init_block (&block2
);
7342 if (sym
->attr
.intent
!= INTENT_IN
)
7344 /* First, create the inner copy-out loop.
7345 for (idx = 0; idx < size; ++idx)
7349 for (dim = 0; dim < rank; ++dim)
7351 shift += (tmpidx % extent[d]) * sm[d]
7352 tmpidx = tmpidx / extend[d]
7354 memcpy (lhs + shift, rhs + idx*elem_len, elem_len)
7356 stmtblock_t loop_body
;
7357 idx
= gfc_create_var (size_type_node
, "arrayidx");
7358 gfc_init_block (&loop_body
);
7359 tree shift
= gfc_create_var (size_type_node
, "shift");
7360 tree tmpidx
= gfc_create_var (size_type_node
, "tmpidx");
7361 gfc_add_modify (&loop_body
, shift
,
7362 build_zero_cst (TREE_TYPE (shift
)));
7363 gfc_add_modify (&loop_body
, tmpidx
, idx
);
7364 stmtblock_t inner_loop
;
7365 gfc_init_block (&inner_loop
);
7366 tree dim
= gfc_create_var (TREE_TYPE (rank
), "dim");
7367 /* shift += (tmpidx % extent[d]) * sm[d] */
7368 tmp
= fold_convert (size_type_node
,
7369 gfc_get_cfi_dim_extent (cfi
, dim
));
7370 tmp
= fold_build2_loc (input_location
, TRUNC_MOD_EXPR
,
7371 size_type_node
, tmpidx
, tmp
);
7372 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7373 size_type_node
, tmp
,
7374 fold_convert (size_type_node
,
7375 gfc_get_cfi_dim_sm (cfi
, dim
)));
7376 gfc_add_modify (&inner_loop
, shift
,
7377 fold_build2_loc (input_location
, PLUS_EXPR
,
7378 size_type_node
, shift
, tmp
));
7379 /* tmpidx = tmpidx / extend[d] */
7380 tmp
= fold_convert (size_type_node
,
7381 gfc_get_cfi_dim_extent (cfi
, dim
));
7382 gfc_add_modify (&inner_loop
, tmpidx
,
7383 fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
7384 size_type_node
, tmpidx
, tmp
));
7385 gfc_simple_for_loop (&loop_body
, dim
,
7386 build_zero_cst (TREE_TYPE (rank
)), rank
, LT_EXPR
,
7387 build_int_cst (TREE_TYPE (dim
), 1),
7388 gfc_finish_block (&inner_loop
));
7391 tmp
= fold_convert (pchar_type_node
,
7392 gfc_get_cfi_desc_base_addr (cfi
));
7393 tmp
= fold_build2 (POINTER_PLUS_EXPR
, pchar_type_node
, tmp
, shift
);
7394 /* memcpy (lhs + shift, rhs + idx*elem_len, elem_len) */
7396 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc
)))
7397 elem_len
= gfc_conv_descriptor_elem_len (gfc_desc
);
7399 elem_len
= gfc_get_cfi_desc_elem_len (cfi
);
7400 rhs
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
7402 rhs
= fold_build2_loc (input_location
, POINTER_PLUS_EXPR
,
7404 fold_convert (pchar_type_node
, data
), rhs
);
7405 tmp
= fold_convert (pvoid_type_node
, tmp
);
7406 rhs
= fold_convert (pvoid_type_node
, rhs
);
7407 call
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
7408 call
= build_call_expr_loc (input_location
, call
, 3, tmp
, rhs
,
7410 gfc_add_expr_to_block (&loop_body
,
7411 fold_convert (void_type_node
, call
));
7412 gfc_simple_for_loop (&block2
, idx
, build_zero_cst (TREE_TYPE (idx
)),
7414 build_int_cst (TREE_TYPE (idx
), 1),
7415 gfc_finish_block (&loop_body
));
7417 call
= builtin_decl_explicit (BUILT_IN_FREE
);
7418 call
= build_call_expr_loc (input_location
, call
, 1, data
);
7419 gfc_add_expr_to_block (&block2
, call
);
7421 /* if (cfi->base_addr != gfc->data) { copy out; free(var) }; return */
7422 tree tmp2
= gfc_get_cfi_desc_base_addr (cfi
);
7423 tmp2
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7424 tmp2
, fold_convert (TREE_TYPE (tmp2
), data
));
7425 tmp
= build3_v (COND_EXPR
, tmp2
, gfc_finish_block (&block2
),
7426 build_empty_stmt (input_location
));
7427 gfc_add_expr_to_block (&block
, tmp
);
7431 /* Update pointer + array data data on exit. */
7432 tmp
= gfc_get_cfi_desc_base_addr (cfi
);
7433 tmp2
= (!sym
->attr
.dimension
7434 ? gfc_desc
: gfc_conv_descriptor_data_get (gfc_desc
));
7435 gfc_add_modify (&block
, tmp
, fold_convert (TREE_TYPE (tmp
), tmp2
));
7437 /* Set string length for len=:, only. */
7438 if (sym
->ts
.type
== BT_CHARACTER
&& !sym
->ts
.u
.cl
->length
)
7440 tmp2
= gfc_get_cfi_desc_elem_len (cfi
);
7441 tmp
= fold_convert (TREE_TYPE (tmp2
), sym
->ts
.u
.cl
->backend_decl
);
7442 if (sym
->ts
.kind
!= 1)
7443 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
7444 TREE_TYPE (tmp2
), tmp
,
7445 build_int_cst (TREE_TYPE (tmp2
), sym
->ts
.kind
));
7446 gfc_add_modify (&block
, tmp2
, tmp
);
7449 if (!sym
->attr
.dimension
)
7452 gfc_init_block (&block2
);
7454 /* Loop: for (i = 0; i < rank; ++i). */
7455 idx
= gfc_create_var (TREE_TYPE (rank
), "idx");
7458 gfc_init_block (&loop_body
);
7459 /* cfi->dim[i].lower_bound = gfc->dim[i].lbound */
7460 gfc_add_modify (&loop_body
, gfc_get_cfi_dim_lbound (cfi
, idx
),
7461 gfc_conv_descriptor_lbound_get (gfc_desc
, idx
));
7462 /* cfi->dim[i].extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1. */
7463 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
7464 gfc_conv_descriptor_ubound_get (gfc_desc
, idx
),
7465 gfc_conv_descriptor_lbound_get (gfc_desc
, idx
));
7466 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
, tmp
,
7467 gfc_index_one_node
);
7468 gfc_add_modify (&loop_body
, gfc_get_cfi_dim_extent (cfi
, idx
), tmp
);
7469 /* d->dim[n].sm = gfc->dim[i].stride * gfc->span); */
7470 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
7471 gfc_conv_descriptor_stride_get (gfc_desc
, idx
),
7472 gfc_conv_descriptor_span_get (gfc_desc
));
7473 gfc_add_modify (&loop_body
, gfc_get_cfi_dim_sm (cfi
, idx
), tmp
);
7475 /* Generate loop. */
7476 gfc_simple_for_loop (&block2
, idx
, build_zero_cst (TREE_TYPE (idx
)),
7477 rank
, LT_EXPR
, build_int_cst (TREE_TYPE (idx
), 1),
7478 gfc_finish_block (&loop_body
));
7479 /* if (gfc->data != NULL) { block2 }. */
7480 tmp
= gfc_get_cfi_desc_base_addr (cfi
),
7481 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
7482 tmp
, null_pointer_node
);
7483 tmp
= build3_v (COND_EXPR
, tmp
, gfc_finish_block (&block2
),
7484 build_empty_stmt (input_location
));
7485 gfc_add_expr_to_block (&block
, tmp
);
7488 /* If optional arg: 'if (arg) { block } else { local_arg = NULL; }'. */
7489 if (sym
->attr
.optional
)
7491 tree present
= fold_build2_loc (input_location
, NE_EXPR
,
7492 boolean_type_node
, cfi_desc
,
7494 tmp
= build3_v (COND_EXPR
, present
, gfc_finish_block (&block
),
7495 build_empty_stmt (input_location
));
7496 gfc_add_expr_to_block (finally
, tmp
);
7499 gfc_add_block_to_block (finally
, &block
);
7502 /* Generate code for a function. */
7505 gfc_generate_function_code (gfc_namespace
* ns
)
7511 tree fpstate
= NULL_TREE
;
7512 stmtblock_t init
, cleanup
, outer_block
;
7514 gfc_wrapped_block try_block
;
7515 tree recurcheckvar
= NULL_TREE
;
7517 gfc_symbol
*previous_procedure_symbol
;
7521 sym
= ns
->proc_name
;
7522 previous_procedure_symbol
= current_procedure_symbol
;
7523 current_procedure_symbol
= sym
;
7525 /* Initialize sym->tlink so that gfc_trans_deferred_vars does not get
7529 /* Create the declaration for functions with global scope. */
7530 if (!sym
->backend_decl
)
7531 gfc_create_function_decl (ns
, false);
7533 fndecl
= sym
->backend_decl
;
7534 old_context
= current_function_decl
;
7538 push_function_context ();
7539 saved_parent_function_decls
= saved_function_decls
;
7540 saved_function_decls
= NULL_TREE
;
7543 trans_function_start (sym
);
7545 gfc_init_block (&init
);
7546 gfc_init_block (&cleanup
);
7547 gfc_init_block (&outer_block
);
7549 if (ns
->entries
&& ns
->proc_name
->ts
.type
== BT_CHARACTER
)
7551 /* Copy length backend_decls to all entry point result
7556 gfc_conv_const_charlen (ns
->proc_name
->ts
.u
.cl
);
7557 backend_decl
= ns
->proc_name
->result
->ts
.u
.cl
->backend_decl
;
7558 for (el
= ns
->entries
; el
; el
= el
->next
)
7559 el
->sym
->result
->ts
.u
.cl
->backend_decl
= backend_decl
;
7562 /* Translate COMMON blocks. */
7563 gfc_trans_common (ns
);
7565 /* Null the parent fake result declaration if this namespace is
7566 a module function or an external procedures. */
7567 if ((ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
7568 || ns
->parent
== NULL
)
7569 parent_fake_result_decl
= NULL_TREE
;
7572 - deallocate intent-out allocatable dummy arguments.
7573 - Create GFC variable which will later be populated by convert_CFI_desc */
7574 if (sym
->attr
.is_bind_c
)
7575 for (gfc_formal_arglist
*formal
= gfc_sym_get_dummy_args (sym
);
7576 formal
; formal
= formal
->next
)
7578 gfc_symbol
*fsym
= formal
->sym
;
7579 if (!is_CFI_desc (fsym
, NULL
))
7581 if (!fsym
->attr
.referenced
)
7583 gfc_conv_cfi_to_gfc (&init
, &cleanup
, fsym
->backend_decl
,
7587 /* Let's now create a local GFI descriptor. Afterwards:
7588 desc is the local descriptor,
7589 desc_p is a pointer to it
7590 and stored in sym->backend_decl
7591 GFC_DECL_SAVED_DESCRIPTOR (desc_p) contains the CFI descriptor
7592 -> PARM_DECL and before sym->backend_decl.
7593 For scalars, decl == decl_p is a pointer variable. */
7595 location_t loc
= gfc_get_location (&sym
->declared_at
);
7596 if (fsym
->ts
.type
== BT_CHARACTER
&& !fsym
->ts
.u
.cl
->length
)
7597 fsym
->ts
.u
.cl
->backend_decl
= gfc_create_var (gfc_array_index_type
,
7599 else if (fsym
->ts
.type
== BT_CHARACTER
&& !fsym
->ts
.u
.cl
->backend_decl
)
7602 gfc_init_se (&se
, NULL
);
7603 gfc_conv_expr (&se
, fsym
->ts
.u
.cl
->length
);
7604 gfc_add_block_to_block (&init
, &se
.pre
);
7605 fsym
->ts
.u
.cl
->backend_decl
= se
.expr
;
7606 gcc_assert(se
.post
.head
== NULL_TREE
);
7608 /* Nullify, otherwise gfc_sym_type will return the CFI type. */
7609 tree tmp
= fsym
->backend_decl
;
7610 fsym
->backend_decl
= NULL
;
7611 tree type
= gfc_sym_type (fsym
);
7612 gcc_assert (POINTER_TYPE_P (type
));
7613 if (POINTER_TYPE_P (TREE_TYPE (type
)))
7614 /* For instance, allocatable scalars. */
7615 type
= TREE_TYPE (type
);
7616 if (TREE_CODE (type
) == REFERENCE_TYPE
)
7617 type
= build_pointer_type (TREE_TYPE (type
));
7618 desc_p
= build_decl (loc
, VAR_DECL
, get_identifier (fsym
->name
), type
);
7619 if (!fsym
->attr
.dimension
)
7621 else if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (desc_p
))))
7623 /* Character(len=*) explict-size/assumed-size array. */
7625 gfc_build_qualified_array (desc
, fsym
);
7629 tree size
= size_in_bytes (TREE_TYPE (TREE_TYPE (desc_p
)));
7630 tree call
= builtin_decl_explicit (BUILT_IN_ALLOCA
);
7631 call
= build_call_expr_loc (input_location
, call
, 1, size
);
7632 gfc_add_modify (&outer_block
, desc_p
,
7633 fold_convert (TREE_TYPE(desc_p
), call
));
7634 desc
= build_fold_indirect_ref_loc (input_location
, desc_p
);
7637 if (fsym
->attr
.optional
)
7639 gfc_allocate_lang_decl (desc_p
);
7640 GFC_DECL_OPTIONAL_ARGUMENT (desc_p
) = 1;
7642 fsym
->backend_decl
= desc_p
;
7643 gfc_conv_cfi_to_gfc (&init
, &cleanup
, tmp
, desc
, fsym
);
7646 gfc_generate_contained_functions (ns
);
7648 has_coarray_vars
= false;
7649 generate_local_vars (ns
);
7651 if (flag_coarray
== GFC_FCOARRAY_LIB
&& has_coarray_vars
)
7652 generate_coarray_init (ns
);
7654 /* Keep the parent fake result declaration in module functions
7655 or external procedures. */
7656 if ((ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
7657 || ns
->parent
== NULL
)
7658 current_fake_result_decl
= parent_fake_result_decl
;
7660 current_fake_result_decl
= NULL_TREE
;
7662 is_recursive
= sym
->attr
.recursive
7663 || (sym
->attr
.entry_master
7664 && sym
->ns
->entries
->sym
->attr
.recursive
);
7665 if ((gfc_option
.rtcheck
& GFC_RTCHECK_RECURSION
)
7666 && !is_recursive
&& !flag_recursive
&& !sym
->attr
.artificial
)
7670 msg
= xasprintf ("Recursive call to nonrecursive procedure '%s'",
7672 recurcheckvar
= gfc_create_var (logical_type_node
, "is_recursive");
7673 TREE_STATIC (recurcheckvar
) = 1;
7674 DECL_INITIAL (recurcheckvar
) = logical_false_node
;
7675 gfc_add_expr_to_block (&init
, recurcheckvar
);
7676 gfc_trans_runtime_check (true, false, recurcheckvar
, &init
,
7677 &sym
->declared_at
, msg
);
7678 gfc_add_modify (&init
, recurcheckvar
, logical_true_node
);
7682 /* Check if an IEEE module is used in the procedure. If so, save
7683 the floating point state. */
7684 ieee
= is_ieee_module_used (ns
);
7686 fpstate
= gfc_save_fp_state (&init
);
7688 /* Now generate the code for the body of this function. */
7689 gfc_init_block (&body
);
7691 if (TREE_TYPE (DECL_RESULT (fndecl
)) != void_type_node
7692 && sym
->attr
.subroutine
)
7694 tree alternate_return
;
7695 alternate_return
= gfc_get_fake_result_decl (sym
, 0);
7696 gfc_add_modify (&body
, alternate_return
, integer_zero_node
);
7701 /* Jump to the correct entry point. */
7702 tmp
= gfc_trans_entry_master_switch (ns
->entries
);
7703 gfc_add_expr_to_block (&body
, tmp
);
7706 /* If bounds-checking is enabled, generate code to check passed in actual
7707 arguments against the expected dummy argument attributes (e.g. string
7709 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) && !sym
->attr
.is_bind_c
)
7710 add_argument_checking (&body
, sym
);
7712 finish_oacc_declare (ns
, sym
, false);
7714 tmp
= gfc_trans_code (ns
->code
);
7715 gfc_add_expr_to_block (&body
, tmp
);
7717 if (TREE_TYPE (DECL_RESULT (fndecl
)) != void_type_node
7718 || (sym
->result
&& sym
->result
!= sym
7719 && sym
->result
->ts
.type
== BT_DERIVED
7720 && sym
->result
->ts
.u
.derived
->attr
.alloc_comp
))
7722 bool artificial_result_decl
= false;
7723 tree result
= get_proc_result (sym
);
7724 gfc_symbol
*rsym
= sym
== sym
->result
? sym
: sym
->result
;
7726 /* Make sure that a function returning an object with
7727 alloc/pointer_components always has a result, where at least
7728 the allocatable/pointer components are set to zero. */
7729 if (result
== NULL_TREE
&& sym
->attr
.function
7730 && ((sym
->result
->ts
.type
== BT_DERIVED
7731 && (sym
->attr
.allocatable
7732 || sym
->attr
.pointer
7733 || sym
->result
->ts
.u
.derived
->attr
.alloc_comp
7734 || sym
->result
->ts
.u
.derived
->attr
.pointer_comp
))
7735 || (sym
->result
->ts
.type
== BT_CLASS
7736 && (CLASS_DATA (sym
)->attr
.allocatable
7737 || CLASS_DATA (sym
)->attr
.class_pointer
7738 || CLASS_DATA (sym
->result
)->attr
.alloc_comp
7739 || CLASS_DATA (sym
->result
)->attr
.pointer_comp
))))
7741 artificial_result_decl
= true;
7742 result
= gfc_get_fake_result_decl (sym
, 0);
7745 if (result
!= NULL_TREE
&& sym
->attr
.function
&& !sym
->attr
.pointer
)
7747 if (sym
->attr
.allocatable
&& sym
->attr
.dimension
== 0
7748 && sym
->result
== sym
)
7749 gfc_add_modify (&init
, result
, fold_convert (TREE_TYPE (result
),
7750 null_pointer_node
));
7751 else if (sym
->ts
.type
== BT_CLASS
7752 && CLASS_DATA (sym
)->attr
.allocatable
7753 && CLASS_DATA (sym
)->attr
.dimension
== 0
7754 && sym
->result
== sym
)
7756 tmp
= CLASS_DATA (sym
)->backend_decl
;
7757 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
7758 TREE_TYPE (tmp
), result
, tmp
, NULL_TREE
);
7759 gfc_add_modify (&init
, tmp
, fold_convert (TREE_TYPE (tmp
),
7760 null_pointer_node
));
7762 else if (sym
->ts
.type
== BT_DERIVED
7763 && !sym
->attr
.allocatable
)
7766 /* Arrays are not initialized using the default initializer of
7767 their elements. Therefore only check if a default
7768 initializer is available when the result is scalar. */
7769 init_exp
= rsym
->as
? NULL
7770 : gfc_generate_initializer (&rsym
->ts
, true);
7773 tmp
= gfc_trans_structure_assign (result
, init_exp
, 0);
7774 gfc_free_expr (init_exp
);
7775 gfc_add_expr_to_block (&init
, tmp
);
7777 else if (rsym
->ts
.u
.derived
->attr
.alloc_comp
)
7779 rank
= rsym
->as
? rsym
->as
->rank
: 0;
7780 tmp
= gfc_nullify_alloc_comp (rsym
->ts
.u
.derived
, result
,
7782 gfc_prepend_expr_to_block (&body
, tmp
);
7787 if (result
== NULL_TREE
|| artificial_result_decl
)
7789 /* TODO: move to the appropriate place in resolve.cc. */
7790 if (warn_return_type
> 0 && sym
== sym
->result
)
7791 gfc_warning (OPT_Wreturn_type
,
7792 "Return value of function %qs at %L not set",
7793 sym
->name
, &sym
->declared_at
);
7794 if (warn_return_type
> 0)
7795 suppress_warning (sym
->backend_decl
);
7797 if (result
!= NULL_TREE
)
7798 gfc_add_expr_to_block (&body
, gfc_generate_return ());
7801 /* Reset recursion-check variable. */
7802 if (recurcheckvar
!= NULL_TREE
)
7804 gfc_add_modify (&cleanup
, recurcheckvar
, logical_false_node
);
7805 recurcheckvar
= NULL
;
7808 /* If IEEE modules are loaded, restore the floating-point state. */
7810 gfc_restore_fp_state (&cleanup
, fpstate
);
7812 /* Finish the function body and add init and cleanup code. */
7813 tmp
= gfc_finish_block (&body
);
7814 /* Add code to create and cleanup arrays. */
7815 gfc_start_wrapped_block (&try_block
, tmp
);
7816 gfc_trans_deferred_vars (sym
, &try_block
);
7817 gfc_add_init_cleanup (&try_block
, gfc_finish_block (&init
),
7818 gfc_finish_block (&cleanup
));
7820 /* Add all the decls we created during processing. */
7821 decl
= nreverse (saved_function_decls
);
7826 next
= DECL_CHAIN (decl
);
7827 DECL_CHAIN (decl
) = NULL_TREE
;
7831 saved_function_decls
= NULL_TREE
;
7833 gfc_add_expr_to_block (&outer_block
, gfc_finish_wrapped_block (&try_block
));
7834 DECL_SAVED_TREE (fndecl
) = gfc_finish_block (&outer_block
);
7837 /* Finish off this function and send it for code generation. */
7839 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl
)) = fndecl
;
7841 DECL_SAVED_TREE (fndecl
)
7842 = fold_build3_loc (DECL_SOURCE_LOCATION (fndecl
), BIND_EXPR
, void_type_node
,
7843 decl
, DECL_SAVED_TREE (fndecl
), DECL_INITIAL (fndecl
));
7845 /* Output the GENERIC tree. */
7846 dump_function (TDI_original
, fndecl
);
7848 /* Store the end of the function, so that we get good line number
7849 info for the epilogue. */
7850 cfun
->function_end_locus
= input_location
;
7852 /* We're leaving the context of this function, so zap cfun.
7853 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
7854 tree_rest_of_compilation. */
7859 pop_function_context ();
7860 saved_function_decls
= saved_parent_function_decls
;
7862 current_function_decl
= old_context
;
7864 if (decl_function_context (fndecl
))
7866 /* Register this function with cgraph just far enough to get it
7867 added to our parent's nested function list.
7868 If there are static coarrays in this function, the nested _caf_init
7869 function has already called cgraph_create_node, which also created
7870 the cgraph node for this function. */
7871 if (!has_coarray_vars
|| flag_coarray
!= GFC_FCOARRAY_LIB
)
7872 (void) cgraph_node::get_create (fndecl
);
7875 cgraph_node::finalize_function (fndecl
, true);
7877 gfc_trans_use_stmts (ns
);
7878 gfc_traverse_ns (ns
, gfc_emit_parameter_debug_info
);
7880 if (sym
->attr
.is_main_program
)
7881 create_main_function (fndecl
);
7883 current_procedure_symbol
= previous_procedure_symbol
;
7888 gfc_generate_constructors (void)
7890 gcc_assert (gfc_static_ctors
== NULL_TREE
);
7898 if (gfc_static_ctors
== NULL_TREE
)
7901 fnname
= get_file_function_name ("I");
7902 type
= build_function_type_list (void_type_node
, NULL_TREE
);
7904 fndecl
= build_decl (input_location
,
7905 FUNCTION_DECL
, fnname
, type
);
7906 TREE_PUBLIC (fndecl
) = 1;
7908 decl
= build_decl (input_location
,
7909 RESULT_DECL
, NULL_TREE
, void_type_node
);
7910 DECL_ARTIFICIAL (decl
) = 1;
7911 DECL_IGNORED_P (decl
) = 1;
7912 DECL_CONTEXT (decl
) = fndecl
;
7913 DECL_RESULT (fndecl
) = decl
;
7917 current_function_decl
= fndecl
;
7919 rest_of_decl_compilation (fndecl
, 1, 0);
7921 make_decl_rtl (fndecl
);
7923 allocate_struct_function (fndecl
, false);
7927 for (; gfc_static_ctors
; gfc_static_ctors
= TREE_CHAIN (gfc_static_ctors
))
7929 tmp
= build_call_expr_loc (input_location
,
7930 TREE_VALUE (gfc_static_ctors
), 0);
7931 DECL_SAVED_TREE (fndecl
) = build_stmt (input_location
, EXPR_STMT
, tmp
);
7937 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl
)) = fndecl
;
7938 DECL_SAVED_TREE (fndecl
)
7939 = build3_v (BIND_EXPR
, decl
, DECL_SAVED_TREE (fndecl
),
7940 DECL_INITIAL (fndecl
));
7942 free_after_parsing (cfun
);
7943 free_after_compilation (cfun
);
7945 tree_rest_of_compilation (fndecl
);
7947 current_function_decl
= NULL_TREE
;
7951 /* Translates a BLOCK DATA program unit. This means emitting the
7952 commons contained therein plus their initializations. We also emit
7953 a globally visible symbol to make sure that each BLOCK DATA program
7954 unit remains unique. */
7957 gfc_generate_block_data (gfc_namespace
* ns
)
7962 /* Tell the backend the source location of the block data. */
7964 gfc_set_backend_locus (&ns
->proc_name
->declared_at
);
7966 gfc_set_backend_locus (&gfc_current_locus
);
7968 /* Process the DATA statements. */
7969 gfc_trans_common (ns
);
7971 /* Create a global symbol with the mane of the block data. This is to
7972 generate linker errors if the same name is used twice. It is never
7975 id
= gfc_sym_mangled_function_id (ns
->proc_name
);
7977 id
= get_identifier ("__BLOCK_DATA__");
7979 decl
= build_decl (input_location
,
7980 VAR_DECL
, id
, gfc_array_index_type
);
7981 TREE_PUBLIC (decl
) = 1;
7982 TREE_STATIC (decl
) = 1;
7983 DECL_IGNORED_P (decl
) = 1;
7986 rest_of_decl_compilation (decl
, 1, 0);
7990 /* Process the local variables of a BLOCK construct. */
7993 gfc_process_block_locals (gfc_namespace
* ns
)
7997 saved_local_decls
= NULL_TREE
;
7998 has_coarray_vars
= false;
8000 generate_local_vars (ns
);
8002 if (flag_coarray
== GFC_FCOARRAY_LIB
&& has_coarray_vars
)
8003 generate_coarray_init (ns
);
8005 decl
= nreverse (saved_local_decls
);
8010 next
= DECL_CHAIN (decl
);
8011 DECL_CHAIN (decl
) = NULL_TREE
;
8015 saved_local_decls
= NULL_TREE
;
8019 #include "gt-fortran-trans-decl.h"